The term Application Programming Interface (API) can be applied in many instances. By
definition, an API is an application-supplied program or procedure that allows an application
program, which is written in a high-level language, to access specific data or functions of the
application without requiring access to the source code or requiring a detailed understanding
of the functions’ internal workings.
It is quite reasonable, and common, for any software application to provide APIs that provide
access to “complex” portions of the application, for example, an application might provide an
API that validates a product code or another API that calculates a price. Of course the
supplier of the application provides adequate documentation on how to use the API.
IBM® supplies APIs that allow programmers to use specific data or functions of the operating
system or a licensed program. The adequacy of the documentation is open to interpretation.

list *DTAARA in all Libraries

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
     H OPTION(*NODEBUGIO) ACTGRP(*NEW)                                                              
‚     *************************************************************************                    €
‚     *                                                                                            €
‚     *  Stand Alone variables                                                                     €
‚     *                                                                                            €
     d AllText         s             10    Inz('*ALL')                                              
     d Chr8            s              8                                                            
     d Count           s              4  0                                                          
     d Count2          s              4  0                                                          
     d cymd            s              7  0                                                          
     d CreateDateISO   s               D                                                            
     d EntryFmt        s             10    inz('*FIRST')                                            
     d Fds#            s             10i 0                                                          
    d FFds#           s             10i 0                                                          
    d FileLib         s             20                                                            
     d GenLen          s              8                                                            
     d Header          s           2000                                                            
     d I               s             15  0                                                          
     d Infile          s             10                                                            
     d InLibrary       s             10                                                            
     d InType          s             10                                                            
     d MyFiles         s             10    dim(1000)                                                
     d MyFilesFound    s             10    dim(1000)                                                
     d ObjectLib       s             20                                                            
     d ReceiveVr2      s            100                                                            
     d RelRecNbr       s              4  0                                                          
     d RelRecHi#       s              4  0                                                          
    d SpaceVal        s              1    inz(*BLANKS)                                            
     d SpaceAuth       s             10    inz('*CHANGE')                                          
     d SpaceText       s             50    inz(*BLANKS)                                            
     d SpaceRepl       s             10    inz('*YES')                                              
     d SpaceAttr       s             10    inz(*BLANKS)                                            
     d TodayISO        s               d                                                            
     d UserSpaceOut    s             20                                                            
     d Worktype        s             10    inz('*DTAARA')                                          
‚     *                                                                                            €
‚     *  Data structures                                                                           €
     d GENDS2          ds                  qualified                                                
     d  Filler1                     116                                                            
     d  OffsetHdr                    10i 0                                                          
     d  SizeHeader                   10i 0                                                          
     d  OffsetList                   10i 0                                                          
     d  Filler2                       4                                                            
     d  NbrInList                    10i 0                                                          
     d  SizeEntry                    10i 0                                                          
                                                                                                   
     d HeaderDs        ds                                                                          
     d  OutFileNam                   10    overlay(HeaderDS:1)                                      
     d  OutLibName                   10    overlay(HeaderDS:11)                                    
     d  OutType                       5    overlay(HeaderDS:21)                                    
     d  OutFormat                    10    overlay(HeaderDS:31)                                    
     d  RecordLen                    10i 0 overlay(HeaderDS:41)                                    
                                                                                                   
     d ListDs          ds                  Qualified                                                
     d  FieldName                    10    overlay(ListDS:1)                                        
     d  FieldType                     1    overlay(ListDS:11)                                      
     d  BufferOut                    10i 0 overlay(ListDS:13)                                      
     d  FieldLen                     10i 0 overlay(ListDS:21)                                      
     d  Digits                       10i 0 overlay(ListDS:25)                                      
     d  Decimals                     10i 0 overlay(ListDS:29)                                      
     d  FieldDesc                    50    overlay(ListDS:33)                                      
                                                                                                   
     d APIErrorDS      ds                  Qualified                                                
     d  BytesP                       10I 0 inz(%size(apiErrorDS))                                  
     d  BytesA                       10I 0 inz(0)                                                  
     d  Messageid                     7                                                            
     d  Reserved                      1                                                            
     d  messagedta                  128                                                            
                                                                                                   
     d                 ds                                                                          
     d  StartPosit                   10i 0                                                          
     d  StartLen                     10i 0                                                          
     d  SpaceLen                     10i 0                                                          
     d  ReceiveLen                   10i 0                                                          
     d  MessageKey                   10i 0                                                          
     d  MsgDtaLen                    10i 0                                                          
     d  MsgQueNbr                    10i 0                                                          
      *                                                                                            
     dGenSpcPtr                        *                                                            
     dLstSpcPtr                        *                                                            
     dHdrPtr                           *                                                            
                                                                                                   
      *                                                                                            
     d GENDS           ds                                                                          
     d  OffsetHdr                    10i 0  overlay(GENDS:1)                                        
     d  NbrInList                    10i 0  overlay(GENDS:9)                                        
     d  SizeEntry                    10i 0  overlay(GENDS:13)                                      
      *                                                                                            
      * Date structure for retriving userspace info                                                
      *                                                                                            
     d InputDs         DS                                                                          
     d  UserSpace              1     20                                                            
     d  SpaceName              1     10                                                            
     d  SpaceLib              11     20                                                            
     d  InpFileLib            29     48                                                            
     d  InpFFilNam            29     38                                                            
     d  InpFFilLib            39     48                                                            
     d  InpRcdFmt             49     58                                                            
      *                                                                                            
     d ListQPAD        ds                  qualified                                                
     d  Object                       10                                                            
     d  Library                      10                                                            
     d  ObjectType                   10                                                            
     d  InfoStatus                    1                                                            
     d  ExtObjAttrib                 10                                                            
     d  Description                  50                                                            
     **-- Object description structure OBJD0400:  ----------------------------**                    
     d ObjectDs        ds                  qualified  inz                                          
     d  ObjDscLen                    10i 0                                                          
     d  ObjDscSiz                    10i 0                                                          
     d  ObjNam                       10                                                            
     d  ObjLib                       10                                                            
     d  ObjTyp                       10                                                            
     d  ObjRtnLib                    10                                                            
     d  ObjAsp                       10i 0                                                          
     d  ObjOwnr                      10                                                            
     d  ObjDmn                        2                                                            
     d  ObjCrtDat                    13                                                            
     d  ObjChgDat                    13                                                            
      *                                                                                            
     d  ObjAtr                       10                                                            
     d  ObjTxt                       50                                                            
     d  ObjSrcFil                    10                                                            
     d  ObjSrcLib                    10                                                            
     d  ObjSrcMbr                    10                                                            
      *                                                                                            
     d  ObjSrcChgDat                 13                                                            
     d  ObjSrcSavDat                 13                                                            
     d  ObjSrcRstDat                 13                                                            
     d  ObjCrtUsr                    10                                                            
     d  ObjCrtSys                     8                                                            
     d  ObjResDat                     7                                                            
     d  ObjSavSiz                    10i 0                                                          
     d  ObjSavSeq                    10i 0                                                          
     d  ObjStg                       10                                                            
     d  ObjSavCmd                    10                                                            
     d  ObjSavVolId                  71                                                            
     d  ObjSavDvc                    10                                                            
     d  ObjSavFil                    10                                                            
     d  ObjSavLib                    10                                                            
     d  ObjSavLvl                     9                                                            
     d  ObjCompiler                  16                                                            
     d  ObjLvl                        8                                                            
     d  ObjUsrChg                     1                                                            
     d  ObjLicPgm                    16                                                            
     d  ObjPtf                       10                                                            
     d  ObjApar                      10                                                            
      *  start of four                                                                              
     d  ObjUseDat                     7                                                            
     d  ObjUsgInf                     1                                                            
     d  ObjUseDay                    10i 0                                                          
     d  ObjSiz                       10i 0                                                          
     d  ObjSizMlt                    10i 0                                                          
     d  ObjCprSts                     1                                                            
     d  ObjAlwChg                     1                                                            
     d  ObjChgByPgm                   1                                                            
     d  ObjUsrAtr                    10                                                            
     d  ObjOvrflwAsp                  1                                                            
     d  ObjSavActDat                  7                                                            
     d  ObjSavActTim                  6                                                            
     d  ObjAudVal                    10                                                            
     d  ObjPrmGrp                    10                                                            
                                                                                                   
     **-- Retrieve object description:  -------------------------------                            
     d $RtvObjD        Pr                  ExtPgm( 'QUSROBJD' )                                    
     d  RoRcvVar                  32767a         Options( *VarSize )                                
     d  RoRcvVarLen                  10i 0 Const                                                    
     d  RoFmtNam                      8a   Const                                                    
     d  RoObjNamQ                    20a   Const                                                    
     d  RoObjTyp                     10a   Const                                                    
     d  RoError                   32767a         Options( *VarSize )                                
     **-- List objects:   ---------------------------------------------                            
     d $ListObjects    Pr                  ExtPgm( 'QUSLOBJ' )                                      
     d  userspace                    20a   Const                                                    
     d  format                        8a   Const                                                    
     d  objectlib                    20a   Const                                                    
     d  type                         10a   Const                                                    
     **-- Userspace pointer: ------------------------------------------                            
     d $Userspace      Pr                  ExtPgm( 'QUSRTVUS' )                                    
     d  userspace                    20a   Const                                                    
     d  start                        10i 0 Const                                                    
     d  Length                       10i 0 Const                                                    
     d  Returned                  32767a         Options( *VarSize )                                
     **-- Create Space:   ---------------------------------------------                            
     d $CreateSpace    Pr                  ExtPgm( 'QUSCRTUS' )                                    
     d  UserSpaceOut                 20a   Const                                                    
     d  SpaceAttr                    10    Const                                                    
     d  SpaceLen                     10i 0 Const                                                    
     d  SpaceVal                      1a   Const                                                    
     d  SpaceAuth                    10a   Const                                                    
     d  SpaceText                    50a   Const                                                    
     d  SpaceRepl                    10a   Const                                                    
     d  APIErrorDs                32767a         Options( *VarSize )                                
                                                                                                   
‚     *---------------------------------------------------------------                             €
‚     *  M A I N   L I N E                                                                         €
‚     *---------------------------------------------------------------                             €
‚     *                                                                                            €
      /free                                                                                        
          // find all files in the passed in Library                                                
                 Spacename = 'MYPADS';                                                              
                 exsr $QUSCRTUS;                                                                    
                                                                                                   
                 ObjectLib =  '*ALL      ' + '*ALL';                                                
         //                                                                                        
         // List all the outqueues to the user space                                                
         //                                                                                        
                 $ListObjects( Userspace : 'OBJL0200' : ObjectLib : WorkType);                      
         //                                                                                        
         // Retrive header entry and process the user space                                        
         //                                                                                        
                 StartPosit = 125;                                                                  
                 StartLen   = 16;                                                                  
                 $UserSpace( Userspace : StartPosit : StartLen : GENDS);                            
                                                                                                   
                 StartPosit = OffsetHdr + 1;                                                        
                 StartLen = %size(ListQPAD);                                                        
         //                                                                                        
‚        // Do for number of outqueues in the userspace                            €                
         //                                                                                        
                                                                                                   
B1               for count = 1 to  NbrInList;                                                      
                  $UserSpace( Userspace : StartPosit : StartLen : ListQPAD);                        
                  StartPosit += SizeEntry;                                                          
                  if %scan('QSYS': ListQPAD.Library) = *zeros;                                      
                   // retrieve the device description                                              
                   $RtvObjD( ObjectDS                                                              
                             : %Size( ObjectDS )                                                    
                             : 'OBJD0400'                                                          
                             : ListQPAD.Object + ListQPAD.library                                  
                             : ListQPAD.ObjectType                                                  
                             : ApiErrorDS                                                          
                                              );                                                    
                                                                                                   
                  endif;                                                                            
                 endfor;                                                                            
                                                                                                   
                 clear Myfiles;                                                                    
                 reset Fds#;                                                                        
                clear MyFiles;                                                                    
                 reset fds#;                                                                        
                                                                                                   
                 for count = 1 to FFds#;                                                            
                endfor;                                                                            
                                                                                                   
                 *inlr = *on;                                                                      
                                                                                                   
        //--------------------------------------------------------                                  
        // $QUSCRTUS - create userspace                                                            
        //--------------------------------------------------------                                  
                 begsr $QUSCRTUS;                                                                  
                                                                                                   
                  APIErrorDS.BytesP = 116;                                                          
                  SpaceLib = 'QTEMP';                                                              
                                                                                                   
               //                                                                                  
               // Create the user space                                                            
               //                                                                                  
                  $CreateSpace( Userspace : SpaceAttr : 4096 :                                      
                                SpaceVal : SpaceAuth : SpaceText : SpaceRepl:                      
                                APIErrorDs);                                                        
                 endsr;

Example Dynamic Screen QsnWrtDta

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
     h Option(*NODEBUGIO)  DFTACTGRP(*NO)                                                          
                                                                                                   
      /copy current,DYNO_CP                                                                        
                                                                                                   
     d $Screen1        pr           500a   varying                                                  
     d   Line                        78a   const dim(24) options(*varsize)                          
     d   NumLines                    10i 0 value                                                    
     d   AnsLen                      10i 0 value                                                    
     d   DataOut                    256                                                            
      *                                                                                            
      * local variables                                                                            
      *                                                                                            
     d Abort           s              1n                                                            
     d Choice#         s             10i 0                                                          
    d cmdlength       s             15  5                                                          
     d cmdstring       s            512                                                            
     d dec8            s              8  0                                                          
     d decimalanswer   s              1  0                                                          
     d end             s              3  0                                                          
     d endscreen1      s               n                                                            
     d Essay           s            500A                                                            
     d filename        s             80                                                            
     d foundAS400      s              3  0                                                          
     d Directory       s            256    varying                                                  
     d GrapTheFile     s               n                                                            
     d itemnumber      s              7  0                                                          
     d length          s             10i 0                                                          
     d Lines           s             78A   dim(24)                                                  
     d Mycount         s             10i 0                                                          
     d newname         s            512                                                            
     d password        s             10    inz('@PASSWORD')                                          
     d processing      s               n                                                            
     d Q               s              1    inz('''')                                                
      *                                        dns name or Ip address                              
     d remoteIP        s             15    inz('@SERVERNAME')                                            
     d*remoteIP        s             15    inz('192.168.1.100')                                    
     d reply           s              1                                                            
     d screenatr       s              1                                                            
     d screenerror     s               n                                                            
     d start           s              3  0                                                          
     d string          s            512                                                            
     d sqlstmt         s           2500    varying                                                  
     d teststring      s            512                                                            
     d theanswer       s              1                                                            
     d userid          s             10    inz('@USERID')                                            
     d workfile        s             80                                                            
     d workPO#         s              7  0                                                          
    d workPOLine#     s              3  0                                                          
     *                                                                                            
      * This is the return data from subprocedure $screen                                          
      * left at 256 so you can add bunch more return values                                        
      *                                                                                            
     d  dataout        ds           256    qualified inz                                            
     d    F3                           n   overlay(dataout:1)                                      
     d    Choice                      1    overlay(dataout:*next)                                  
      **---------------------------------------------------------------                            
      * external calls                                                                              
      **---------------------------------------------------------------                            
     d $command        pr                  extpgm( 'QCMDEXC' )                                      
     d   cmdstring                 2000    options( *varsize ) const                                
     d   cmdlength                   15  5                     const                                
      *                                                                                            
     d  mysqldata      ds                  qualified  inz                                          
     d   String                     512                                                            
      *                                                                                            
     d  mysqldata2     ds                  qualified  inz                                          
     d   String                     512                                                            
      *                                                                                            
     d  mysqldata3     ds                  qualified  inz                                          
     d   String                     512                                                            
      *                                                                                            
      * Sql functions                                                                              
      *                                                                                            
     d openlist        pr                                                                          
     d fetchnext       pr              n                                                            
     d closelist       pr                                                                          
                                                                                                   
      **---------------------------------------------------------------                            
      /free                                                                                        
                                                                                                   
         *inlr = *on;                                                                              
                                                                                                   
                                                                                                   
         directory = '/pdm/data/wkgshare/pfs/AS400_AuxiliaryFolder_wl ';                            
                                                                                                   
                                                                                                   
         exec sql  set option commit=*none,datfmt=*iso,                                            
                       closqlcsr=*ENDMOD;                                                          
                                                                                                   
                                                                                                   
        //--------------------------------------------------------                                  
        //     M A I N   L I N E                                                                    
        //--------------------------------------------------------                                  
                                                                                                   
         // ftp to server and get directory listing                                                
                                                                                                   
             exsr $OverrideFiles;                                                                  
             exsr $ftpDirList;                                                                      
             exsr $startftp;                                                                        
                                                                                                   
             exsr $readoutput;                                                                      
             return;                                                                                
                                                                                                   
        //--------------------------------------------------------                                  
        // $ReadOutput - read the output file                                                      
        //--------------------------------------------------------                                  
             begsr $ReadOutput;                                                                    
                                                                                                   
                                                                                                   
              reset choice#;                                                                        
             // setup the title                                                                    
              Mycount +=1;                                                                          
              Lines(Mycount) = 'Select File to Process';                                            
              // add blank line                                                                    
              Mycount +=1;                                                                          
              Lines(Mycount) = *blanks;                                                            
                                                                                                   
                                                                                                   
              sqlstmt = 'Select * from OUTPUT';                                                    
                                                                                                   
               openList();                                                                          
               dow fetchNext();                                                                    
                // look for the direcotry listing and the file name                                
                start = %scan('6-':mysqldata3.string);                                              
                // don't loop forever!                                                              
                FoundAS400 = %scan('AS400':mysqldata3.string);                                      
                if start > *zeros and FoundAS400 > *zeros;                                          
                 end = %scan('.txt':mysqldata3.string);                                            
                 if end > *zeros;                                                                  
                                                                                                   
                  length = end+4 - start;                                                          
                  filename = %subst(mysqldata3.string:start:length);                                
                                                                                                   
                  // increment the letter                                                          
                  Choice#+=1;                                                                      
                 Mycount+=1;                                                                      
                  lines(Mycount) = ' ' + %char(Choice#) + ') ' +                                    
                 %trim(filename);                                                                  
                                                                                                   
                  exsr $processfile;                                                                
                 endif;                                                                            
                endif;                                                                              
                                                                                                   
               enddo;                                                                              
               closeList();                                                                        
                                                                                                   
               // all files .txt are listed now show screen                                        
                                                                                                   
               if Mycount <= 2;                                                                    
                Mycount+=1;                                                                        
                lines(Mycount) = '** No Records Found **';                                          
               endif;                                                                              
                                                                                                   
               reset endscreen1;                                                                    
               dow not(EndScreen1);                                                                
                if not(screenerror);                                                                
                 lines(20) = *blanks;                                                              
                endif;                                                                              
                reset dataout;                                                                      
                Dataout = $Screen1(lines:20:1:DataOut);                                            
                reset screenerror;                                                                  
                // this is the error line                                                          
                select;                                                                            
                 when dataout.F3 = *on;                                                            
                  EndScreen1 = *on;                                                                
                  return;                                                                          
                 other;     // check answer                                                        
                  TheAnswer = dataout.choice;                                                      
                                                                                                   
                  exsr $validate;                                                                  
                  if not(screenerror);                                                              
                   exsr $getthefile;                                                                
                  endif;                                                                            
                                                                                                   
                endsl;                                                                              
                                                                                                   
               enddo;                                                                              
                                                                                                   
             endsr;                                                                                
                                                                                                   
        //--------------------------------------------------------                                  
        // $Validate - validate the return selection                                                
        //--------------------------------------------------------                                  
             begsr $Validate;                                                                      
                                                                                                   
              reset screenerror;                                                                    
              // validate the answer                                                                
                                                                                                   
                                                                                                   
              if %check(' 0123456789':TheAnswer) > *zeros;                                          
               lines(20) = 'Entry ' + TheAnswer + ' is invalid';                                    
               screenerror = *on;                                                                  
              else;                                                                                
               TheAnswer = %xlate(' ':'0':TheAnswer);                                              
               DecimalAnswer = %dec(TheAnswer:1:0);                                                
               if DecimalAnswer > Choice#;                                                          
               lines(20) = 'Entry ' + TheAnswer + ' is Greater than ' +                            
                 %char(choice#);                                                                    
               screenerror = *on;                                                                  
               endif;                                                                              
              endif;                                                                                
                                                                                                   
                                                                                                   
             endsr;                                                                                
                                                                                                   
        //--------------------------------------------------------                                  
        // $GettheFile - get the file from FTP and process it                                      
        //--------------------------------------------------------                                  
             begsr $GettheFile;                                                                    
                                                                                                   
                                                                                                   
                                                                                                   
             endsr;                                                                                
                                                                                                   
        //--------------------------------------------------------                                  
        // $ProcessFile  - grab the file and do the work                                            
        //--------------------------------------------------------                                  
             begsr $ProcessFile;                                                                    
                                                                                                   
              // create pf in qtemp and do processing                                              
              cmdstring = 'CRTPF QTEMP/MYFILE RCDLEN(512) ';                                        
              cmdlength = %len(%trim(cmdstring));                                                  
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                    
              on-error;                                                                            
               cmdstring = 'CLRPFM QTEMP/MYFILE ';                                                  
               cmdlength = %len(%trim(cmdstring));                                                  
              endmon;                                                                              
                                                                                                   
              // remove any get commands from the imput file                                        
              exec sql                                                                              
               delete from QTEMP/MYFILE                                                            
               where myfile like '%MYFILE%';                                                        
                                                                                                   
              exec sql                                                                              
               delete from QTEMP/INPUT                                                              
               where myfield like '%DIR%';                                                          
                                                                                                   
              processing = *on;                                                                    
              exsr $OverrideFiles;                                                                  
              exsr $FtpDirList;                                                                    
              processing = *off;                                                                    
                                                                                                   
              mysqldata2.String = 'Get ' + %trim(filename) + ' QTEMP/MYFILE' +                      
               ' (replace ';                                                                        
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                        
                                                                                                   
              // change extension of .txt file to .done                                            
              workfile = Filename;                                                                  
              end = %scan('.txt':workfile);                                                        
              %subst(workfile:end:5) = '.done';                                                    
              mysqldata2.String = 'Rename ' + %trim(filename) +                                    
              ' ' + %trim(workfile);                                                                
          //  exec sql                                                                              
          //   insert into QTEMP/INPUT values(:mysqldata2);                                        
              exsr $startFTP;                                                                      
                                                                                                   
             endsr;                                                                                
                                                                                                   
        //--------------------------------------------------------                                  
        // $OverrideFiles - create input & output override files                                    
        //--------------------------------------------------------                                  
             begsr $OverrideFiles;                                                                  
                                                                                                   
              cmdstring = 'DLTOVR INPUT';                                                          
              cmdlength = %len(%trim(cmdstring));                                                  
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                    
              on-error;                                                                            
              endmon;                                                                              
                                                                                                   
              cmdstring = 'DLTOVR OUTPUT';                                                          
              cmdlength = %len(%trim(cmdstring));                                                  
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                    
              on-error;                                                                            
              endmon;                                                                              
                                                                                                   
              cmdstring = 'CLRPFM FILE(QTEMP/INPUT)';                                              
              cmdlength = %len(%trim(cmdstring));                                                  
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                    
              on-error;                                                                            
               exec sql                                                                            
                create table QTEMP/INPUT                                                            
                (MyField  char(512));                                                              
              endmon;                                                                              
                                                                                                   
              cmdstring = 'CLRPFM FILE(QTEMP/OUTPUT)';                                              
              cmdlength = %len(%trim(cmdstring));                                                  
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                    
              on-error;                                                                            
               exec sql                                                                            
                create table QTEMP/OUTPUT                                                          
                (MyField  char(512));                                                              
              endmon;                                                                              
                                                                                                   
             endsr;                                                                                
        //--------------------------------------------------------                                  
        // $FtpDirList - get direcotory listing                                                    
        //--------------------------------------------------------                                  
             begsr $FtpDirList;                                                                    
                                                                                                   
             // commands to run on server                                                          
                                                                                                   
              mysqldata2.string = %trim(userid) + ' ' + %trim(password);                            
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                        
                                                                                                   
              mysqldata2.String = 'ASCII';                                                          
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                        
                                                                                                   
              mysqldata2.String =                                                                  
               'cd  ' + directory;                                                                  
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                        
                                                                                                   
              if processing = *off;                                                                
               mysqldata2.String =  'Dir ' ;                                                        
              endif;                                                                                
                                                                                                   
              exec sql                                                                              
               insert into QTEMP/INPUT values(:mysqldata2);                                        
                                                                                                   
              cmdstring = 'OVRDBF FILE(INPUT) TOFILE(QTEMP/INPUT)' +                                
                          ' OVRSCOPE(*JOB) ';                                                      
              cmdlength = %len(%trim(cmdstring));                                                  
              $command(cmdstring : cmdlength);                                                      
                                                                                                   
              cmdstring = 'OVRDBF FILE(OUTPUT) TOFILE(QTEMP/OUTPUT)' +                              
                          ' OVRSCOPE(*JOB) ';                                                      
              cmdlength = %len(%trim(cmdstring));                                                  
              $command(cmdstring : cmdlength);                                                      
                                                                                                   
             endsr;                                                                                
                                                                                                   
        //--------------------------------------------------------                                  
        // $StartFTP;   Start FTP...                                                                
        //--------------------------------------------------------                                  
             begsr $StartFTP;                                                                      
                                                                                                   
              cmdstring = 'STRTCPFTP ' + Q + %trim(remoteIp)  + Q  ;                                
              cmdlength = %len(%trim(cmdstring));                                                  
              monitor;                                                                              
               $command(cmdstring : cmdlength);                                                    
              on-error;                                                                            
              endmon;                                                                              
                                                                                                   
             endsr;                                                                                
                                                                                                   
      /end-free                                                                                    
                                                                                                   
      *--------------------------------------------------------                                    
      *  $Screen1():     Show Screen1 (Remote files via FTP)                                        
      *                                                                                            
      *     Line = (input) array of lines of text containing                                        
      *                 the question to ask                                                        
      * NumLines = (input) number of lines in the Line array                                        
      *   AnsLen = (input) size of answer blank                                                    
      *    DataOut = (output) position 1 F3 positon 2 answer                                        
      *                                                                                            
      * Returns the user's answer                                                                  
      *--------------------------------------------------------                                    
     p $Screen1        B                                                                            
                                                                                                   
     d $Screen1        PI           500A   varying                                                  
     d   Line                        78A   const                                                    
     d                                     dim(24) options(*varsize)                                
     d   NumLines                    10I 0 value                                                    
     d   AnsLen                      10I 0 value                                                    
     d   DataOut                    256                                                            
                                                                                                   
     d cmdbuf          s                   like(Qsn_Cmd_Buf_T)                                      
     d inpbuf          s                   like(Qsn_Inp_Buf_T)                                      
     d prompt          s             70A   varying                                                  
     d NRF             s             50    inz('
** No Records Found **')                            
     d skipthis        s               n                                                            
     d len             s             10I 0                                                          
     d data            s            132A   varying                                                  
     d x               s             10I 0                                                          
     d Row             s              3U 0                                                          
     d Answer          s            500A   varying                                                  
      *                                                                                            
     d InputData       ds                  qualified                                                
     d                                     based(p_InputData)                                      
     d   Row                          3U 0                                                          
     d   Col                          3U 0                                                          
     d   AID                          1A                                                            
     d   Field                      500A                                                            
      /free                                                                                        
                                                                                                   
          // ----------------------------------------------                                        
          //  Create Input/Output buffers and clear them                                            
          // ----------------------------------------------                                        
          cmdbuf = QsnCrtCmdBuf(100: 50: 0: *OMIT: *OMIT);                                          
          inpbuf = QsnCrtInpBuf(200: 50: 0: *OMIT: *OMIT);                                          
          QsnClrBuf( cmdbuf : *omit );                                                              
          QsnClrBuf( inpbuf : *omit );                                                              
          // ----------------------------------------------                                        
          // Add the "Clear Screen" command to the output                                          
          //  so that the terminal starts with an empty                                            
          //  screen.                                                                              
          // ----------------------------------------------                                        
          QsnClrScr( *omit : cmdbuf : *omit : *omit );                                              
          // ----------------------------------------------                                        
          //  Put a screen title in the output buffer                                              
          // ----------------------------------------------                                        
          data = '
Select File to download and process.';                                            
          QsnWrtDta( data                                                                          
                   : %len(data)                                                                    
                   : *omit                                                                          
                   : 1                                                                              
                   : 40 - (%len(data)/2)  // center                                                
                   : QSN_SA_HI                                                                      
                   : QSN_SA_HI                                                                      
                   : QSN_SA_WHT                                                                    
                   : QSN_SA_WHT                                                                    
                   : cmdbuf                                                                        
                   : *omit                                                                          
                   : *omit                                                                          
                   );                                                                              
          // ----------------------------------------------                                        
          // Put the filename on rows 3+ of the output buf                                          
          // ----------------------------------------------                                        
          row = 2;                                                                                  
          for x = 1 to NumLines;                                                                    
             row +=1;                                                                              
                                                                                                   
             Select;                                                                                
             when row = 3;                                                                          
              ScreenAtr = QSN_SA_PNK_UL;                                                            
              Length = 22;                                                                          
             when row = 22;                                                                        
              ScreenAtr = QSN_SA_RED;                                                              
              Length = %len(line(x));                                                              
             other;                                                                                
              ScreenAtr = QSN_SA_GRN;                                                              
              Length = %len(line(x));                                                              
             endsl;                                                                                
                                                                                                   
             if %scan(%trim(NRF):Line(x)) > *zeros;                                                
              SkipThis = *on;                                                                      
             endif;                                                                                
                                                                                                   
             QsnWrtDta( Line(x)                                                                    
                      : Length                                                                      
                      : *omit                                                                      
                      : row                                                                        
                      : 2                                                                          
                      : QSN_SA_NORM                                                                
                      : QSN_SA_NORM                                                                
                      : ScreenAtr                                                                  
                      : QSN_SA_GRN                                                                  
                      : cmdbuf                                                                      
                      : *omit                                                                      
                      : *omit                                                                      
                      );                                                                            
          endfor;                                                                                  
          // ----------------------------------------------                                        
          // Put an underlined blank input field into the                                          
          //  output buffer so the user has a place to                                              
          //  answer.. This is on Row 21                                                            
          // ----------------------------------------------                                        
          if not(SkipThis);                                                                        
                                                                                                   
           QsnSetFld( *omit                                                                        
                    : AnsLen                                                                        
                    : 21                                                                            
                    : 2                                                                            
                    : QSN_FFW_ALPHA_SHIFT                                                          
                    : *omit                                                                        
                    : 0                                                                            
                    : QSN_SA_UL                                                                    
                    : QSN_SA_GRN_UL                                                                
                    : cmdbuf                                                                        
                    : *omit                                                                        
                    : *omit );                                                                      
          endif;                                                                                    
          // ----------------------------------------------                                        
          //   Let the user know how to exit  (color blue)                                          
          // ----------------------------------------------                                        
          QsnWrtDta( '
F3=Exit'                                                                      
                   : %len('
F3=Exit')                                                                
                   : *omit                                                                          
                   : 23                                                                            
                   : 2                                                                              
                   : QSN_SA_HI                                                                      
                   : QSN_SA_NORM                                                                    
                   : QSN_SA_BLU                                                                    
                   : QSN_SA_GRN                                                                    
                   : cmdbuf                                                                        
                   : *omit                                                                          
                   : *omit                                                                          
                   );                                                                              
          // ----------------------------------------------                                        
          // put the "unlock keyboard" command into the                                            
          // output buffer                                                                          
          // ----------------------------------------------                                        
          QsnReadInp( QSN_CC1_MDTALL_CLRALL                                                        
                    : QSN_CC2_UNLOCKBD                                                              
                    : *omit                                                                        
                    : *omit                                                                        
                    : cmdbuf                                                                        
                    : *omit                                                                        
                    : *omit );                                                                      
          // ----------------------------------------------                                        
          // send the output buffer to the terminal, and                                            
          //  wait for input from the user                                                          
          // ----------------------------------------------                                        
          QsnPutGetBuf( cmdbuf: inpbuf: *omit: *omit);                                              
          // ----------------------------------------------                                        
          //  Get a pointer to the input data, and the                                              
          //   length of the input data.                                                            
          // ----------------------------------------------                                        
          p_InputData = QsnRtvDta( inpbuf: *omit: *omit );                                          
          Len = QsnRtvDtaLen(inpbuf: *omit: *omit)                                                  
                 - %size(InputData.ROW)                                                            
                 - %size(InputData.COL)                                                            
                 - %size(InputData.AID);                                                            
          // ----------------------------------------------                                        
          //   Copy the answer from the buffer                                                      
          // ----------------------------------------------                                        
          if (Len > 0);                                                                            
             Answer = %trim( %subst( InputData.field: 1: len) );                                    
             %subst(dataout:2:1) = Answer;                                                          
          endif;                                                                                    
          // ----------------------------------------------                                        
          //   Clean up the buffers, and return to caller                                          
          // ----------------------------------------------                                        
          QsnDltBuf(cmdbuf: *omit);                                                                
          QsnDltBuf(inpbuf: *omit);                                                                
          %subst(dataout:1:1) = '
0';                                                                
          if (InputData.AID = QSN_F3);                                                              
           %subst(dataout:1:1) = '
1';                                                              
          endif;                                                                                    
                                                                                                   
          // return Variable                                                                        
          return dataout;                                                                          
                                                                                                   
      /end-free                                                                                    
     P                 E                                                                            
      *--------------------------------------------------------                                    
      *  openList  - Open a cursor to read file                                                    
      *--------------------------------------------------------                                    
     p openList        b                                                                            
                                                                                                   
     d openList        pi                                                                          
                                                                                                   
      /free                                                                                        
                                                                                                   
       exec sql                                                                                    
        declare MyCursor cursor for statement;                                                      
                                                                                                   
       exec sql                                                                                    
        prepare statement from :sqlstmt;                                                            
                                                                                                   
       exec sql                                                                                    
        open mycursor;                                                                              
                                                                                                   
      /End-Free                                                                                    
                                                                                                   
     p openList        e                                                                            
      *--------------------------------------------------------                                    
      *  fetchNext  - read one record at a time                                                    
      *--------------------------------------------------------                                    
     p fetchNext       b                                                                            
                                                                                                   
     d fetchNext       pi              n                                                            
                                                                                                   
      /free                                                                                        
                                                                                                   
       exec sql                                                                                    
        fetch next from mycursor into : mysqldata3;                                                
         if sqlstt < '
02000';                                                                      
           return *on;                                                                              
         else;                                                                                      
           return *off;                                                                            
         endif;                                                                                    
                                                                                                   
      /end-free                                                                                    
                                                                                                   
     p fetchnext       e                                                                            
                                                                                                   
      *--------------------------------------------------------                                    
      *  closeOrderList  - Close the OrderHdr cursor                                                
      *--------------------------------------------------------                                    
     p closeList       b                                                                            
                                                                                                   
     d closeList       pi                                                                          
                                                                                                   
      /free                                                                                        
                                                                                                   
       exec sql                                                                                    
        close MyCursor;                                                                            
                                                                                                   
      /end-free                                                                                    
                                                                                                   
     p closeList       e                                                                            
      *--------------------------------------------------------

QUSLSPL – List all spooled files in an outqueue.
This would better be done in SQL, today)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
      *========================================================================                    
      *                                                                                            
      * Program Info                                                                                
      *                                                                                            
     d PgmInfo        SDS                                                                          
     d  @JobName             244    253                                                            
     d  @UserId              254    263                                                            
     d  @JobNumber           264    269  0                                                          
      *                                                                                            
      * API - List spooled files                                                                    
      *                                                                                            
     d QUSLSPL         PR                  extpgm('QUSLSPL')                                        
      * required parameters                                                                        
     d   UsrSpc                      20A   const                                                    
     d   Format                       8A   const                                                    
     d   UserName                    10A   const                                                    
     d   QualOutQ                    20A   const                                                    
     d   FormType                    10A   const                                                    
     d   UserData                    10A   const                                                    
      * optional group 1:                                                                          
     d   ErrorCode                32766A   options(*nopass: *varsize)                              
      * optional group 2:                                                                          
     d   QualJob                     26A   options(*nopass) const                                  
     d   FieldKeys                   10I 0 options(*nopass: *varsize)                              
     d                                     dim(9999)                                                
     d   NumFields                   10I 0 options(*nopass) const                                  
      * optional group 3:                                                                          
     d   AuxStgPool                  10I 0 options(*nopass) const                                  
      * optional group 4:                                                                          
     d   JobSysName                   8A   options(*nopass) const                                  
     d   StartCrtDate                 7A   options(*nopass) const                                  
     d   StartCrtTime                 6A   options(*nopass) const                                  
     d   EndCrtDate                   7A   options(*nopass) const                                  
     d   EndCrtTime                   6A   options(*nopass) const                                  
      *                                                                                            
     d QUSCRTUS        PR                  extpgm('QUSCRTUS')                                      
     d   UsrSpc                      20A   const                                                    
     d   ExtAttr                     10A   const                                                    
     d   InitialSize                 10I 0 const                                                    
     d   InitialVal                   1A   const                                                    
     d   PublicAuth                  10A   const                                                    
     d   Text                        50A   const                                                    
     d   Replace                     10A   const                                                    
     d   ErrorCode                32766A   options(*nopass: *varsize)                              
      *                                                                                            
     d QUSPTRUS        PR                  extpgm('QUSPTRUS')                                      
     d   UsrSpc                      20A   const                                                    
     d   Pointer                       *                                                            
      *                                                                                            
     d QUSDLTUS        PR                  extpgm('QUSDLTUS')                                      
     d   UsrSpc                      20A   const                                                    
     d   ErrorCode                32766A   options(*varsize)                                        
      *                                                                                            
     d p_UsrSpc        s               *                                                            
     d dsLH            DS                   based(p_UsrSpc)                                        
     d                                      qualified                                              
     d   Filler1                    103A                                                            
     d   Status                       1A                                                            
     d   Filler2                     12A                                                            
     d   HdrOffset                   10I 0                                                          
     d   HdrSize                     10I 0                                                          
     d   ListOffset                  10I 0                                                          
     d   ListSize                    10I 0                                                          
     d   NumEntries                  10I 0                                                          
     d   EntrySize                   10I 0                                                          
      *                                                                                            
     d p_Entry         s               *                                                            
     d dsSF            DS                   based(p_Entry)                                          
     d                                      qualified                                              
     d   JobName                     10A                                                            
     d   UserName                    10A                                                            
     d   JobNumber                    6A                                                            
     d   SplfName                    10A                                                            
     d   SplfNbr                     10I 0                                                          
     d   SplfStatus                  10I 0                                                          
     d   OpenDate                     7A                                                            
     d   OpenTime                     6A                                                            
     d   Schedule                     1A                                                            
     d   SysName                     10A                                                            
     d   UserData                    10A                                                            
     d   FormType                    10A                                                            
     d   OutQueue                    10A                                                            
     d   OutQueueLib                 10A                                                            
     d   AuxPool                     10I 0                                                          
     d   SplfSize                    10I 0                                                          
     d   SizeMult                    10I 0                                                          
      *                                                                                            
     d   TotalPages                  10I 0                                                          
     d   CopiesLeft                  10I 0                                                          
     d   Priority                     1A                                                            
     d   Reserved                     3A                                                            
      *                                                                                            
     d dsEC            DS                  qualified                                                
     d  BytesProvided                10I 0 inz(%size(dsEC))                                        
     d  BytesAvail                   10I 0 inz(0)                                                  
     d  MessageID                     7A                                                            
     d  Reserved                      1A                                                            
     d  MessageData                 240A                                                            
      *                                                                                            
      * constants                                                                                  
      *                                                                                            
     d Low             c                   const('abcdefghijklmnopqrstuvwxyz')                      
     d MYSPACE         c                   const('SPLFLIST  QTEMP     ')                            
     d Q               c                   const('''')                                              
     d Up              c                   const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')                      
                                                                                                   
     d OutQName        ds                  qualified inz                                            
     d   OutQ                        10A   overlay(OutQname:1)                                      
     d   OutQLib                     10A   overlay(OutQname:*next)                                  
      *                                                                                            
      *  Field Definitions.                                                                        
      *                                                                                            
     d size            s             10I 0                                                          
     d sf              s             10I 0 inz(1)                                                  
      *                                                                                            
      *                                                                                            
      *========================================================================                    
      * MAIN LINE                                                                                  
      *========================================================================                    
                                                                                                   
      /free                                                                                        
                                                                                                   
               OutQName.OutQLib = 'QUSRSYS';                                                        
               OutQName.OutQ = 'PRT01';                                                            
               exsr  $getsplflist;                                                                  
               *inlr = *on;                                                                        
                                                                                                   
                                                                                                   
        //===========================================                                              
        // $GetSPLFList - Get Spooled File List                                                    
        //===========================================                                              
                                                                                                   
             begsr $GetSPLFList;                                                                    
                                                                                                   
                                                                                                   
               // set this to zero to let OS/400 handle errors                                      
                                                                                                   
              dsEC.BytesProvided = 0;                                                              
                                                                                                   
              // make space for (approx) 1000 spooled files to be listed                            
                                                                                                   
              size = %size(dsLH) + 512 + (%size(dsSF) * 1000);                                      
                                                                                                   
             // create a user space                                                                
             // List spooled files to the user space                                                
             // Get a pointer to the returned user space                                            
             // Create a user space                                                                
             QUSCRTUS(MYSPACE: 'USRSPC': size: x'00': '*ALL':                                      
             'Temp User Space for QUSLSPL API':  '*YES': dsEC);                                    
                                                                                                   
             // List spooled files to the user space                                                
             QUSLSPL(MYSPACE: 'SPLF0300': '*ALL': OutQName:                                        
             '*ALL': '*ALL': dsEC);                                                                
                                                                                                   
             // Get a pointer to the returned user space                                            
             QUSPTRUS(MYSPACE: p_UsrSpc);                                                          
                                                                                                   
            // Loop through list, for each spooled file, display the                                
            // Status: 1=RDY , 2=OPN, 3=CLO, 4=SAV, 5=WRT, 6=HLD,                                  
            //     7=MSGW, 8=PND, 9=PRT,10=FIN,11=SND,12=DFR                                        
                                                                                                   
              p_Entry = p_UsrSpc + dsLH.ListOffset;                                                
              sf = 1;                                                                              
              dow  sf <= dsLH.NumEntries;                                                          
                                                                                                   
               // currently only move status = 1 ready                                              
                                                                                                   
               if  dsSF.SplfStatus = 1;                                                            
                                                                                                   
               endif;                                                                              
                                                                                                   
               p_Entry  +=  dsLH.EntrySize;                                                        
               sf +=1;                                                                              
              enddo;                                                                                
                                                                                                   
              // delete user space                                                                  
                                                                                                   
              QUSDLTUS(MYSPACE: dsEC);                                                              
                                                                                                   
             endsr;                                                                                
                                                                                                   
        //===========================================                                              
      /end-free

QLIRNMO – rename and/or move object.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
     * PROGRAM - @RENAME                                                                          
      * PURPOSE - rename object use API QLIRNMO                                                    
      * WRITTEN -                                                                                  
      * AUTHOR  -                                                                                  
                                                                                                   
      * PROGRAM DESCRIPTION                                                                        
      *--------------------------------------------------------                                    
      *                                                                                            
      * Entry Plist                                                                                
      *                                                                                            
     d @RENAME         pr                                                                          
     d  OldFile                      10                                                            
     d  OldLib                       10                                                            
     d  NewFile                      10                                                            
     d  NewLib                       10                                                            
     d  inType                       10                                                            
      *                                                                                            
     d @RENAME         pi                                                                          
     d  OldFile                      10                                                            
     d  OldLib                       10                                                            
     d  NewFile                      10                                                            
     d  NewLib                       10                                                            
     d  inType                       10                                                            
      *                                                                                            
      * Variable Definition                                                                        
      *                                                                                            
     d Error           s             34                                                            
     d FromObject      s             20                                                            
     d ObjectType      s             10                                                            
     d ToObject        s             20                                                            
     d Replace         s              1                                                            
      *                                                                                            
      * Program Info                                                                                
      *                                                                                            
     d                SDS                                                                          
     d  @PGM                 001    010                                                            
     d  @PARMS               037    039  0                                                          
     d  @MSGDTA               91    170                                                            
     d  @MSGID               171    174                                                            
     d  @JOB                 244    253                                                            
     d  @USER                254    263                                                            
     d  @JOB#                264    269  0                                                          
      //                                                                                          
       //  external calls                                                                          
       //                                                                                          
     d $Rename         pr                  extpgm('QLIRNMO')                                        
     d   fromObject                  20                                                            
     d   ObjectType                  10                                                            
     d   ToObject                    20                                                            
     d   Replace                      1                                                            
     d   Error                       34                                                            
                                                                                                   
      /Free                                                                                        
                                                                                                   
        //--------------------------------------------------------                                  
        // MAIN LINE                                                                                
        //--------------------------------------------------------                                  
                                                                                                   
                                                                                                   
                   // take parms and rename --and/or-- move object                                  
                                                                                                   
                FromObject = OldFile + OldLib;                                                      
                ToObject = NewFile + NewLib;                                                        
                ObjectType = InType;                                                                
                replace = '1';                                                                      
                                                                                                   
                $rename(FromObject      :                                                          
                        ObjectType      :                                                          
                        ToObject        :                                                          
                        Replace         :                                                          
                        Error                                                                      
                                        );                                                          
                                                                                                   
                                                                                                   
               *inlr = *on;                                                                        
                                                                                                   
                                                                                                   
        //--------------------------------------------------------                                  
        // *Inzsr -  one time run subroutine                                                        
        //--------------------------------------------------------                                  
                                                                                                   
             begsr *inzsr;                                                                          
                                                                                                   
                                                                                                   
             endsr;                                                                                
      /End-Free

CEERAN0 – Generate random number.
This to better done in SQL

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
     H DFTACTGRP(*NO) ACTGRP('QILE')                                                                
                                                                                                   
     d @RANDOM         PR                  extpgm('@RANDOM')                                        
     d   lowno                       15  5 const                                                    
     d   highno                      15  5 const                                                    
     d   result                      15  5                                                          
                                                                                                   
     d @RANDOM         PI                                                                          
     d   lowno                       15  5 const                                                    
     d   highno                      15  5 const                                                    
     d   result                      15  5                                                          
                                                                                                   
     d CEERAN0         PR                                                                          
     d   seed                        10I 0                                                          
     d   ranno                        8F                                                            
     d   fc                          12A   options(*omit)                                          
                                                                                                   
     d count           s              6  0                                                          
     d outNumber       s             15                                                            
     d rand            s              8F                                                            
     d range           s              5P 0                                                          
     d seed            s             10I 0 inz(4905268)                                            
     d worknumber      s             15  5                                                          
                                                                                                   
      /free                                                                                        
       for count = 1 to %subdt(%TimeStamp():*s);                                                    
       range = (highno - lowno) + 1;                                                                
       CEERAN0( seed : rand : *omit );                                                              
       result = %int(rand * range) + lowno;                                                        
       endfor;                                                                                      
       outnumber = %char(result);                                                                  
       dsply outnumber ' ';                                                                        
       *inlr = *on;                                                                                
      /end-free
Working examples of API’s
Tagged on:                         

Leave a Reply

This site uses Akismet to reduce spam. Learn how your comment data is processed.