contact image

Tips

Many examples/tips to make programming on the IBM system i much more enjoyable. These tips written in RPGLE, SQLRPGLE, CLLE are free to use and modify as see fit.


Post Your Example

SELECT AND REPLACE in SQL Select a row from a table, and replace to a different number


Sample from Rajan Srinivasan posted at 2014-02-07 13:10:07

C/exec sql         
c+ SELECT REPLACE( 
c+       REPLACE(  
c+       REPLACE(  
c+       REPLACE(  
c+       REPLACE(  
c+       UPPER(IFLD)
c+       ,'A', '10')
c+       ,'B', '11')
c+       ,'C', '12')
c+       ,'D', '13')
c+       ,'E', '14')
c+      INTO :fldout FROM table1
c+      WHERE ofld1 = :tfld1       
c/end-exec                         

Example ILEC/400 (SUMMITION TOW VALUES)


Sample from Mohamed posted at 2012-10-18 06:23:47

??=include  
??=include   
main()               
??<                  
int a=6;             
int b=9;             
int c,d,e,f;         
c=a+b;               
d=b-a;               
e=a*b;               
f=a/b;               
printf("c=%d   ",c); 
printf("d=%d   ",d); 
printf("e=%d   ",e); 
printf("f=%d   ",f); 
??>                  

How to trigger a SQL Server Reporting Services subscription via SQL. Run this SQL against your SSRS database to manually trigger an SSRS subscription.


Sample from Jonas Temple posted at 2012-08-09 11:41:50

EXEC ReportServer.dbo.AddEvent @EventType='TimedSubscription', @EventData='subscription_id'

cardex model sample


Sample from Sw.eng.mohamed posted at 2012-08-02 04:52:13

C x begsr
c i = 1 
c *loval setll di
c read di
c doweq %eof(di)
c j = 1 
c k setll sij
c k readeq sij 
c doweq %eof(sij)
c chain file (sij)
c ifeq ( %not found)
c write file (sij)
c endif 
c j = 1 + j 
c k readeq sij 
c enddo 
c eval t = c*j 
c i = 1 + i
c read di
c enddo
c endsr  sw.eng.mohamed - July 5th, 2011  Edit Report  I would like to know the opinions of experts in computer sciences field either I correct or wrong.
To recognize my ideas I start to mathematical model.
Scientific logics .
In business ..
Using function of cardex model. 
Determine (first key, second key ..) 
solving in algorithms. 
A = ITEM No P K
I = 1, 2, 3... ,N No OF ITEMS 
D = D1, D2, D3... ,DN ITEM NAME
J = 1, 2, 3,…,M No OF UNITS
M = UNIT OF MEASURE
T = TOTAL
C = UNIT OF COST
SIJ = UNIT OF CODE S K
T =C*∑ J FOR DI TOTAL 
write code400 

QCMDEXEC vs.QCAPCMD


Sample from Jamie Flanary posted at 2012-06-25 10:17:10

                                                                                                    
     dchangedCmd       s            512    inz                                                      
     dcmdstring        s            512    inz                                                      
     dcmdlength        s             10i 0 inz                                                      
     dcmdAvailLen      s             10i 0 inz                                                      
     dcmdChangeLen     s             10i 0 inz                                                      
                                                                                                    
     docbDS            ds                  Qualified                                                
     d type                          10i 0 inz                                                      
     d DBCSdh                         1    inz('0')                                                 
     d prompt                         1    inz('0')                                                 
     d cmdsyntax                      1    inz('0')                                                 
     d msgrtvkey                      4    inz(x'00000000')                                         
     d reserve1                       9    inz(x'000000000000000000')                               
     d ocblength                     10i 0 inz                                                      
     d formatName                     8    inz('CPOP0100')                                          
     d chgcmd                         1    inz                                                      
     d lngchgcmd                     10i 0 inz                                                      
     d lngchgrtn                     10i 0 inz                                                      
                                                                                                    
     d $command        pr                  extpgm('QCAPCMD')                                        
     d   cmdstring                  512    const                                                    
     d   cmdlength                   10i 0 const                                                    
     d   ocb                               likeds(ocbDS)                                            
     d   ocblength                   10i 0 const                                                    
     d   FormatName                   8    const                                                    
     d   ChangedCmd                 512    const                                                    
     d   LenAvailChgd                10i 0 const                                                    
     d   LenChgdCmd                  10i 0 const                                                    
     d   ApiError                          likeds(APIErrorDS)                                       
                                                                                                    
     d $commandII      pr                  extpgm('QCMDEXC')                                        
     d   command                    512                                                             
     d   Length                      10i 0                                                          
                                                                                                    
     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                  240                                                             
                                                                                                    
      *  Program Information                                                                        
     d progstatus     sds                                                                           
     d  parms            *parms                                                                     
     d  progname         *proc                                                                      
     d  errmsgID                      7    overlay(ProgStatus:40)                                   
     d  errmsg                       80    overlay(ProgStatus:91)                                   
     d  jobname                      10    overlay(ProgStatus:244)                                  
     d  userid                       10    overlay(ProgStatus:254)                                  
     d  Jobnumber                     7    overlay(ProgStatus:264)                                  
                                                                                                    
      /free                                                                                         
                                                                                                    
                 // --------------------- QCAPCMD  ------------------------                         
                                                                                                    
                cmdstring = 'ADDLIBLE NOLIBRARY';                                                   
                cmdlength = %len(%trim(cmdstring));                                                 
                                                                                                    
                $command(cmdstring    :                                                             
                         cmdlength    :                                                             
                         ocbds        :                                                             
                         %len(ocbDS)  :                                                             
                         'CPOP0100'   :                                                             
                         changedCmd   :                                                             
                         cmdAvailLen  :                                                             
                         cmdChangeLen :                                                             
                         APIErrorDS                                                                 
                                       );                                                           
                                                                                                    
                                                                                                    
                 // after above call APIErrorDS contains:                                           
                 //APIERRORDS.BYTESP = 256                                                          
                 //APIERRORDS.BYTESA = 26                                                           
                 //APIERRORDS.MESSAGEID = 'CPF2110'                                                 
                 //APIERRORDS.RESERVED = '0'                                                        
                 //APIERRORDS.MESSAGEDTA =                                                          
                 //          ....5...10...15...20...2                                               
                 //     1   'NOLIBRARY                                                              
                                                                                                    
                                                                                                    
                                                                                                    
                 // --------------------- QCMDEXEC ------------------------                         
                                                                                                    
                 cmdstring = 'ADDLIBLE NOLIBII';                                                    
                 cmdlength = %len(%trim(cmdstring));                                                
                                                                                                    
                 // error message will be available in SDS Program Information DS                   
                 monitor;                                                                           
                 $commandII (cmdstring : cmdlength);                                                
                 on-error;                                                                          
                 endmon;                                                                            
                                                                                                    
                 // after above call APIErrorDS contains:                                           
                 //  PROGNAME OF PROGSTATUS = 'MYCMDTEST '                                          
                 //  PARMS OF PROGSTATUS = 000.                                                     
                 //  ERRMSGID OF PROGSTATUS = 'CPF0006'                                             
                 //  ERRMSG OF PROGSTATUS =                                                         
                 //            ....5...10...15...20...25...30.                                      
                 //       1   'Errors occurred in command.                                          
                 //      61   '                   '                                                 
                 //  JOBNAME OF PROGSTATUS = 'QPADEV0052'                                           
                 //  USERID OF PROGSTATUS = 'FLANARY   '                                            
                 //  JOBNUMBER OF PROGSTATUS = '773535'                                             
                                                                                                    
                                                                                                    
                *inlr = *On;                                                                        
      /end-free                                                                                     

To display the day of the week


Sample from Venkatasubramanian S posted at 2012-03-21 05:02:43

0001.00       *                                                                    *         000000 
0002.00       *--------------------------------------------------------------------*         000000 
0003.00       * Created by . . . . . : Venkatasubramanian                          *         000000 
0004.00       * Date . . . . . . . . : March 21, 2012                              *         000000 
0005.00       * Purpose. . . . . . . : To display the day of the week              *         000000 
0006.00       *--------------------------------------------------------------------*         000000 
0007.00       *                                                                    *         000000 
0008.00      D Date            S               D   DATFMT(*ISO)                              000000 
0009.00      D DayC            S              1  0                                           000000 
0010.00      D DayNum          S              9    DIM(7) CTDATA                             000000 
0011.00       *                                                                              000000 
0012.00      C/EXEC SQL                                                                      000000 
0013.00      C+ Set :DayC = DayofWeek(:Date)                                                 000000 
0014.00      C/END-EXEC                                                                      000000 
0015.00       *                                                                              000000 
0016.00      C     DayNum(DayC)  Dsply                                                       000000 
0017.00       *                                                                              000000 
0018.00      C                   Eval      *INLR = *On                                       000000 
0019.00       *--------------------------------------------------------------------*         000000 
0020.00      C     *InzSr        Begsr                                                       000000  
0021.00      C     *Entry        Plist                                                       000000  
0022.00      C                   Parm                    Date                                000000  
0023.00      C                   EndSr                                                       000000  
0024.00       *--------------------------------------------------------------------*         000000  
0025.00 ** CTDATA                                                                            000000  
0026.00 SUNDAY                                                                               000000  
0027.00 MONDAY                                                                               000000  
0028.00 TUESDAY                                                                              000000  
0029.00 WEDNESDAY                                                                            000000  
0030.00 THURSDAY                                                                             000000  
0031.00 FRIDAY                                                                               000000  
0032.00 SATURDAY                                                                             000000  

Get IP address of device program called from.


Sample from Jamie Flanary posted at 2012-02-12 11:18:53

                                                                                                    
                                                                                                    
     d Format          s              8A   Inz('DEVD0600')                                          
     d ipaddress       s             15a                                                            
     d Rcvar           S           5000A   Inz                                                      
     d Varlen          S             10i 0 Inz(5000)                                                
                                                                                                    
     d $getipaddress   pr                  extpgm('QDCRDEVD')                                       
     d   rcvar                     5000                                                             
     d   varlen                      10i 0                                                          
     d   format                       8                                                             
     d   @job                        10                                                             
     d   apierror                   256                                                             
                                                                                                    
      //                                                                                            
      // Program Info                                                                               
      //                                                                                            
     d                SDS                                                                           
     d  @JOB                 244    253                                                             
                                                                                                    
                                                                                                    
     d APIError        ds                  Qualified                                                
     d  BytesP                 1      4I 0 inz(%size(apiError))                                     
     d  BytesA                 5      8I 0 inz(0)                                                   
     d  Messageid              9     15                                                             
     d  Reserved              16     16                                                             
     d  messagedta            17    256                                                             
                                                                                                    
                                                                                                    
                                                                                                    
                                                                                                    
                                                                                                    
      /free                                                                                         
                                                                                                    
           $getipaddress( rcvar   :                                                                 
                          varlen  :                                                                 
                          format  :                                                                 
                          @job    :                                                                 
                          Apierror                                                                  
                                   );                                                               
           ipaddress = %subst( rcvar:878:15);                                                       
           dsply ipaddress ' ';                                                                     
                                                                                                    
           *inlr = *on;                                                                             
      /end-free                                                                                     
                                                                                                    

Working with a data area


Sample from Jamie Flanary posted at 2012-02-12 11:07:48

      *=====================================================                                        
      *--------------------------------------------------------                                     
      *                                                                                             
      * Variable Definition                                                                         
      *                                                                                             
     d CmdLength       s             15  5 inz(0)                                                   
     d CmdString       s            256    inz(*blanks)                                             
     d reply           s              1                                                             
                                                                                                    
       //                                                                                           
       //  external calls                                                                           
       //                                                                                           
                                                                                                    
     d $command        pr                  extpgm('QCMDEXC')                                        
     d   command                   5000    options(*varsize)                                        
     d   Length                      15  5                                                          
                                                                                                    
     d program21       ds                  DTAARA('MYTWENTY1')                                      
     d   mytwenty1                   21                                                             
                                                                                                    
                                                                                                    
                                                                                                    
      /Free                                                                                         
                                                                                                    
        //--------------------------------------------------------                                  
        // MAIN PROGRAM                                                                             
        //--------------------------------------------------------                                  
                                                                                                    
             cmdstring =                                                                            
              'CRTDTAARA DTAARA(QTEMP/MYTWENTY1) TYPE(*CHAR) LEN(21)';                              
             cmdlength = %len(%trim(cmdstring));                                                    
             monitor;                                                                               
             $command (cmdstring:cmdlength);                                                        
             on-error;                                                                              
             endmon;                                                                                
                                                                                                    
           // populate it  ....                                                                     
                                                                                                    
             *in99 = *on;                                                                           
             dow *in99 = *on;                                                                       
             in(e) *lock Program21;                                                                 
              *in99 = %error;                                                                       
             enddo;                                                                                 
                                                                                                    
             Program21 = 'Holy Crap Batman!';                                                       
             out  Program21;                                                                        
                                                                                                    
             in Program21;                                                                          
             dsply program21 reply;                                                                 
                                                                                                    
           // now clear it  ....                                                                    
                                                                                                    
             *in99 = *on;                                                                           
             dow *in99 = *on;                                                                       
             in(e) *lock Program21;                                                                 
              *in99 = %error;                                                                       
             enddo;                                                                                 
             clear Program21;                                                                       
                                                                                                    
             out  program21;                                                                        
                                                                                                    
             in  Program21;                                                                         
                                                                                                    
             dsply program21 reply ;                                                                
                                                                                                    
           // re-populate it  ....                                                                  
                                                                                                    
             *in99 = *on;                                                                           
             dow *in99 = *on;                                                                       
             in(e) *lock Program21;                                                                 
              *in99 = %error;                                                                       
             enddo;                                                                                 
                                                                                                    
             Program21 = 'Lets try this again!';                                                    
             out  Program21;                                                                        
             in Program21;                                                                          
             dsply program21 reply;                                                                 
                                                                                                    
             clear MyTwenty1;                                                                       
                                                                                                    
             *inlr = *on;                                                                           
        //--------------------------------------------------------                                  
        // *inzsr - initial one time subroutine                                                     
        //--------------------------------------------------------                                  
                                                                                                    
             begsr *inzsr;                                                                          
                                                                                                    
             endsr;                                                                                 
                                                                                                    
        //--------------------------------------------------------                                  
      /End-Free                                                                                     

last weeks Monday to Friday dates in MMDDYY


Sample from Jamie Flanary posted at 2012-02-12 10:20:29

     d dayofweek       s              1  0                                                          
     d fromMonday      s              6  0                                                          
     d monday          s               d                                                            
     d toFriday        s              6  0                                                          
                                                                                                    
              //this junk gives you last weeks Monday to Friday dates in MMDDYY                     
              //this should work till arounf 2012 when the world explodes                           
              //day of week 1=Sun 2=Monday ......7=Sat                                              
                                                                                                    
      /free                                                                                         
                dayofweek = %rem(%diff(%date():D'1899-12-30':*days):7);                             
                if dayofweek < 1;                                                                   
                 dayofweek += 7;                                                                    
                endif;                                                                              
                // need to get to current weeks Monday                                              
                if dayofweek = 1;                                                                   
                 monday = %date() + %days(1);                                                       
                else;                                                                               
                 monday = %date() - %days(dayofweek-2);                                             
                endif;                                                                              
                                                                                                    
                fromMonday = %dec(monday - %days(7):*mdy);                                          
                toFriday = %dec(monday - %days(3):*mdy);                                            
                                                                                                    
                *inlr = *on;                                                                        
      /end-free                                                                                     
                                                                                                    

Examples of *New functions in CLLE V5R4.


Sample from Jamie Flanary posted at 2012-01-04 18:15:11

       /*---------------------------------------------------------------*/
       /*  To compile run these commands first                          */
       /*                                                               */
       /*    DSPOBJD    OBJ(QSYS/ADD*) OBJTYPE(*CMD) +                  */
       /*                 OUTPUT(*OUTFILE) OUTFILE(QTEMP/QADSPOBJ)      */
       /*                                                               */
       /*    DSPOBJD    OBJ(QSYS/CHG*) OBJTYPE(*CMD) +                  */
       /*                 OUTPUT(*OUTFILE) OUTFILE(QTEMP/QADSPOBJ2)     */
       /*                                                               */
       /*---------------------------------------------------------------*/
pgm



       /*--------------------------------------------------------*/
       /*  New TYPE values on DCL statement                      */
       /*   *INT & *UINT                                         */
       /*   Len of 2 & 4 supported                               */
       /*   OPM doesnt support 8-Byte intengers - use CLLE       */
       /*   (use %INT instead of binary)                         */
       /*                                                        */
       /*   Previous limit on max parameters                     */
       /*   PGM & TFRCTL = 40                                    */
       /*   CALL = 99                                            */
       /*   New limits                                           */
       /*   PGM & TFRCTL = 255                                   */
       /*   CALL = 255                                           */
       /*                                                        */
       /*   Number of PARM statems remains at 99                 */
       /*--------------------------------------------------------*/

             DCL        VAR(&INT2) TYPE(*INT) LEN(2)
             DCL        VAR(&INT4) TYPE(*INT) LEN(4)

             DCL        VAR(&LOOP) TYPE(*CHAR) LEN(1) VALUE('Y')
             DCL        VAR(&COUNT) TYPE(*DEC) LEN(4 0)

         /*------------------------------------------------------*/
         /* character lengths have increaded from 9999 to 32767  */
         /* Limit for TYPE(*CHAR) and TYPE(*PNAME) on            */
         /*       PARM , ELEM, and QUAL command stays at 5000    */
         /*------------------------------------------------------*/

             DCL        VAR(&BIGOFIELD) TYPE(*CHAR) LEN(32767)

            DCL   VAR(&INT)  TYPE(*INT)  LEN(2)
            DCL   VAR(&NAME)  TYPE(*CHAR)  LEN(10)
            DCL   VAR(&LGL)  TYPE(*LGL)  VALUE('1')      /* True */


       /*--------------------------------------------------------*/
       /*  Multiple file support                                 */
       /*  supports upto 5 file "instances"                      */
       /*  instances can be for the same file of different files */
       /*                                                        */
       /*  New OPNID (open identifier) parm added to DCLF        */
       /*    (only 1 DCLF allowed with OPNID(*NONE)              */
       /*    OPNID accepts 10 *char values                       */
       /*    If OPNID name is used then declared CL values are   */
       /*    prefixed with this name :                           */
       /*                              &FILE01_Field1            */
       /*                              &FILE01_Field2            */
       /*    OPNID added to                                      */
       /*                   RCVF                                 */
       /*                   ENDRCV                               */
       /*                   SNDF                                 */
       /*                   SNDRCVF                              */
       /*                   WAIT                                 */
       /*                                                        */
       /*   I havent tried this  but I think by defining the     */
       /*   the file QADSPOBJ twice with different OPNID I       */
       /*   can read the file again once it hits eof             */
       /*   **once a file is read in CL (at EOF) the POSDBF      */
       /*     doesnt reposition the pointer.                     */
       /*--------------------------------------------------------*/

             DCLF       FILE(QTEMP/QADSPOBJ) OPNID(FILE01)
             DCLF       FILE(QTEMP/QADSPOBJ2) OPNID(FILE02)
             DCLF       FILE(QTEMP/QADSPOBJ) OPNID(FILE03)

             DSPOBJD    OBJ(QSYS/ADD*) OBJTYPE(*CMD) +
                          OUTPUT(*OUTFILE) OUTFILE(QTEMP/QADSPOBJ)

             DSPOBJD    OBJ(QSYS/CHG*) OBJTYPE(*CMD) +
                          OUTPUT(*OUTFILE) OUTFILE(QTEMP/QADSPOBJ2)



             CHGVAR     VAR(&COUNT) VALUE(0)
             DOWHILE    COND(LOOP = 'Y')
             CHGVAR     VAR(&COUNT) VALUE(&COUNT + 1)

       /*--------------------------------------------------------*/
       /*  Loops ..                                              */
       /*   DOWHILE :  DOUNTIL  : DOFOR                          */
       /*   each support                                         */
       /*   LEAVE : ITERATE                                      */
       /*   -> CASE                                              */
       /*   SELECT : WHEN : OTHERWISE : ENDSELECT                */
       /*   25 Level nesting supported                           */
       /*--------------------------------------------------------*/

             SELECT
             WHEN       COND(&COUNT *LE 5) THEN(DO)
             ITERATE
             ENDDO

             OTHERWISE  CMD(DO)
             leave
             ENDDO

             endSelect

             enddo

       /*--------------------------------------------------------*/
       /*  DOFOR:                                                */
       /*  BY left blank defaults to 1                           */
       /*  VAR must be *INT or *UINT                             */
       /*  FROM and TO can be integer constants, expressions,    */
       /*              or variables                              */
       /*  BY must be an integer contant (may be negative)       */
       /*                                                        */
       /*  FROM/TO  expressions are checked at loop initiation   */
       /*           TO evaluated after increment                 */
       /*                                                        */
       /*  Checks for loop exit aat top of loop                  */
       /*--------------------------------------------------------*/

             DOFOR      VAR(&INT2) FROM(1) TO(12) BY(2)
             leave
             ENDDO


       /*--------------------------------------------------------*/
       /*  LEAVE/ITERATE                                         */
       /*  Leave defaults to current loop may be changed to      */
       /*  any label.   see example below                        */
       /*--------------------------------------------------------*/

            LOOP1:      DOFOR      VAR(&INT) FROM(0) TO(10)

               LOOP2: DOUNTIL   COND(&LGL)
               IF   COND(&NAME *EQ *NONE)  THEN(LEAVE  CMDLBL(LOOP1))
               ENDDO /* DOUNTIL */

            ENDDO /* DOFOR */



       /*--------------------------------------------------------*/
       /*  Did someone say subroutines?                          */
       /*  IBM is looking to add  SUBR, ENDSUBR and GOSUBR       */
       /*--------------------------------------------------------*/


endpgm


Create multi-tabbed XLS sheet using RPG


Sample from Jamie Flanary posted at 2011-12-10 16:22:52

     H dftactgrp( *no ) bnddir( 'QC2LE') OPTION(*NODEBUGIO)
      * --------------------------------------------------
      * Program - EXCEL
      * Purpose - 
      * Written - 
      * Author  - 
      *
      * PROGRAM DESCRIPTION
      *   create example XML to view as excel
      *
      * INPUT PARAMETERS
      *   Description        Type  Size    How Used
      *   -----------        ----  ----    --------
      *
      *
      * INDICATOR USAGE
      *   xx - xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      *---------------------------------------------------
      *
      *
     d Buf             s          65000A
     d BufP            s               *   INZ(%ADDR(Buf))
     d BufLen          s             10U 0
     d CmdString       s          10000
     d CmdLength       s             15  5
     d company         s              2s 0
     d Complete        s              1
     d count           s              5  0
     d count2          s              5  0
     d cp              s             10U 0 INZ(819)
     d CR              c                   CONST(X'0d')
     d CRLF            c                   CONST(X'0d25')
     d Current         s              1
     d cymd            s              7  0
     d Data            s          65000
     d dbxfil          s             10
     d dbxlib          s             10
     d dbxown          s             10
     d dbxtxt          s             50
     d dbxatr          s              2
     d deleted         s               n
     d DQ              c                   CONST('"')
     d FileNam         s             15A   inz('/xml/jamie2.xml')
     d FileName1       s             21
     d FileName2       s             21
     d FileNamP        s               *   inz(%ADDR(FileNam))
     d FileDescr       s             10I 0
     d FirstNew        s              1
     d formated        s              7
     d formatBack      s          65535A   varying
     d From            c                   CONST(',"''')
     d header          s          65000
     d ISODate         s               D
     d LC#             s              3  0
     d LaborCodes      s              3    dim(100)
     d LaborCodeCu     s              1    dim(100)
     d LaborCodeCo     s              1    dim(100)
     d LaborCodePd     s              7  0 dim(100)
     d Len             s              3  0
     d Length          s              9
     d Lilian          s             10i 0
     d NewDate         s             52a
     d NLZero          s              2A   INZ(X'1500')
     d O_CREAT         s             10I 0 INZ(8)
     d O_RDWR          s             10I 0 INZ(4)
     d O_TEXTDATA      s             10I 0 INZ(16777216)
     d O_CODEPAGE      s             10I 0 INZ(8388608)
     d Oflag           s             10I 0 INZ(0)
     d Omode           s             10U 0 INZ(511)
     d Pos             s              4  0
     d Produced        s              7  0
     d Q               c                   CONST('''')
     d ReadOneRecord   s              1
     d reporttype      s             20
     d RC              s             10I 0
     d savecustomer    s              5  0
     d savelib         s             10
     d SI_Fmt          s             50A   INZ('n')
     d SI_FmtP         s               *   INZ(%ADDR(SI_Fmt))
     d SI_Msg          s             50A
     d SI_MsgP         s               *   INZ(%ADDR(SI_Msg))
     d sqlrecords      s              9  0
     d sqlstmt         s          23000    varying
     d Str             s              3  0
     d style           s          65000
     d To              c                   CONST('   ')
     d useweight       s              7  0
     d Width           s              7
     d WKSDES          s             30
     d Workread        s              3  0
     d x               s              2  0
     d ZeroBin         s              1A   INZ(*ALLX'00')
      *
      * Program Info
      *
     d                SDS
     d  @PGM                 001    010
     d  @PARMS               037    039  0
     d  @JOB                 244    253
     d  @USER                254    263
     d  @JOB#                264    269  0
      *
     d openList        pr
     d FetchNext       pr              n
     d closeList       pr
      *
     d Num_DS          DS
     d Num_Hex                        4A   INZ(X'00000000')
     d Num                           10I 0 OVERLAY(Num_Hex)

     dperror           PR            10I 0 EXTPROC('perror')
     dconst                            *   VALUE

     dsprintf          PR            10I 0 EXTPROC('sprintf')
     d                                 *   VALUE
     d                                 *   VALUE
     d                               10I 0 VALUE OPTIONS(*NOPASS)
     d                                 *   VALUE OPTIONS(*NOPASS)
      * Open Operations
      * value returned = file descriptor 0 (OK), -1 (Error)

     dopen             PR            10I 0 EXTPROC('open')
     d                                 *   VALUE
     d                               10I 0 VALUE
     d                               10U 0 VALUE OPTIONS(*NOPASS)
     d                               10U 0 VALUE OPTIONS(*NOPASS)

      * Read Operations
      * value returned = number of bytes read or , -1 (Error)

     Dread             PR            10I 0 EXTPROC('read')
     d                               10I 0 VALUE
     d                                 *   Value
     d                               10U 0 VALUE

      * Write Operations
      * value returned = number of bytes Written or , -1 (Error)

     dwrite            PR            10I 0 EXTPROC('write')
     d                               10I 0 VALUE
     d                                 *   VALUE
     d                               10U 0 VALUE

      * Close Operations
      * value returned = 0 (OK) or , -1 (Error)

     dclose            PR            10I 0 EXTPROC('close')
     d                               10I 0 VALUE

      * Open Directory Operation
      * value returned = file descriptor 0 (OK), -1 (Error)

     dopendir          PR              *   EXTPROC('opendir')
     d                                 *   VALUE

      * Read Directory Operation
      *


     dreaddir          PR              *   EXTPROC('readdir')
     d                                 *   VALUE

      * Open Directory Operation
      * value returned = 0 (OK) or , -1 (Error)

     dclosedir         PR            10I 0 EXTPROC('closedir')
     d                                 *   VALUE

      * Unlink a File from system... Delete File
      * value returned = 0 (OK) or , -1 (Error)

     dunlink           PR            10I 0 EXTPROC('unlink')
     d path                            *   Value options(*string)

     d CEEDAYS         pr                  opdesc
     d   InputDate                65535A   const options(*varsize)
     d   picture                  65535A   const options(*varsize)
     d   Lilian                      10i 0
     d   Feedback                    12a   options(*omit)

     d CEEDATE         pr                  opdesc
     d   Lilian                      10i 0
     d   picture                  65535A   const options(*varsize)
     d   OutputDate               65535A   const options(*varsize)
     d   Feedback                    12a   options(*omit)


      /Free


          exsr $buildifs;
          exsr $readfile;

          clear data;
          data = '' + CRLF;
          Buf = %trim(Data);
          BufLen = %scan(CRLF:Buf);
          RC = write(filedescr: BufP: BufLen);

          RC = close(FileDescr);
          if FileDescr = -1;
           RC = perror(FileNamP);
           Return;
          endif;

          *inlr = *on;

        //--------------------------------------------------------
        // $buildIFS - build the temp table in IFS
        //--------------------------------------------------------
             begsr $buildIFS;

              Filenam = %trim('/xml/jamie.xml');
              Filenamp = %ADDR(FileNam);

              Oflag = O_CREAT + O_RDWR + O_CODEPAGE;
              FileDescr=open(FileNamP:Oflag:Omode:cp);
              if FileDescr = -1;
               RC = perror(FileNamP);
               return;
              endif;

              RC = close(FileDescr);
              if        RC = -1;
               RC = perror(FileNamP);
               return;
              endif;

              Oflag =  O_RDWR + O_TEXTDATA;
              FileDescr=open(FileNamP:Oflag);
              if        FileDescr = -1;
               RC = perror(FileNamP);
               Return;
              endif;


              // Write the header
              Buf = %trim(Data) + CRLF;
              BufLen = %scan(CRLF:Buf);
              RC = write(filedescr: BufP: BufLen);
              clear DATA;

             endsr;

        //--------------------------------------------------------
        // $readfile - pretend to read file of libs
        //--------------------------------------------------------
             begsr $readfile;

              for count2 = 1 to 5;   // replace with your libraries
               select;
                when count2 = 1;
                 saveLib = 'JAMIELIB';
                when count2 = 2;
                 saveLib = 'QGPL';
                when count2 = 3;
                 saveLib = 'QSYS';
                when count2 = 4;
                 saveLib = 'QRPG';
                when count2 = 5;
                 saveLib = 'QUSRSYS';
               endsl;
               exsr $header;
               exsr $detail;
               exsr $footer;
              endfor;

             endsr;

        //--------------------------------------------------------
        // $header - write the header for the excel sheet.
        //--------------------------------------------------------
             begsr $header;

              data =
             '' + cr    +
             '' + cr                                         +
             '' +cr            +
             '' +cr   +
             ''+crlf;

              Buf = %trim(Data);
              BufLen = %scan(CRLF:Buf);
              RC = write(filedescr: BufP: BufLen);
              clear data;

              // add new heading
              data =
                ' ' +cr                               +
                '  '+cr            +
                ' '  +cr                              +
                ' Files Listed from QADBXFIL'                                +
                 cr + ' '+cr                                   +
                '' + cr ;

            // write the five column headings
              data = %trim(data) +   cr +
            ' '                                                          +
            '  '                +
            'File'                                                            +
            '  '                                                +
                            cr                                                +
            '  '                +
            'Library'                                                         +
            '  '                                                +
                            cr                                                +
            '  '                +
            'Owner'                                                           +
            '  '                                                +
                            cr                                                +
            '  '                +
            'Description'                                                     +
            '  '                                                +
                            cr                                                +
            '  '                +
            'Attribute'                                                       +
            '  '                                                +
                         cr                                                   +
            '  '   + crlf ;

              Buf = %trim(Data);
              BufLen = %scan(CRLF:Buf);
              RC = write(filedescr: BufP: BufLen);
              clear data;

             endsr;
        //--------------------------------------------------------
        // $detail - get detail for current salesperson for today
        //--------------------------------------------------------
             begsr $detail;


              sqlstmt = 'select '          +
                        'dbxfil,dbxlib,dbxown,dbxtxt,dbxatr ' +
                        ' from QADBXFIL '  +
                        ' where DBXLIB = ' + Q+ %trim(saveLib) + Q ;
              openList();
              dow fetchNext();
               exsr $writerow;
              enddo;
              closeList();

             endsr;
        //--------------------------------------------------------
        // $writerow - write detail row of spread sheet
        //--------------------------------------------------------
             begsr $writerow;

              dbxtxt = %xlate('/':' ': dbxtxt);
              dbxtxt = %xlate('*':' ': dbxtxt);

                 for count = 1 to 05;
                  select;
                   when count = 1;
                    data = cr + '' +  CR +
                           '' +
                           %trim(dbxfil) + '' + cr ;
                   when count = 2;
                    data = %trim(data) + CR +
                           '' +
                           %trim(dbxlib)  +
                           '' + cr;
                   when count = 3;
                    data = %trim(data) + CR +
                           '' +
                           %trim(dbxown)  +
                           '' + cr;
                   when count = 4;
                    data = %trim(data) + CR +
                           '' +
                           %trim(dbxtxt)  +
                           '' + cr;
                   when count = 5;
                    data = %trim(data) + CR +
                           '' +
                           %trim(dbxatr)  +
                           '' + cr;

                  endsl;

                 endfor;

                 data = %trim(data) + cr + '' + CRLF;
                 Buf = %trim(Data);
                 BufLen = %scan(CRLF:Buf);
                 RC = write(filedescr: BufP: BufLen);
                 clear DATA;


             endsr;
        //--------------------------------------------------------
        // $footer - close all the tags
        //--------------------------------------------------------
             begsr $footer;

           // write footer
                data =
            ' 
' + cr + ' ' + cr + ' 47' + cr + ' False' +cr + ' False' + cr + ' ' + cr + '
' + crlf ; Buf = %trim(Data); BufLen = %scan(CRLF:Buf); RC = write(filedescr: BufP: BufLen); clear DATA; endsr; //-------------------------------------------------------- // *inzsr - initial one time run subroutine //-------------------------------------------------------- begsr *inzsr; // get todays date in cymd format isodate = %date(); // build the headers for the xml header = '' + CR + '' + CR + '' + CR + '' + CR + 'Author' + CR + 'flanary' + CR + '2008-05-10T01:38:01Z' + CR + '11.9999' + CR + '' + CR + '' +CR + '7755' + CR + '15225' + CR + '0' + CR + '255' + CR + '1' + CR + 'False' +CR + 'False' +CR + ' ' + CR ; style = '' + CR + '' + CR + '' + CR + '' + CR + '' + CR + '' + CR + '' + CR + '' + CR + '' + CR; data = %trim(header) + CR + %trim(style) ; CEEDAYS(%char(isodate): 'YYYY-MM-DD': lilian: *omit); formatBack = 'Wwwwwwwwwz, DD Mmmmmmmmmz YYYY'; CEEDATE(Lilian: Formatback : NewDate: *omit); // this ===> Wednesday, 27 June 2007 endsr; /End-Free *-------------------------------------------------------- * 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 : dbxfil , : dbxlib , : dbxown , : dbxtxt , : dbxatr ; 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 

Using FTP to get directory listing of remote system.


Sample from Jamie Flanary posted at 2011-12-10 16:19:09

      *=======================================================================
      * PROGRAM - ##FTP
      * PURPOSE - FTP to a server get a list of files and retrive them
      * WRITTEN -
      * AUTHOR  -
      *
      *=======================================================================
     d cmdstring       s           2000
     d cmdlength       s             15  5
     d ftpdata         s            100
     d Q               s              1    inz('''')
     d remoteIP        s             15    inz('XX.X.X.XX')
     d sqlstmt         s          23000    varying

     d openList        pr
     d FetchNext       pr              n
     d closeList       pr

      // external calls
     d $command        pr                  extpgm( 'QCMDEXC' )
     d   cmdstring                 2000    options( *varsize ) const
     d   cmdlength                   15  5                     const

      /free

         exsr $ftplist;
         exsr $readList;

         *inlr = *on;

        //-------------------------------------------
        // $ftpList - List the directory contents to
        //            a table DIROUTPUT.
        //
        // if it doesnt exist system creates if there
        // then member is *Replaced..
        //-------------------------------------------
             begsr $ftpList;

                 // now copy the file to the IFS

              cmdstring = 'CPYTOIMPF FROMFILE(QTEMP/SLS28WORKP) ' +
                          ' TOSTMF(' + Q + '/home/sls28/sls28.csv' +
                          Q + ') ' +
                          'STMFCODPAG(*PCASCII) ' +
                          'RCDDLM(*CRLF) STRDLM(*NONE) MBROPT(*REPLACE)';
              cmdlength = %len(%trim(cmdstring));
              monitor;
              $command(cmdstring : cmdlength);
              on-error;
              endmon;


             //prepare the FTP

             //in case this is a repeat delete the overrides and
             //the input output file(s)

             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 = 'DLTF FILE(QTEMP/INPUT)';
             cmdlength = %len(%trim(cmdstring));
             monitor;
             $command(cmdstring : cmdlength);
             on-error;
             endmon;

             cmdstring = 'DLTF FILE(QTEMP/OUTPUT)';
             cmdlength = %len(%trim(cmdstring));
             monitor;
             $command(cmdstring : cmdlength);
             on-error;
             endmon;

             cmdstring = 'CRTPF FILE(QTEMP/INPUT) ' +
                          ' RCDLEN(256)';
             cmdlength = %len(%trim(cmdstring));
             monitor;
             $command(cmdstring : cmdlength);
             on-error;
             endmon;

             cmdstring = 'CRTPF FILE(QTEMP/OUTPUT) ' +
                          ' RCDLEN(256)';
             cmdlength = %len(%trim(cmdstring));
             monitor;
             $command(cmdstring : cmdlength);
             on-error;
             endmon;

              // populate the input file


         Exec SQL   INSERT INTO INPUT
                    values('&user  &password');

         Exec SQL   INSERT INTO INPUT
                    values('dir (DISK ');


         Exec SQL   INSERT INTO INPUT
                    values('quit');

             cmdstring = 'OVRDBF FILE(INPUT) TOFILE(QTEMP/INPUT)' +
                         ' OVRSCOPE(*JOB) ';
             cmdlength = %len(%trim(cmdstring));
             monitor;
             $command(cmdstring : cmdlength);
             on-error;
             endmon;

             cmdstring = 'OVRDBF FILE(OUTPUT) TOFILE(QTEMP/OUTPUT)' +
                         ' OVRSCOPE(*JOB) ';
             cmdlength = %len(%trim(cmdstring));
             monitor;
             $command(cmdstring : cmdlength);
             on-error;
             endmon;

             cmdstring = 'STRTCPFTP ' + Q + %trim(remoteIp)  + Q  ;
             cmdlength = %len(%trim(cmdstring));
             monitor;
             $command(cmdstring : cmdlength);
             on-error;
             endmon;

             endsr;

        //-------------------------------------------
        // $readList - read the list created
        //-------------------------------------------

             begsr $readList;

              sqlstmt = 'select * from DIROUTPUT ';
              openList();
              dow fetchNext();

             //   file date              1      8
             //   file time             11     17
             //   date&time              1     17
             //   isdirectory           25     29
             //   file size             29     38
             //   file name             40     89
             //   .....                 49     98



               dsply %subst(ftpdata:40:25) ' ';

              enddo;
              closeList();


             endsr;

        //-------------------------------------------
      /end-free

      *--------------------------------------------------------
      *  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 : ftpdata;
         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



Using C function STRTOK to read .csv table


Sample from Jamie Flanary posted at 2011-12-10 15:10:58

     h dftactgrp(*no) actgrp(*caller) option(*srcstmt)
     h bnddir('QC2LE')

     d counter         s              3s 0
     d displayme       s             20
     d isodate         s               d   inz
     d n12             s             12s 0
     d pointer         s               *
     d reply           s              1
     d response        s           4096a
     d rundte          s              6s 0
     d  token          S            160A   varying
     d                 DS

     dstrtok           PR              *   ExtProc('strtok')
     d string                          *   value options(*string)
     d delim                           *   Value Options(*string)

      /free

         response  =  'tree,dog,bird,,cow,horse,flower';
         response = %scanrpl(',,' : ', ,' : response);
         reset counter;
         pointer = strtok(response: ',');

         dow (pointer <> *null);
          counter+=1;
          token = %trim(%str(pointer));
          pointer = strtok(*null: ',');
          displayme = %trim(token);
          dsply displayme reply;
         enddo;

         *inlr = *on;