contact image

Operations

When I was a young programmer, there existed a group of people known as Operators.... They were responsible for keeping the OS updated, Monitoring the system for errors, printing & distributing reports in various formats and many other very important operator type things. This page is dedicated to those type of functions and the programs that are created to accomplish them.


Post Your Example

skeleton code for deleteing QPAD devices


Sample from Jamie Flanary posted at 2012-07-19 06:56:09

     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('*DEVD')                                             
‚     *                                                                                            €
‚     *  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      ' + 'QSYS';                                                
         //                                                                                         
         // 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('QPAD': ListQPAD.Object) > *zeros;                                       
                   // retrieve the device description                                               
                   $RtvObjD( ObjectDS                                                               
                             : %Size( ObjectDS )                                                    
                             : 'OBJD0400'                                                           
                             : ListQPAD.Object + ListQPAD.library                                   
                             : ListQPAD.ObjectType                                                  
                             : ApiErrorDS                                                           
                                              );                                                    
                                                                                                    
                  // see if created today  & if so delete it                                        
                   cymd = %dec(%subst(OBJECTDS.OBJCRTDAT:1:7):7:0);                                 
                   test(de) *cymd  cymd;                                                            
                   if not%error;                                                                    
                    createdateIso = %date(cymd:*cymd);                                              
                    if CreateDateIso = TodayISO;                                                    
                    endif;                                                                          
                   endif;                                                                           
                                                                                                    
                  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;                                                                             

List jobq info using QSPRJOBQ


Sample from Jamie Flanary posted at 2012-06-26 06:04:38

     H Option(*SRCSTMT:*NODEBUGIO)                                                                  
                                                                                                    
     d CmdLength       s             15  5                                                          
     d CmdString       s            512                                                             
     d Reply           s              1                                                             
                                                                                                    
     d $GetJobq        pr                  EXTPGM('QSPRJOBQ')                                       
     d  RECIEVER                    144A                                                            
     d  RCVRLEN                      10I 0 const                                                    
     d  FORMAT                        8A   const                                                    
     d  JOBQ                         20A   consT                                                    
     d  ERROR                       116A                                                            
      *                                                                                             
     dMyJobQDS         DS                  Qualified                                                
     d BytesReturned                 10i 0                                                          
     d BytesAvailable                10i 0                                                          
     d JobQName                      10                                                             
     d JobQLib                       10                                                             
     d OppControlled                 10                                                             
     d AuthorityChk                  10                                                             
     d NumberOfJobs                  10i 0                                                          
     d JobqStatus                    10                                                             
     d SubsystemName                 10                                                             
     d SubsystemLib                  10                                                             
     d Description                   50                                                             
     d Sequence#                     10i 0                                                          
     d MaximumActive                 10i 0                                                          
     d CurrentActive                 10i 0                                                          
     d MaxActPri1                    10i 0                                                          
     d MaxActPri2                    10i 0                                                          
     d MaxActPri3                    10i 0                                                          
     d MaxActPri4                    10i 0                                                          
     d MaxActPri5                    10i 0                                                          
     d MaxActPri6                    10i 0                                                          
     d MaxActPri7                    10i 0                                                          
     d MaxActPri8                    10i 0                                                          
     d MaxActPri9                    10i 0                                                          
     d ActJobsPri1                   10i 0                                                          
     d ActJobsPri2                   10i 0                                                          
     d ActJobsPri3                   10i 0                                                          
     d ActJobsPri4                   10i 0                                                          
     d ActJobsPri5                   10i 0                                                          
     d ActJobsPri6                   10i 0                                                          
     d ActJobsPri7                   10i 0                                                          
     d ActJobsPri8                   10i 0                                                          
     d ActJobsPri9                   10i 0                                                          
     d ActJobsPri10                  10i 0                                                          
     d RlsJObsOnQ1                   10i 0                                                          
     d RlsJObsOnQ2                   10i 0                                                          
     d RlsJObsOnQ3                   10i 0                                                          
     d RlsJObsOnQ4                   10i 0                                                          
     d RlsJObsOnQ5                   10i 0                                                          
     d RlsJObsOnQ6                   10i 0                                                          
     d RlsJObsOnQ7                   10i 0                                                          
     d RlsJObsOnQ8                   10i 0                                                          
     d RlsJObsOnQ9                   10i 0                                                          
     d RlsJObsOnQ10                  10i 0                                                          
     d SchJobsOnQ1                   10i 0                                                          
     d SchJobsOnQ2                   10i 0                                                          
     d SchJobsOnQ3                   10i 0                                                          
     d SchJobsOnQ4                   10i 0                                                          
     d SchJobsOnQ5                   10i 0                                                          
     d SchJobsOnQ6                   10i 0                                                          
     d SchJobsOnQ7                   10i 0                                                          
     d SchJobsOnQ8                   10i 0                                                          
     d SchJobsOnQ9                   10i 0                                                          
     d SchJobsOnQ10                  10i 0                                                          
     d HldJobsOnQ1                   10i 0                                                          
     d HldJobsOnQ2                   10i 0                                                          
     d HldJobsOnQ3                   10i 0                                                          
     d HldJobsOnQ4                   10i 0                                                          
     d HldJobsOnQ5                   10i 0                                                          
     d HldJobsOnQ6                   10i 0                                                          
     d HldJobsOnQ7                   10i 0                                                          
     d HldJobsOnQ8                   10i 0                                                          
     d HldJobsOnQ9                   10i 0                                                          
     d HldJobsOnQ10                  10i 0                                                          
      *                                                                                             
      * Standard API error data structure                                                           
      *                                                                                             
     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                                                             
                                                                                                    
     d $command        pr                  extpgm('QCMDEXC')                                        
     d   command                    512                                                             
     d   Length                      15  5                                                          
      *                                                                                             
                                                                                                    
      // ****************************************************************** //                      
      // *  Main Calculations                                             * //                      
      // ****************************************************************** //                      
                                                                                                    
      /Free                                                                                         
                                                                                                    
       $getJobQ(MyJobQDS:%SIZE(MyJobQDS):'JOBQ0200':                                                
                   'QBATCH    QGPL':APIERROR);                                                      
                                                                                                    
       DSPLY MyJobQDS.JobQStatus Reply;                                                             
                                                                                                    
       cmdstring = 'HLDJOBQ QBATCH';                                                                
       cmdlength = %len(%trim(cmdstring));                                                          
       // $command(cmdstring: cmdlength);                                                           
                                                                                                    
       cmdstring = 'RLSJOBQ QBATCH';                                                                
       cmdlength = %len(%trim(cmdstring));                                                          
       // $command(cmdstring: cmdlength);                                                           
                                                                                                    
       *inlr = *on;                                                                                 
                                                                                                    
      /End-Free                                                                                     

Part II to the FTP below


Sample from Jamie Flanary posted at 2012-06-08 08:13:12

     H Option( *SrcStmt: *NoDebugIo )  BndDir( 'QC2LE' ) DFTACTGRP(*No)                             
     ‚**********************************************************************                        
     ‚* Project ID     Date  Pgmr ID  Rev  Description                                              
     ‚*                                                                                             
     ‚*            12/05/17  JJF       00  program written                                          
     ‚*     Read .csv documents pulled from the signmanest system                                
     ‚*     write them to system i table them rename and move to subfolder - History	                                                              
     ‚*                 /sigmanest/nests                                                            
     ‚*                                                                          
     ‚*                                                                       
     ‚*      the "CSV" looks like this                                                                 
     ‚*                                                                       
     ‚*      "Program Number  ;;;;""506326  "";;;;;;;;;;;;;;""6/8/2012 9:26:52 AM  "";;;;;;"
     ‚*        "Sheet Name  ;;;"""";;;;""1962.78  "";;;;;"""";;;;;;;;;;;;;"
     ‚*        "Rect Wgt  ;;;;;;""1962.78  "";;;;;;;;;"
     ‚*        "Cutting Time  ;;""00:19:39  "";;;;;;;"
     ‚*
     ‚*        "Part ID  ;;"""";;;;""Cutting Distance | Inches  "";;;;;;"""";
     ‚*        ""Cutting Pierces  "";;;;"""";;;;""
     ‚*         Qty Nstd  "";;"""";""Pro  Number  "";;""Cntr  "";"""";;
     ‚*        ""Cutting Time - One Piece  "";;;;"""";""Program #  "";;"""";"
     ‚*        "1  ;;""19.83  "";;;;;;""0  "";""1  "";;""8912211  "";;""1  "";;
     ‚*        ""00:19:39  "";;""506326  "";;;;"
     ‚*
     ‚*        Page 1  ;;
     ‚*                                                            
     ‚*                                                                       
     ‚*                                                                       
     ‚*                                                                       
     ‚*                                                                       
 
     '**********************************************************************                        
     fcsznest   uf a e             disk                                                             
      *                                                                                             
      * Directory Entry Structure (dirent)                                                          
      *                                                                                             
     d p_dirent        s               *                                                            
     d dirent          ds                  based(p_dirent)                                          
     d   d_reserv1                   16A                                                            
     d   d_reserv2                   10U 0                                                          
     d   d_fileno                    10U 0                                                          
     d   d_reclen                    10U 0                                                          
     d   d_reserv3                   10I 0                                                          
     d   d_reserv4                    8A                                                            
     d   d_nlsinfo                   12A                                                            
     d     nls_ccsid                 10I 0 OVERLAY(d_nlsinfo:1)                                     
     d     nls_cntry                  2A   OVERLAY(d_nlsinfo:5)                                     
     d     nls_lang                   3A   OVERLAY(d_nlsinfo:7)                                     
     d     nls_reserv                 3A   OVERLAY(d_nlsinfo:10)                                    
     d   d_namelen                   10U 0                                                          
     d   d_name                     640A                                                            
      *------------------------------------------------------------                                 
      * Open a Directory                                                                            
      *------------------------------------------------------------                                 
     d opendir         pr              *   EXTPROC('opendir')                                       
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Read Directory Entry                                                                        
      *------------------------------------------------------------                                 
     d readdir         pr              *   EXTPROC('readdir')                                       
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Close Directory                                                                             
      *------------------------------------------------------------                                 
     d closedir        pr              *   EXTPROC('closedir')                                      
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Open IFs table                                                                              
      *------------------------------------------------------------                                 
     d open            pr            10i 0   ExtProc('open')                                        
     d   filename                      *     value                                                  
     d   openflags                   10i 0   value                                                  
     d   mode                        10u 0   value options(*nopass)                                 
     d   codepage                    10u 0   value options(*nopass)                                 
      *------------------------------------------------------------                                 
      * Read IFS table                                                                              
      *------------------------------------------------------------                                 
     d read            pr            10i 0   ExtProc('read')                                        
     d   filehandle                  10i 0   value                                                  
     d   datareceived                  *     value                                                  
     d   nbytes                      10u 0   value                                                  
      *------------------------------------------------------------                                 
      * Close IFs table                                                                             
      *------------------------------------------------------------                                 
     d close           pr            10i 0   ExtProc('close')                                       
     d   filehandle                  10i 0   value                                                  
      *------------------------------------------------------------                                 
      * read ifs table  - internal procedure                                                        
      *------------------------------------------------------------                                 
     d RdIfsFil        pr           256a                                                            
     d  FileName                    256a   const                                                    
      *------------------------------------------------------------                                 
      * Delay - sleep function                                                                      
      *------------------------------------------------------------                                 
     d sleep           pr            10i 0 ExtProc( 'sleep' )                                       
     d  seconds                      10u 0 Value                                                    
      *------------------------------------------------------------                                 
      * Command - run a command                                                                     
      *------------------------------------------------------------                                 
     d $command        pr                  extpgm('QCMDEXC')                                        
     d   command                    256                                                             
     d   length                      15  5                                                          
      *------------------------------------------------------------                                 
      * Grab the date in LongFormat                                                                 
      *------------------------------------------------------------                                 
     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)                                           
                                                                                                    
     dstrtok           PR              *   ExtProc('strtok')                                        
     d string                          *   value options(*string)                                   
     d delim                           *   Value Options(*string)                                   
      *------------------------------------------------------------                                 
      * a few local variables...                                                                    
     d BaseDate        s               d   inz(D'1582-10-14')                                       
     d cmdlength       s             15  5                                                          
     d cmdstring       s            256                                                             
     d count           s              3  0                                                          
     d counter         s             10i 0                                                          
     d cr              c                   Const(x'0D')                                             
     d data            s          65535A                                                            
     d Data_Rec        s          65535A                                                            
     d datasize        s              5  0                                                          
     d decimal3        s              3  0                                                          
     d decimal22       s              2  2                                                          
     d detailCounter   s              3  0                                                          
     d dh              s               *                                                            
     d Eol             c                   Const(x'0D25')                                           
     d Error_Flag      s              1A   INZ('0')                                                 
     d File            s            256                                                             
     d FileName        s            256    varying                                                  
     d FolderNames     s            256    dim(500)                                                 
     d found           s              3  0                                                          
     d Fp              s             10i 0                                                          
     d KeepLooping     s               n   inz('1')                                                 
     d lf              C                   Const(x'25')                                             
     d MyNewName       s            265    varying                                                  
     d N               s              5  0                                                          
     d nDays           s             10i 0                                                          
     d NewNameCount    s             10i 0 inz                                                      
      * values for oflag parameter, used by open()                                                  
     d O_RDONLY        s             10i 0   inz(1)                                                 
     d O_TEXTDATA      s             10i 0   inz(16777216)                                          
     d Oflag           s             10i 0                                                          
     d Omode           s             10u 0                                                          
     d PathName        s             17    inz('/sigmanest/nests/')                                 
     d PathNameHist    s             25    inz('/sigmanest/nests/history/')                         
     d pointer         s               *                                                            
     d Q               s              1    inz('''')                                                
     d R               S              5  0                                                          
     d Rc              S             10i 0                                                          
     d ReadingDetail   s               n                                                            
     d ReturnData      s             12                                                             
     d SleepSeconds    s             10i 0 inz(300)                                                 
     d ta              s              3  0                                                          
     d Today           s               d   inz(*SYS)                                                
     d  token          S            160A   varying                                                  
         // entire document stored in here                                                          
     d MyData          ds                  qualified  inz                                           
     d  bighunkdata               65535                                                             
     d   OneSlice                    60    dim(1000) overlay(bighunkdata:*next)                     
      *------------------------------------------------------                                       
      * MAIN LINE                                                                                   
      *------------------------------------------------------                                       
      /free                                                                                         
                                                                                                    
              //start the ftp process to retrieve more documents                                    
                                                                                                    
                // program will loop until outside force                                            
                // stops it.                                                                        
              dow KeepLooping;                                                                      
               exsr $GetFileName;                                                                   
               if ta > *zeros;                                                                      
                // read the tables one at a time                                                    
                for count = 1 to ta;                                                                
                 filename = foldernames(count);                                                     
                 // this reads entire file                                                          
                 Error_flag = rdifsfil(Filename);                                                   
                  exsr $breakapart;                                                                 
                  exsr $MoveToHistory;                                                              
                  reset Mydata;                                                                     
                endfor;                                                                             
               endif;                                                                               
                                                                                                    
               // Step3: Close the directory to reprocess                                           
               closedir(dh);                                                                        
                                                                                                    
               // Delay job for a number of seconds then start                                      
               // the process all over again.                                                       
               sleep(SleepSeconds);                                                                 
              enddo;                                                                                
                                                                                                    
           *inlr = *on;                                                                             
                                                                                                    
           //-------------------------------------------                                            
           // $GetFileName - get the next csv table                                                 
           //-------------------------------------------                                            
                                                                                                    
             begsr $GetFileName;                                                                    
                                                                                                    
               clear filename;                                                                      
                // tables will hold all the names of the tables                                     
               clear TA;                                                                            
               clear folderNames;                                                                   
                // loop on the directory                                                            
                // Step1: Open up the directory.                                                    
             //PathName = '/sigmanest/nests/';                                                      
               dh = opendir(%addr(PathName));                                                       
               if dh <> *NULL;                                                                      
                // Step2: Read each entry from the directory (in a loop)                            
                p_dirent = readdir(dh);                                                             
                dow p_dirent <> *NULL;                                                              
                 if d_namelen < 256;                                                                
                  // set filename to lowercase                                                      
                  FileName = %subst(d_name:1:d_namelen);                                            
                  exec sql Set :FileName = lower(:filename);                                        
                  // process only csv files                                                         
                  // even MT directory contains folders:                                            
                  // o .                                                                            
                  // o ..                                                                           
                  if %scan('.csv':Filename) > *zeros;                                               
                   ta+=1;                                                                           
                   foldernames(ta) = %trim(pathname) + %trim(filename);                             
                  endif;                                                                            
                 endif;                                                                             
                  p_dirent = readdir(dh);                                                           
                enddo;                                                                              
               endif;                                                                               
                                                                                                    
             endsr;                                                                                 
                                                                                                    
           //-------------------------------------------                                            
           // $BreakApart - break apart the .csv into                                               
           //               fields.                                                                 
           //-------------------------------------------                                            
                                                                                                    
             begsr $BreakApart;                                                                     
                                                                                                    
              mydata.bighunkdata  =                                                                 
               %scanrpl(',,' : ', ,' : mydata.bighunkdata);                                         
                                                                                                    
              reset ReadingDetail;                                                                  
              reset DetailCounter;                                                                  
              reset counter;                                                                        
                                                                                                    
              pointer = strtok(mydata.bighunkdata: ',');                                            
              dow (pointer <> *null);                                                               
               counter+=1;                                                                          
               token = %trim(%str(pointer));                                                        
               if token = 'Program#';                                                               
                ReadingDetail = *on;                                                                
                DetailCounter = -1;                                                                 
               endif;                                                                               
                                                                                                    
               select;                                                                              
                when counter = 4;                                                                   
                 if token <> *blanks;                                                               
                  cznest# = %dec(token:7:0);                                                        
                 else;                                                                              
                  cznest# = *zeros;                                                                 
                 endif;                                                                             
                when  %scan(':':token) = 3 and counter <=  82;                                      
                 token = %xlate(' ':'0':token);                                                     
                 token =  %scanrpl(':' : '' : token);                                               
                                                                                                    
                 monitor;                                                                           
                  decimal3  = %dec(%subst(token:2:3):3:0);                                          
                 on-error;                                                                          
                  pointer = strtok(*null: ',');                                                     
                  iter;                                                                             
                 endmon;                                                                            
                                                                                                    
                 decimal22 = (%dec(%subst(token:5:2):2:0)/100);                                     
                 czttime = decimal3 + decimal22;                                                    
               endsl;                                                                               
                                                                                                    
                                                                                                    
               if   ReadingDetail = *on;                                                            
                DetailCounter+=1;                                                                   
                                                                                                    
                if %scan('Page1':token) > *zeros;                                                   
                 leave;                                                                             
                endif;                                                                              
                                                                                                    
                // process the detail records                                                       
                select;                                                                             
                 when detailCounter = 2;                                                            
                  CZPARTID = %dec(%xlate(' ':'0':token):3:0);                                       
                 when detailCounter = 4;                                                            
                  found = %scan('.':token);                                                         
                  if found > *zeros;                                                                
                   decimal3  = %dec(%subst(token:found-1):3:0);                                     
                   decimal22 = (%dec(%subst(token:found+1):2:0)/100);                               
                   czftge = decimal3 + decimal22;                                                   
                  endif;                                                                            
                 when detailCounter = 9;                                                            
                  found = %len(%trim(token));                                                       
                  czqnest = %dec(%subst(token:1:found):3:0);                                        
                 when detailCounter = 11;                                                           
                  found = %len(%trim(token));                                                       
                  czpro7 = %dec(%subst(token:1:found):7:0);                                         
                 when detailCounter = 13;                                                           
                  found = %len(%trim(token));                                                       
                  czcnt3 = %dec(%subst(token:1:found):3:0);                                         
                 when detailCounter = 15;                                                           
                  token = %xlate(' ':'0':token);                                                    
                  token =  %scanrpl(':' : '' : token);                                              
                                                                                                    
                  monitor;                                                                          
                   decimal3  = %dec(%subst(token:2:3):3:0);                                         
                  on-error;                                                                         
                   pointer = strtok(*null: ',');                                                    
                   iter;                                                                            
                  endmon;                                                                           
                                                                                                    
                  decimal22 = (%dec(%subst(token:5:2):2:0)/100);                                    
                  cztime = decimal3 + decimal22;                                                    
                 when detailCounter = 17;                                                           
                   found = %len(%trim(token));                                                      
                                                                                                    
                  monitor;                                                                          
                   czpgm# = %dec(%subst(token:1:found):7:0);                                        
                  on-error;                                                                         
                   pointer = strtok(*null: ',');                                                    
                   iter;                                                                            
                  endmon;                                                                           
                                                                                                    
                endsl;                                                                              
                                                                                                    
                if DetailCounter = 18;                                                              
                 czstamp = %timestamp();                                                            
                 // percentage                                                                      
                 if czttime > *zeros;                                                               
                  czpercent = %dech(cztime/czttime:9:4)*100;                                        
                 else;                                                                              
                  czpercent = *zeros;                                                               
                 endif;                                                                             
                 write csznestr;                                                                    
                 reset DetailCounter;                                                               
                endif;                                                                              
               endif;                                                                               
                                                                                                    
                                                                                                    
               pointer = strtok(*null: ',');                                                        
              enddo;                                                                                
                                                                                                    
             endsr;                                                                                 
                                                                                                    
           //-------------------------------------------                                            
           // $MoveToHistory - move processed table to                                              
           //                  history                                                              
           //-------------------------------------------                                            
                                                                                                    
             begsr $MoveToHistory;                                                                  
                                                                                                    
              //  *****  Rename the file  *****                                                     
              // RNM OBJ('/sigmanest/nests/106103.csv')                                             
              // NEWOBJ('SomeNewName.csv')                                                          
              // *like: November16_2011_114547.csv                                                  
                 nDays = %diff(today : baseDate : *days);                                           
                 ceedate(nDays:'Mmmmmmmmmm':ReturnData:*OMIT);                                      
                 NewNameCount +=1;                                                                  
                 MyNewName = %trim(ReturnData)  +                                                   
                 %char(%subdt(Today:*days)) + '_' +                                                 
                 %char(%subdt(Today:*years)) + '_' +                                                
                 %ScanRpl('.' : '' :                                                                
                 %char(%time())) +    %trim(%char(NewNameCount)) +                                  
                 '.csv';                                                                            
                                                                                                    
                 cmdstring = 'RNM OBJ(' + Q +                                                       
                             %trim(filename) + Q + ')' +                                            
                             ' NEWOBJ(' + Q + %trim(MyNewName) +                                    
                             Q + ')';                                                               
                                                                                                    
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring:cmdlength);                                                    
                 on-error;                                                                          
                  // process for errors                                                             
                 endmon;                                                                            
              //  *****  Move file to history  *****                                                
              // MOV OBJ('/sigmanest/nests/106078.CSV')                                             
              //  TODIR('/sigmanest/nests/history')                                                 
                 cmdstring = 'MOV OBJ(' + Q + %trim(PathName) +                                     
                             %trim(MyNewName) + Q + ')' +                                           
                             ' TODIR(' + Q + %trim(PathNameHist) +                                  
                             Q + ')';                                                               
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring:cmdlength);                                                    
                 on-error;                                                                          
                  // process for errors                                                             
                 endmon;                                                                            
             endsr;                                                                                 
           //-------------------------------------------                                            
      /end-free                                                                                     
      *-------------------------------------------------------------                                
      *    RdIfsFil - Subprocedure To Read The IFS File                                             
      *-------------------------------------------------------------                                
     p RdIfsFil        B                   Export                                                   
     d RdIfsFil        PI           256A                                                            
     d  FileName                    256A   Const                                                    
     d CharsRead       S             10i 0                                                          
     d CurChar         S              1                                                             
     d Eof             C                   const(x'00')                                             
      /free                                                                                         
             Oflag = O_Rdonly + O_Textdata;                                                         
             // need whole path here                                                                
             File = %trim(FileName) + x'00';                                                        
             Fp = open(%addr(File): Oflag);                                                         
             if  Fp < 0;                                                                            
              Error_Flag = *On;                                                                     
              Return  Error_Flag;                                                                   
             Endif;                                                                                 
             R = 0;                                                                                 
             N = 0;                                                                                 
             dou  CurChar = Eof;                                                                    
              exsr getChar;                                                                         
              R+=1;                                                                                 
              %Subst(Data: R: 1) = CurChar;                                                         
              if CurChar = X'25';                                                                   
               %Subst(Data: R: 1)  = *blanks;                                                       
              endif;                                                                                
              select;                                                                               
               when  R = 256 or CurChar = X'25';                                                    
           // if you find the  code then we still have more data in                                 
           // memory  and we need to process that remaining data.                                   
                if  CurChar = X'25';                                                                
                 %Subst(Data: R: 1)  = *blanks;                                                     
                endif;                                                                              
            // one record is here                                                                   
                clear  R;                                                                           
                clear  Data;                                                                        
              endsl;                                                                                
             enddo;                                                                                 
             Return    Error_Flag;                                                                  
          //---------------------------------------------------------                               
          //  GetChar - Process IFS Record, One Character At A Time                                 
          //---------------------------------------------------------                               
             begsr GetChar;                                                                         
               //  If input buffer is empty, or all characters have been                            
               //    processed, refill the input buffer.                                            
              if N = CharsRead;                                                                     
               CharsRead = Read(Fp:%Addr(Data_Rec): 2560);                                          
               N = *Zero;                                                                           
              endif;                                                                                
               // Get the next character in the input buffer.                                       
              if CharsRead <= 0;                                                                    
               CurChar = Eof;                                                                       
              else;                                                                                 
               N+=1;                                                                                
               CurChar = %Subst(Data_Rec: N: 1);                                                    
               curchar = %scanrpl(';':',':curchar);                                                 
               curchar = %scanrpl('"':' ':curchar);                                                 
               select;                                                                              
                when  CurChar = *blanks or CurChar = cr  or  CurChar = lf;                          
                 mydata.bighunkdata = %trim(mydata.bighunkdata) + ' ';                              
                other;                                                                              
                 mydata.Bighunkdata = %trim(mydata.bighunkdata) +                                   
                 %trim(Curchar);                                                                    
                endsl;                                                                              
              endif;                                                                                
             endsr;                                                                                 
         //---------------------------------------------------------                                
      /end-free                                                                                     
     p RdIfsFil        E                                                                            

Ftp to windows server process .csv tables


Sample from Jamie Flanary posted at 2012-06-08 07:41:55

      *=======================================================================                      
      *                                                                                             
      * PROGRAM -                                                                                   
      * PURPOSE - Program grabs .csv documents from server lbi-13                                   
      *           copies them to the IFS /sigmanest/nests/ then deletes                             
      *           them from the server                                                              
      * WRITTEN - 06/01/2012                                                                        
      * AUTHOR  - jamie flanary                                                                     
                                                                                                    
      * AUTHORITY PARAMETERS                                                                        
      *   Description                      How Used                                                 
      *   -----------                      --------                                                 
                                                                                                    
      * PROGRAM DESCRIPTION                                                                         
      *   This program will grab .csv documents from server then copy to IFS & delete               
      *                                                                                             
      * INDICATOR USAGE                                                                             
      *   03 - leave current screen                                                                 
      *                                                                                             
      *=======================================================================                      
     d cmdstring       s           2000                                                             
     d cmdlength       s             15  5                                                          
     d DataString      s            100                                                             
     d ftpdata         s            100                                                             
     d IseriesFolder   s            256    inz('/sigmanest/nests/')                                 
     d mode            s              1                                                             
     d Password        s             10    inz('Password')                                           
     d Q               s              1    inz('''')                                                
     d remoteIP        s             15    inz('10.0.1.13')                                         
     d sqlstmt         s          23000    varying                                                  
     d Userid          s             10    inz('Userid')                                           
                                                                                                    
     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                                                                                         
                                                                                                    
         mode = '1';                                                                                
         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;                                                                        
                                                                                                    
             //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;                                                                                
                                                                                                    
             // depend on process what commands can be entered                                      
             select;                                                                                
              when Mode = '1';                                                                      
               // populate the input file                                                           
               datastring = %trim(Userid) + '   ' + %trim(Password);                                
               Exec SQL   INSERT INTO INPUT                                                         
                     values(:dataString);                                                           
               Exec SQL   INSERT INTO INPUT                                                         
                     values('dir (DISK ');                                                          
               Exec SQL   INSERT INTO INPUT                                                         
                     values('quit');                                                                
              when Mode = '2';                                                                      
               // populate the input file                                                           
               datastring = %trim(Userid) + '   ' + %trim(Password);                                
               Exec SQL   INSERT INTO INPUT                                                         
                     values(:dataString);                                                           
               Exec SQL   INSERT INTO INPUT                                                         
                     values('bin');                                                                 
                                                                                                    
               datastring = 'namefmt 1';                                                            
               Exec SQL   INSERT INTO INPUT                                                         
                     values(:dataString);                                                           
                                                                                                    
               datastring = 'get   ' + %trim(%subst(ftpdata:40:25)) + '  ' +                        
                            %trim(IseriesFolder)  +                                                 
                            %trim(%subst(ftpdata:40:25)) + '  ' +                                   
                            ' (replace';                                                            
               Exec SQL   INSERT INTO INPUT                                                         
                     values(:dataString);                                                           
               datastring = 'dele ' + %trim(%subst(ftpdata:40:25));                                 
               Exec SQL   INSERT INTO INPUT                                                         
                     values(:dataString);                                                           
             endsl;                                                                                 
                                                                                                    
             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                                                   
               if %scan('.CSV' :%subst(ftpdata:40:25)) > *zeros;                                    
                mode = '2';                                                                         
                exsr $ftplist;                                                                      
               endif;                                                                               
              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                                                                            
                                                                                                   

List and enable disabled NetServer users


Sample from Carsten Flensburg posted at 2011-12-18 20:03:02

      **                                                                                            
      **  Program . . : CBX110                                                                      
      **  Description : List and enable disabled NetServer users                                    
      **  Author  . . : Carsten Flensburg                                                           
      **                                                                                            
      **                                                                                            
      **  Compile options:                                                                          
      **                                                                                            
      **    CrtRpgMod Module( CBX110 )  DbgView( *LIST )                                            
      **                                                                                            
      **    CrtPgm    Pgm( CBX110 )                                                                 
      **              Module( CBX110 )                                                              
      **                                                                                            
      **                                                                                            
      **-- Header specifications:  --------------------------------------------**                   
     H Option( *SrcStmt )                                                                           
      **-- API error data structure:                                                                
     D ERRC0100        Ds                  Qualified                                                
     D  BytPrv                       10i 0 Inz( %Size( ERRC0100 ))                                  
     D  BytAvl                       10i 0                                                          
     D  MsgId                         7a                                                            
     D                                1a                                                            
     D  MsgDta                      256a                                                            
                                                                                                    
     **-- Global constants:                                                                         
     D OFS_MSGDTA      c                   16                                                       
     **-- Global variables:                                                                         
     D Idx             s             10i 0                                                          
     D MsgRpy          s             32a   Varying                                                  
     D NetSvrUsr       s             10a   Varying                                                  
                                                                                                    
     **-- API parameters:                                                                           
     D ZLSL0900        Ds                  Qualified                                                
     D  DsaNetUsr                    10a   Dim( 1024 )                                              
     **-- List information:                                                                         
     D LstInf          Ds                  Qualified                                                
     D  RcdNbrTot                    10i 0                                                          
     D  RcdNbrRtn                    10i 0                                                          
     D  RcdLen                       10i 0                                                          
     D  InfLenRtn                    10i 0                                                          
     D  InfCmp                        1a                                                            
     D  Dts                          13a                                                            
     D                               34a                                                            
     **-- Request variable:                                                                         
     D ZLSS0200        Ds                  Qualified                                                
     D  NbrSvrUsr                    10i 0                                                          
     D  NetSvrUsr                    10a   Dim( 1024 )                                              
                                                                                                    
     **-- Open list of server information:                                                          
     D LstSvrInf       Pr                  ExtPgm( 'QZLSOLST' )                                     
     D  LsRcvVar                  32767a          Options( *VarSize )                               
     D  LsRcvVarLen                  10i 0 Const                                                    
     D  LsLstInf                     64a                                                            
     D  LsFmtNam                     10a   Const                                                    
     D  LsInfQual                    15a   Const                                                    
     D  LsError                   32767a          Options( *VarSize )                               
     **                                                                                             
     D  SiSsnUsr                     10a   Const  Options( *NoPass )                                
     **                                                                                             
     D  SiSsnId                      20i 0 Const  Options( *NoPass )                                
     **-- Change server information:                                                                
     D ChgSvrInf       Pr                  ExtPgm( 'QZLSCHSI' )                                     
     D  CsRqsVar                  32767a   Const  Options( *VarSize )                               
     D  CsRqsVarLen                  10i 0 Const                                                    
     D  CsFmtNam                     10a   Const                                                    
     D  CsError                   32767a          Options( *VarSize )                               
     **-- Send program message:                                                                     
     D SndPgmMsg       Pr                  ExtPgm( 'QMHSNDPM' )                                     
     D  SpMsgId                       7a   Const                                                    
     D  SpMsgFq                      20a   Const                                                    
     D  SpMsgDta                    512a   Const  Options( *VarSize )                               
     D  SpMsgDtaLen                  10i 0 Const                                                    
     D  SpMsgTyp                     10a   Const                                                    
     D  SpCalStkE                    10a   Const  Options( *VarSize )                               
     D  SpCalStkCtr                  10i 0 Const                                                    
     D  SpMsgKey                      4a                                                            
     D  SpError                     512a          Options( *VarSize )                               
     **                                                                                             
     D  SpCalStkElen                 10i 0 Const  Options( *NoPass )                                
     D  SpCalStkEq                   20a   Const  Options( *NoPass )                                
     D  SpDspWait                    10i 0 Const  Options( *NoPass )                                
     **                                                                                             
     D  SpCalStkEtyp                 20a   Const  Options( *NoPass )                                
     D  SpCcsId                      10i 0 Const  Options( *NoPass )                                
     **-- Receive program message:                                                                  
     D RcvPgmMsg       Pr                  ExtPgm( 'QMHRCVPM' )                                     
     D  RpRcvVar                  32767a          Options( *VarSize )                               
     D  RpRcvVarLen                  10i 0 Const                                                    
     D  RpFmtNam                     10a   Const                                                    
     D  RpCalStkE                   256a   Const  Options( *VarSize )                               
     D  RpCalStkCtr                  10i 0 Const                                                    
     D  RpMsgTyp                     10a   Const                                                    
     D  RpMsgKey                      4a   Const                                                    
     D  RpWait                       10i 0 Const                                                    
     D  RpMsgAct                     10a   Const                                                    
     D  RpError                   32767a          Options( *VarSize )                               
     **                                                                                             
     D  RpCalStkElen                 10i 0 Const  Options( *NoPass )            call stack counter  
     D  RpCalStkEq                   20a   Const  Options( *NoPass )            call stack counter  
     **                                                                                             
     D  RpCalStkEtyp                 20a   Const  Options( *NoPass )            call stack counter  
     D  RpCcsId                      10i 0 Const  Options( *NoPass )            call stack counter  
     **-- Get inquiry message reply:                                                                
     D GetInqRpy       Pr           128a   Varying                                                  
     D  PxMsgDta                    512a   Const  Varying                                           
     **-- Send completion message:                                                                  
     D SndCmpMsg       Pr            10i 0                                                          
     D  PxMsgDta                    512a   Const  Varying                                           
     **-- Send escape message:                                                                      
     D SndEscMsg       Pr            10i 0                                                          
     D  PxMsgId                       7a   Const                                                    
     D  PxMsgF                       10a   Const                                                    
     D  PxMsgDta                    512a   Const  Varying                                           
                                                                                                    
      /Free                                                                                         
                                                                                                    
        LstSvrInf( ZLSL0900                                                                         
                 : %Size( ZLSL0900 )                                                                
                 : LstInf                                                                           
                 : 'ZLSL0900'                                                                       
                 : *Blank                                                                           
                 : ERRC0100                                                                         
                 );                                                                                 
                                                                                                    
           If  ERRC0100.BytAvl > *Zero;                                                             
               SndEscMsg( ERRC0100.MsgId                                                            
                  : 'QCPFMSG'                                                                       
                   : %Subst( ERRC0100.MsgDta: 1: ERRC0100.BytAvl - OFS_MSGDTA )                     
                  );                                                                                
                                                                                                    
             ElseIf  LstInf.InfCmp = 'C';                                                           
                                                                                                    
             For Idx = 1  to LstInf.RcdNbrTot;                                                      
                                                                                                    
             ExSr  PrcLstEnt;                                                                       
             EndFor;                                                                                
        EndIf;                                                                                      
                                                                                                    
        SndCmpMsg( 'NetServer user activation completed.' );                                        
                                                                                                    
         Return;                                                                                    
                                                                                                    
         BegSr  PrcLstEnt;                                                                          
                                                                                                    
          NetSvrUsr = %TrimR( ZLSL0900.DsaNetUsr(Idx) );                                            
                                                                                                    
         MsgRpy = GetInqRpy( 'NetServer user ' + NetSvrUsr +                                        
                         ' disabled. Enable NetServer user (Y=Yes)?'                                
                       );                                                                           
                                                                                                    
           If  %Xlate( 'y':'Y': MsgRpy ) = 'Y';                                                     
                                                                                                    
            ZLSS0200.NbrSvrUsr  = 1;                                                                
            ZLSS0200.NetSvrUsr(1) = NetSvrUsr;                                                      
                                                                                                    
            ChgSvrInf( ZLSS0200: %Size( ZLSS0200 ): 'ZLSS0200': ERRC0100 );                         
                                                                                                    
            If  ERRC0100.BytAvl > *Zero;                                                            
                                                                                                    
             If  ERRC0100.BytAvl < OFS_MSGDTA;                                                      
               ERRC0100.BytAvl = OFS_MSGDTA;                                                        
             EndIf;                                                                                 
                                                                                                    
             SndEscMsg( ERRC0100.MsgId                                                              
                     : 'QCPFMSG'                                                                    
                      : %Subst( ERRC0100.MsgDta                                                     
                            : 1                                                                     
                            : ERRC0100.BytAvl - OFS_MSGDTA                                          
                            )                                                                       
                     );                                                                             
            Else;                                                                                   
              SndCmpMsg( 'NetServer user ' + NetSvrUsr + ' enabled.' );                             
            EndIf;                                                                                  
          EndIf;                                                                                    
                                                                                                    
        EndSr;                                                                                      
                                                                                                    
       /End-Free                                                                                    
                                                                                                    
     **-- Get inquiry message reply:  ----------------------------------------**                    
     P GetInqRpy       B                                                                            
     D                 Pi           128a   Varying                                                  
     D  PxMsgDta                    512a   Const  Varying                                           
     **                                                                                             
     D MsgKey          s              4a                                                            
     **-- Message information structure:                                                            
     D RCVM0100        Ds                  Qualified                                                
     D  BytPrv                       10i 0                                                          
     D  BytAvl                       10i 0                                                          
     D  MsgSev                       10i 0                                                          
     D  MsgId                         7a                                                            
     D  MsgTyp                        2a                                                            
     D  MsgKey                        4a                                                            
     D                                7a                                                            
     D  CcsIdCnvSts                  10i 0                                                          
     D  CcsIdDta                     10i 0                                                          
     D  MsgLenRtn                    10i 0                                                          
     D  MsgLenAvl                    10i 0                                                          
     D  MsgRpy                       32a                                                            
                                                                                                    
      /Free                                                                                         
                                                                                                    
        SndPgmMsg( *Blanks                                                                          
                 : *Blanks                                                                          
                 : PxMsgDta                                                                         
                 : %Len( PxMsgDta )                                                                 
                 : '*INQ'                                                                           
                 : '*EXT'                                                                           
                 : *Zero                                                                            
                 : MsgKey                                                                           
                 : ERRC0100                                                                         
                  );                                                                                
                                                                                                    
         RcvPgmMsg( RCVM0100                                                                        
                 : %Size( RCVM0100 )                                                                
                 : 'RCVM0100'                                                                       
                 : '*'                                                                              
                 : *Zero                                                                            
                 : '*RPY'                                                                           
                 : MsgKey                                                                           
                 : -1                                                                               
                 : '*OLD'                                                                           
                 : ERRC0100                                                                         
                 );                                                                                 
                                                                                                    
         Return  %Subst( RCVM0100.MsgRpy: 1: RCVM0100.MsgLenRtn );                                  
                                                                                                    
      /End-Free                                                                                     
                                                                                                    
     P GetInqRpy       E                                                                            
     **-- Send completion message:  ------------------------------------------**                    
     P SndCmpMsg       B                                                                            
     D                 Pi            10i 0                                                          
     D  PxMsgDta                    512a   Const  Varying                                           
     **                                                                                             
     D MsgKey          s              4a                                                            
                                                                                                    
      /Free                                                                                         
                                                                                                    
        SndPgmMsg( 'CPF9897'                                                                        
                 : 'QCPFMSG   *LIBL'                                                                
                 : PxMsgDta                                                                         
                 : %Len( PxMsgDta )                                                                 
                 : '*COMP'                                                                          
                 : '*PGMBDY'                                                                        
                 : 1                                                                                
                 : MsgKey                                                                           
                 : ERRC0100                                                                         
                 );                                                                                 
                                                                                                    
        If  ERRC0100.BytAvl > *Zero;                                                                
          Return  -1;                                                                               
                                                                                                    
        Else;                                                                                       
         Return  0;                                                                                 
                                                                                                    
        EndIf;                                                                                      
                                                                                                    
      /End-Free                                                                                     
                                                                                                    
     P SndCmpMsg       E                                                                            
     **-- Send escape message:  ----------------------------------------------**                    
     P SndEscMsg       B                                                                            
     D                 Pi            10i 0                                                          
     D  PxMsgId                       7a   Const                                                    
     D  PxMsgF                       10a   Const                                                    
     D  PxMsgDta                    512a   Const  Varying                                           
     **                                                                                             
     D MsgKey          s              4a                                                            
                                                                                                    
      /Free                                                                                         
                                                                                                    
        SndPgmMsg( PxMsgId                                                                          
                 : PxMsgF + '*LIBL'                                                                 
                 : PxMsgDta                                                                         
                 : %Len( PxMsgDta )                                                                 
                 : '*ESCAPE'                                                                        
            : '*PGMBDY'                                                                             
            : 1                                                                                     
            : MsgKey                                                                                
            : ERRC0100                                                                              
            );                                                                                      
                                                                                                    
        If  ERRC0100.BytAvl > *Zero;                                                                
          Return  -1;                                                                               
                                                                                                    
        Else;                                                                                       
         Return   0;                                                                                
        EndIf;                                                                                      
                                                                                                    
      /End-Free                                                                                     
                                                                                                    
     P SndEscMsg       E                                                                            
                                                                                                    
                                                                                                    
                                                                                                    

Find *ALL version of a source member.


Sample from Jamie Flanary posted at 2011-12-18 19:18:35

      *-=-=-=-=-==-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-       
      * Program Name: FINDSRCR                                                                      
      * Description : Find Source Member                                                            
      * Written On  :                                                                               
      *                                                                                             
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     H option(*srcstmt: *nodebugio)  dftactgrp(*no)                                                 
      *                                                                                             
      * Display File                                                                                
      * ~~~~~~~~~~~~                                                                                
     fFINDD     cf   e             workstn                                                          
     f                                     sfile(SFLRCD : RRn1)                                     
      *                                                                                             
      * External Data Structure                                                                     
      * ~~~~~~~~~~~~~~~~~~~~~~~                                                                     
     d sqldata         ds                                                                           
     d  qDBXFIL                      10                                                             
     d  qDBXLIB                      10                                                             
     d  qDBXATR                       2                                                             
     d  qDBXTYP                       1                                                             
     d  qDBXTXT                      50                                                             
      *                                                                                             
      * QUSRMBRD API return Struture                                                                
      * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~                                                                
     d Mbrd0100        ds                  inz                                                      
     d  nBytesRtn                    10i 0                                                          
     d  nBytesAval                   10i 0                                                          
     d  DBXLIB                       10a                                                            
     d  DBXFIL                       10a                                                            
     d  MbrName                      10a                                                            
     d  FileAttr                     10a                                                            
     d  SrcType                      10a                                                            
     d  dtCrtDate                    13a                                                            
     d  dtLstChg                     13a                                                            
     d  MbrText                      50a                                                            
     d  bIsSource                     1a                                                            
     d  RmtFile                       1a                                                            
     d  LglPhyFile                    1a                                                            
     d  ODPSharing                    1a                                                            
     d  filler2                       2a                                                            
     d  RecCount                     10i 0                                                          
     d  DltRecCnt                    10i 0                                                          
     d  DataSpaceSz                  10i 0                                                          
     d  AccpthSz                     10i 0                                                          
     d  NbrBasedOnMbr                10i 0                                                          
      *                                                                                             
      * Constants                                                                                   
      * ~~~~~~~~~                                                                                   
     d Up              c                   const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')                      
     d Low             c                   const('abcdefghijklmnopqrstuvwxyz')                      
      *                                                                                             
      * Variable Definition                                                                         
      * ~~~~~~~~~~~~~~~~~~~                                                                         
     d @Scrn1          s              1    inz('Y')                                                 
     d bOvr            s              1a   inz('0')                                                 
     d CmdString       s            256    inz(*blanks)                                             
     d CmdLength       s             15  5 inz(0)                                                   
     d Fmt             s              8a   inz('MBRD0200')                                          
     d nBufLen         s             10i 0                                                          
     d Q               s              1    inz('''')                                                
     d RRn1            s                   like(ScRRn)                                              
     d SavRRn1         s                   like(ScRRn)                                              
     d sqlstmt         s            512    varying                                                  
     d SrcDBXLIB       s             20a                                                            
      *                                                                                             
      * external calls                                                                              
      *                                                                                             
     d $command        pr                  extpgm( 'QCMDEXC' )                                      
     d   cmdstring                 2000    options( *varsize ) const                                
     d   cmdlength                   15  5                     const                                
                                                                                                    
     d $GetDescription...                                                                           
     d                 pr                  extpgm( 'QUSRMBRD')                                      
     d   cmdstring                 2000    options( *varsize ) const                                
     d   cmdlength                   15  5                     const                                
                                                                                                    
     d openList        PR                                                                           
     d closeList       PR                                                                           
     d FetchNext       PR              N                                                            
      *--------------------------------------------------------                                     
       //                                                                                           
       //  entry plist                                                                              
       //                                                                                           
     d FINDR           pr                                                                           
     d  MemberName                   10                                                             
                                                                                                    
     d FINDR           pi                                                                           
     d  MemberName                   10                                                             
                                                                                                    
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      * MAIN LINE                                                                                   
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      /free                                                                                         
                                                                                                    
           MemberName = %xlate(Low : Up : MemberName);                                              
           exsr $RunQuery;                                                                          
                                                                                                    
           dow  @Scrn1 = 'Y';                                                                       
                                                                                                    
            write FORMAT1;                                                                          
            exfmt SFLCTL;                                                                           
            select;                                                                                 
                                                                                                    
            //F03=Exit/F12=Exit                                                                     
             when *in03 or *in12;                                                                   
              @Scrn1 = 'N';                                                                         
                                                                                                    
            //F02=Change source using SEU                                                           
              when *in02;                                                                           
               if Where > *zeros;                                                                   
                chain where SFLRCD;                                                                 
                if %found(FINDD);                                                                   
                                                                                                    
                 cmdstring =                                                                        
                 'STRSEU  SRCFILE(' +                                                               
                 %trim(DBXLIB) + '/' + %trim(DBXFIL) +                                              
                 ') SRCMBR( ' +                                                                     
                 %trim(MemberName) + ') TYPE(*SAME) ' +                                             
                 ' OPTION(2)';                                                                      
                                                                                                    
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring : cmdlength);                                                  
                 on-error;                                                                          
                 endmon;                                                                            
                endif;                                                                              
               endif;                                                                               
                                                                                                    
              //F07 = copy source                                                                   
              when *in07;                                                                           
               if Where > *zeros;                                                                   
                chain where SFLRCD;                                                                 
                if %found(FINDD);                                                                   
                                                                                                    
                 CmdString = %trim('?CPYSRCF') +                                                    
                 ' FROMFILE(' +                                                                     
                 %trim(DBXLIB) + '/' +                                                              
                 %trim(DBXFIL) + ')' +                                                              
                 ' TOFILE('  +                                                                      
                 %trim(DBXLIB) + '/' +                                                              
                 %trim(DBXFIL) + ')' +                                                              
                 ' FROMMBR(' +                                                                      
                 %trim(MemberName) + ')' +                                                          
                 ' TOMBR(' +                                                                        
                 %trim(MemberName) + ')' +                                                          
                 ' MBROPT(*REPLACE)  SRCOPT(*SAME)';                                                
                                                                                                    
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring : cmdlength);                                                  
                 on-error;                                                                          
                 endmon;                                                                            
                                                                                                    
                endif;                                                                              
               endif;                                                                               
                                                                                                    
            //F08 = start SDA work with screen                                                      
              when *in08;                                                                           
               if Where > *zeros;                                                                   
                chain where SFLRCD;                                                                 
                if %found(FINDD);                                                                   
                 CmdString = 'STRSDA SRCFILE(' +                                                    
                              %trim(DBXLIB) + '/' +                                                 
                              %trim(DBXFIL) + ')' +                                                 
                              ' SRCMBR(' +                                                          
                              %trim(MemberName) + ') OPTION(1)';                                    
                                                                                                    
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring : cmdlength);                                                  
                 on-error;                                                                          
                 endmon;                                                                            
                                                                                                    
                endif;                                                                              
               endif;                                                                               
                                                                                                    
            // display the source only                                                              
              other;                                                                                
               if Where > *zeros;                                                                   
                chain where SFLRCD;                                                                 
                if %found(FINDD);                                                                   
                                                                                                    
                 CmdString = 'STRSEU  SRCFILE(' +                                                   
                             %trim(DBXLIB) + '/' +                                                  
                             %trim(DBXFIL) + ')' +                                                  
                             ' SRCMBR(' +                                                           
                             %trim(MemberName) + ')'+                                               
                             ' TYPE(*SAME) OPTION(5)';                                              
                                                                                                    
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring : cmdlength);                                                  
                 on-error;                                                                          
                 endmon;                                                                            
                                                                                                    
                endif;                                                                              
               endif;                                                                               
                                                                                                    
             endsl;                                                                                 
           enddo;                                                                                   
                                                                                                    
           *inlr = *on;                                                                             
           return;                                                                                  
                                                                                                    
               //-------------------------------------------                                        
               // $clearsfl - clear subfile                                                         
               //-------------------------------------------                                        
                                                                                                    
                    begsr $clearsfl;                                                                
                                                                                                    
                     *in50 = *on;                                                                   
                     *in51 = *off;                                                                  
                     *in52 = *off;                                                                  
                                                                                                    
                      write SFLCTL;                                                                 
                                                                                                    
                      *in50 = *off;                                                                 
                      *in51 = *on;                                                                  
                      *in52 = *on;                                                                  
                                                                                                    
                      rrn1 = *zeros;                                                                
                      scrrn = 1;                                                                    
                      savrrn1 = *zeros;                                                             
                                                                                                    
                      srcname = %trim(MemberName);                                                  
                                                                                                    
                    endsr;                                                                          
                                                                                                    
               //------------------------------------------------                                   
               // $loadsfl - load subfile to display all source                                     
               //------------------------------------------------                                   
                                                                                                    
                    begsr $loadsfl;                                                                 
                                                                                                    
                     reset SFLRCD;                                                                  
                     DBXLIB = qDBXLIB;                                                              
                     DBXFIL = qDBXFIL;                                                              
                     DBXTXT = MbrText;                                                              
                     DBXTYP = SrcType;                                                              
                     RRn1 +=1;                                                                      
                     write SFLRCD;                                                                  
                                                                                                    
                    endsr;                                                                          
                                                                                                    
                                                                                                    
               //------------------------------------------------                                   
               // $loadsfl - load subfile to display all source                                     
               //------------------------------------------------                                   
                                                                                                    
                    begsr $RunQuery;                                                                
                                                                                                    
                     exsr $ClearSFL;                                                                
                                                                                                    
                     sqlstmt = 'select dbxfil, dbxlib, dbxatr, ' +                                  
                               ' dbxtyp, dbxtxt from QADBXREF ' +                                   
                               'where  dbxtyp =' + Q + 'S' + Q ;                                    
                                                                                                    
                     openList();                                                                    
                     dow fetchNext();                                                               
                      //Check Object & Get Object Description                                       
                      exsr $QUSRMBRD;                                                               
                      if not %error;                                                                
                       exsr $LoadSFL;                                                               
                      endif;                                                                        
                     enddo;                                                                         
                                                                                                    
                     closeList();                                                                   
                                                                                                    
                     if rrn1 <= *zeros;                                                             
                      *in51 = *off;                                                                 
                     endif;                                                                         
                     *in89 = *on;                                                                   
                                                                                                    
                    endsr;                                                                          
                                                                                                    
      /end-free                                                                                     
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
      * $QUSRMBRD - API Retreive Member Description                                                 
      *-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
     C     $QUSRMBRD     begsr                                                                      
      *                                                                                             
     C                   eval      SrcDBXLIB   = qDBXFIL + qDBXLIB                                  
     C                   eval      nBufLen = %size(MbrD0100)                                        
      *                                                                                             
     C                   call(e)   'QUSRMBRD'                                                       
     C                   parm                    MbrD0100                                           
     C                   parm                    nBufLen                                            
     C                   parm                    Fmt                                                
     C                   parm                    SrcDBXLIB                                          
     C                   parm                    MemberName                                         
     C                   parm                    bOvr                                               
      *                                                                                             
     C                   endsr                                                                      
      *--------------------------------------------------------                                     
      *  openList  - Open a cursor to read file                                                     
      *--------------------------------------------------------                                     
     p openList        b                                                                            
                                                                                                    
     d openList        pi                                                                           
                                                                                                    
     c/exec sql                                                                                     
     c+ declare MyCursor cursor                                                                     
     c+    for statement                                                                            
     c/end-exec                                                                                     
     c/exec sql                                                                                     
     c+ prepare statement from :sqlstmt                                                             
     c/end-exec                                                                                     
     c/exec sql                                                                                     
     c+ open mycursor                                                                               
     c/end-exec                                                                                     
                                                                                                    
     p openList        e                                                                            
                                                                                                    
      *--------------------------------------------------------                                     
      *  fetchNext  - read one record at a time                                                     
      *--------------------------------------------------------                                     
     p fetchNext       b                                                                            
                                                                                                    
     d fetchNext       pi              n                                                            
                                                                                                    
     c/exec sql                                                                                     
     c+ fetch next from mycursor                                                                    
     c+    into :sqldata                                                                            
     c/end-exec                                                                                     
      /free                                                                                         
         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                                                                           
                                                                                                    
     c/exec sql                                                                                     
     c+ close MyCursor                                                                              
     c/end-exec                                                                                     
                                                                                                    
     p closeList       e                                                                            
      *--------------------------------------------------------                                     

Here is another version of the convert to pdf
It belong to Giuseppe Costagliola 2005 - beppecosta@yahoo.it
it supportsa multiple fonts and multiple page widths... way cool!
2 things to remember compile the physical file CPYSPOOL in library QGPL or change the hardcoding....
and also compile it with multiple members *NOMAX...
added a save file at version V5R3 for ease ...else download and use the text files


Sample from Giuseppe Costagliola posted at 2011-12-17 07:44:28

     H Dftactgrp(*NO) BNDDIR('QC2LE') debug
     H COPYRIGHT  ('Giuseppe Costagliola 2005 - beppecosta@yahoo.it')

      //-------------------------------------------------------------------
      // Spool file
      //-------------------------------------------------------------------
     FCPYSPOOL  IF   E             DISK    EXTMBR(pMEMBER) USROPN

      //-------------------------------------------------------------------
      // Cmd Parameters
      //-------------------------------------------------------------------
     DEntryParms       PR                  extpgm('SCS2PDFR')
     D pFILE                         10A
     D pMEMBER                       10A
     D pRCDLEN                        9B 0
     D pOVRFLW                        9B 0
     D pTOPDF                       100A
     D pBASEFONT                     21A
     D pPAGESIZE                     13A
     D pPAGEWIDTH                     4P 0
     D pPAGEHEIGHT                    4P 0
     D pPOINTSIZE                     2P 0
     D pVERTSPACE                     2P 0
     D pCOLS                          4P 0
     D pLEFTMARGIN                    3P 0
     D pTOPMARGIN                     3P 0
     D pORIENT                       10A
     DEntryParms       PI
     D pFILE                         10A
     D pMEMBER                       10A
     D pRCDLEN                        9B 0
     D pOVRFLW                        9B 0
     D pTOPDF                       100A
     D pBASEFONT                     21A
     D pPAGESIZE                     13A
     D pPAGEWIDTH                     4P 0
     D pPAGEHEIGHT                    4P 0
     D pPOINTSIZE                     2P 0
     D pVERTSPACE                     2P 0
     D pCOLS                          4P 0
     D pLEFTMARGIN                    3P 0
     D pTOPMARGIN                     3P 0
     D pORIENT                       10A

     DQUSEC            DS
      * Qus EC
     D QUSBPRV                 1      4B 0
      * Bytes Provided
     D QUSBAVL                 5      8B 0
      * Bytes Available
     D QUSEI                   9     15
      * Exception Id
     D QUSERVED               16     16
      * Varying length
      *
     DQUSC0200         DS
      * Qus ERRC0200
     D QUSK01                  1      4B 0
      * Key
     D QUSBPRV00               5      8B 0
      * Bytes Provided
     D QUSBAVL14               9     12B 0
      * Bytes Available
     D QUSEI00                13     19
      * Exception Id
     D QUSERVED39             20     20
      * Reserved
     D  QUSCCSID11            21     24B 0
      * CCSID
     D QUSOED01               25     28B 0
      * Offset Exc Data
     D QUSLED01               29     32B 0
     DQUSED01                        60

      // Stream file APIs --------------------------------------------------.
     Dunlink           PR             9B 0 EXTPROC('unlink')
     D                                 *   VALUE
     Dopen             PR            10I 0 EXTPROC('open')
     D                                 *   VALUE
     D                               10I 0 VALUE
     D                               10U 0 VALUE OPTIONS(*NOPASS)
     D                               10U 0 VALUE OPTIONS(*NOPASS)
     D O_CREAT         S             10I 0 INZ(8)
     D O_WRONLY        S             10I 0 INZ(2)
     D O_TRUNC         S             10I 0 INZ(64)
     D O_CODEPAGE      S             10I 0 INZ(8388608)
     D S_IRWXU         S             10I 0 INZ(448)
     D S_IROTH         S             10I 0 INZ(4)
     Dwrite            PR            10I 0 EXTPROC('write')
     D                               10I 0 VALUE
     D                                 *   VALUE
     D                               10I 0 VALUE
     Dclose            PR            10I 0 EXTPROC('close')
     D                               10I 0 VALUE
      //
     Dfd               S             10I 0

      // Local procedures --------------------------------------------------
     DSetupPage        PR
     DCrtPDFstmf       PR
     D pTOPDF                       100A   VALUE

     DWriteHeader      PR
     D Title                        100A   VALUE

     DWritePages       PR

     DWritePagesTree   PR

     DWriteXRef        PR

     DWriteTrailer     PR

     DStartPage        PR            10I 0

     DEndPage          PR
     D StreamStart                   10I 0

     DWriteData        PR
     D Buffer                      1024A   VALUE
     D Len                           10I 0 VALUE

     DClosePDFstmf     PR

     DInzTblAscii      PR           256

     DGetErrInfo       PR           128

     DSndPgmMsg        PR
     D type                          10A   CONST
     D function                      20A   CONST
     D msgId                          7A   CONST
     D msg                          128A   CONST


      // Conversion table --------------------------------------------------
     DTblAscii         s            256

      // Misc variables ----------------------------------------------------
     DLF               C                   x'25'

      // PDF Variables -----------------------------------------------------
     DPageNo           S              5I 0 INZ(0)
     DPageObject       S              5I 0 DIM(500)
     DxObject          S              5I 0 INZ(5)
     DxOffset          S             10U 0 INZ(0)
     DxRef             S             10I 0 INZ(0)
     DLocations        S             10I 0 DIM(1000)

     DPointSize        S              5I 0 INZ(0)
     DVertSpace        S              5I 0 INZ(0)
     DCols             S              5I 0 INZ(0)
     DLeftMargin       S              5I 0 INZ(0)
     DTopMargin        S              5I 0 INZ(0)

     DPageWidth        S              5I 0 INZ(0)
     DPageHeight       S              5I 0 INZ(0)


     DDefaultFont      C                   'Courier'
     DFont             S             20A

      // Program status ----------------------------------------------------
     DPgmSts          SDS                  NoOpt
     D JobNbr                         6a   Overlay(PgmSts:264)

      //********************************************************************
      // MAIN
      //********************************************************************

      /free

       // Setup page
       SetupPage ();

       // Create the PDF stream file
       CrtPDFstmf (pTOPDF);

       // Initialize conversion table
       TblAscii = InzTblAscii();

       // Write document
       WriteHeader(pFILE);
       WritePages();
       WritePagesTree();
       WriteXRef();
       WriteTrailer();

       // close stream file
       ClosePDFstmf ();

       *inlr = *on;
       return;

      /end-free

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Set Page
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PSetupPage        B
     DSetupPage        PI
      /free

       if pPAGESIZE = '*AUTO';
         select;
           when pRCDLEN <= 80;
             pPAGESIZE = '*PORTRAIT80';
           when pRCDLEN <= 132;
             pPAGESIZE = '*LANDSCAPE132';
           other;
             pPAGESIZE = '*LANDSCAPE198';
         endsl;
       endif;

       select;
         when pPAGESIZE = '*PORTRAIT80';
           PageWidth  = 595;
           PageHeight = 842;
           PointSize  = 12;
           VertSpace  = 12;
           Cols       = 80;
           LeftMargin = 30;
           TopMargin  = 30;
         when pPAGESIZE = '*PORTRAIT132';
           PageWidth  = 595;
           PageHeight = 842;
           PointSize  = 7;
           VertSpace  = 11;
           Cols       = 132;
           LeftMargin = 35;
           TopMargin  = 50;
         when pPAGESIZE = '*LANDSCAPE132';
           PageWidth  = 842;
           PageHeight = 595;
           PointSize  = 10;
           VertSpace  = 9;
           Cols       = 132;
           LeftMargin = 20;
           TopMargin  = 20;
         when pPAGESIZE = '*LANDSCAPE198';
           PageWidth  = 842;
           PageHeight = 595;
           PointSize  = 7;
           VertSpace  = 9;
           Cols       = 198;
           LeftMargin = 5;
           TopMargin  = 10;
         when pPAGESIZE = '*USRDFN';
           PageWidth  = pPAGEWIDTH;
           PageHeight = pPAGEHEIGHT;
           PointSize  = pPOINTSIZE;
           VertSpace  = pVERTSPACE;
           if pCols = -1;
             Cols = pRCDLEN;
           else;
             Cols     = pCOLS;
           endif;
           LeftMargin = pLEFTMARGIN;
           TopMargin  = pTOPMARGIN;
         endsl;

       if pOrient = '*LANDSCAPE';
           PageWidth  = pPageHeight;
           PageHeight = pPageWidth;
       endif;

      /end-free
     PSetupPage        E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Create an empty PDF stream file
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PCrtPDFstmf       B
     DCrtPDFstmf       PI
     D pTOPDF                       100A   VALUE

     DFileName         S            101A
     DErrMsg           S            128A

      /free

       FileName = %TRIM(pTOPDF) + X'00';

       // Check whether stream file exists or not.
       fd = open(%Addr(FileName) : 1);

       // If Stream file exists, then unlink the stream file
       If fd <> -1;
         If close(fd) = -1;
           ErrMsg = 'close() failed. ' + geterrinfo;
         EndIf;
         If unlink(%Addr(Filename)) = -1;
           ErrMsg = 'unlink() failed. ' + geterrinfo;
         Endif;
       EndIf;

       // if errors exit
       if ErrMsg <> ' ';
         SndPgmMsg ('*ESCAPE':'CrtPDFstmf': ' ' : ErrMsg);
       Endif;

       // Open(Create) stream file
       fd = open(%Addr(Filename)
            : O_CREAT + O_WRONLY + O_TRUNC + O_CODEPAGE
            : S_IRWXU + S_IROTH : 819);
       If fd = -1;
         ErrMsg = 'open() failed. ' + geterrinfo;
       EndIf;

       // if errors exit
       if ErrMsg <> ' ';
         SndPgmMsg ('*ESCAPE':'CrtPDFstmt': ' ' : ErrMsg);
       Endif;

      /end-free

     PCrtPDFstmf       E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Write data
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PWriteData        B
     DWriteData        PI
     D Buffer                      1024A   VALUE
     D Len                           10I 0 VALUE

      // xlateb MI
     Dxlateb           PR                  EXTPROC('_XLATEB')
     D                                 *   VALUE
     D                                 *   VALUE
     D                               10U 0 VALUE

     DBytesW           S             10I 0
     DErrMsg           S            128A

      /free

       // convert to ascii
       xlateb (%addr(Buffer):%addr(TblAscii):Len);

       // write data to stream file
       BytesW = write(fd:%addr(Buffer):Len);
       If BytesW <> Len;
         ErrMsg = 'write() failed. ' + geterrinfo;
       Endif;

       // increase final position
       xOffset += BytesW;

      /end-free

     PWriteData        E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Write header
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PWriteHeader      B
     DWriteHeader      PI
     D Title                        100A   VALUE

     D CreationDate    S             14A
     D Element         S            128A

      /free

       // declare PDF version and some "HiBit" stuff
       WriteData('%PDF-1.1'+LF:9);
       WriteData('%' + x'424677ee'+LF:6);

       // document info
       Locations(1) = xOffset;
       WriteData('1 0 obj'+LF:8);
       WriteData('<<'+LF:3);
       CreationDate = %char(%date():*ISO0)+%char(%time():*HMS0);
       WriteData('/CreationDate (D:' + CreationDate + ')'+ LF:33);
       WriteData('/Producer (SCS2PDF v1.0 (251 BeppeCosta, 2005))'+LF:49);
       Element = '/Title (' + %trim(Title) + ')' + LF;
       WriteData(Element:%len(%trimr(Element)));
       WriteData('>>'+LF:3);
       WriteData('endobj'+LF:7);

       // root node
       Locations(2) = xOffset;
       WriteData('2 0 obj'+LF:8);
       WriteData('<<'+LF:3);
       WriteData('/Type /Catalog'+LF:15);
       WriteData('/Pages 3 0 R'+LF:13);
       WriteData('>>'+LF:3);
       WriteData('endobj'+LF:7);

       // font
       Locations(4) = xOffset;
       WriteData('4 0 obj'+LF:8);
       WriteData('<<'+LF:3);
       WriteData('/Type /Font'+LF:12);
       WriteData('/Subtype /Type1'+LF:16);
       WriteData('/Name /F1'+LF:10);
       if pBASEFONT = '*DFT';
         Font = DefaultFont;
       else;
         Font = pBASEFONT;
       endif;
       Element = '/BaseFont /' + %trim(Font) + LF;
       WriteData(Element:%len(%trimr(Element)));
       WriteData('/Encoding /WinAnsiEncoding'+LF:27);
       WriteData('>>'+LF:3);
       WriteData('endobj'+LF:7);

       // page list
       Locations(5) = xOffset;
       WriteData('5 0 obj'+LF:8);
       WriteData('<<'+LF:3);
       WriteData('  /Font << /F1 4 0 R >>'+LF:24);
       WriteData('  /ProcSet [ /PDF /Text ]'+LF:26);
       WriteData('>>'+LF:3);
       WriteData('endobj'+LF:7);

      /end-free
     PWriteHeader      E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Write pages
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PWritePages       B
     DWritePages       PI

     D Element         S            128A

     D BeginStream     S             10I 0

     D c               S              5I 0
     D r               S              5I 0
     D s               S              5I 0
     D Parentheses     C                   '()'
     D PdfText         S            256A

      /free

       open CPYSPOOL;

       dow not %eof(CPYSPOOL);
         // open a new page
         beginstream = StartPage();
         // read a spool line
         read CPYSPOOL;
         dow not %eof(CPYSPOOL);
           WriteData('(':1);
           PdfText = LINE;
           // escape parentheses
           for c = 1 to %len(Parentheses);
             r = 0;
             s = 1;
             dou s = 0;
               s = %scan(%subst(Parentheses:c:1):%subst(PdfText:r+1));
               if s > 0;
                 r += s;
                 PdfText = %replace('':PdfText:r:0);
                 r += 1;
               endif;
             enddo;
           endfor;
           // write spool line
           WriteData(%trimr(PdfText):%len(%trimr(PdfText)));
           WriteData(')'''+LF:3);
           // read next line
           read CPYSPOOL;
           if not %eof(CPYSPOOL);
             // handle FCFC instruction
             select;
               when FCFC = '1';
                 EndPage(beginstream);
                 beginstream = StartPage();
               when FCFC = '0';
                WriteData('()'''+LF:4);
               when FCFC = '-';
                WriteData('()'''+LF:4);
                WriteData('()'''+LF:4);
             endsl;
           endif;
         enddo;
         // close page
         EndPage(beginstream);
       enddo;

       close CPYSPOOL;

      /end-free
     PWritePages       E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Start page
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PStartPage        B
     DStartPage        PI            10I 0

     D strmPos         S             10I 0
     D Element         S            128A

      /free

       // page
       xObject += 1;
       Locations(xObject) = xOffset;
       pageNo += 1;
       PageObject(pageNo) = xObject;
       Element = %char(xObject) + ' 0 obj' + LF;
       WriteData(Element:%len(%trimr(Element)));
       WriteData('<<'+LF:3);
       WriteData('/Type /Page'+LF:12);
       WriteData('/Parent 3 0 R'+LF:14);
       WriteData('/Resources 5 0 R'+LF:17);
       xObject += 1;
       Element = '/Contents ' + %char(xObject) + ' 0 R' + LF;
       WriteData(Element:%len(%trimr(Element)));
       WriteData('>>'+LF:3);
       WriteData('endobj'+LF:7);

       Locations(xObject) = xOffset;
       Element = %char(xObject) + ' 0 obj' + LF;
       WriteData(Element:%len(%trimr(Element)));

       WriteData('<<'+LF:3);
       Element = '/Length ' + %char(xObject + 1) + ' 0 R' + LF;
       WriteData(Element:%len(%trimr(Element)));

       WriteData('>>'+LF:3);
       WriteData('stream'+LF:7);
       strmPos = xOffset;

       // BT begin a text block
       WriteData('BT'+LF:3);

       // set working font
       Element = '/F1 ' + %char(pointSize) + ' Tf' + LF;
       WriteData(Element:%len(%trimr(Element)));

       // set margins (x,y)
       Element = '1 0 0 1 ' + %char(leftMargin) +
                ' ' + %char(pageHeight - topMargin) + ' Tm' + LF;
       WriteData(Element:%len(%trimr(Element)));

       // set vertical space
       Element = %char(vertSpace) + ' TL' + LF;
       WriteData(Element:%len(%trimr(Element)));

       return strmPos;

      /end-free
     PStartPage        E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // End page
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PEndPage          B
     DEndPage          PI
     D StreamStart                   10I 0

     D Element         S            128A
     D StreamEnd       S             10I 0
      /free

         // ET ends the text block
         WriteData('ET'+LF:3);
         streamEnd = xOffset;
         WriteData('endstream'+LF:10);
         WriteData('endobj'+LF:7);

         xObject += 1;
         Locations(xObject) = xOffset;

         Element = %char(xObject) + ' 0 obj' + LF;
         WriteData(Element:%len(%trimr(Element)));

         Element = %char(StreamEnd - streamStart) + LF;
         WriteData(Element:%len(%trimr(Element)));

         WriteData('endobj'+LF:7);

      /end-free
     PEndPage          E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Write pages tree
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PWritePagesTree   B
     DWritePagesTree   PI

     D i               S              5I 0

     D Element         S            128A

      /free

       Locations(3) = xOffset;
       WriteData('3 0 obj'+LF:8);
       WriteData('<<'+LF:3);
       WriteData('/Type /Pages'+LF:13);

       // define page count
       Element = '/Count ' + %char(pageNo) + LF;
       WriteData(Element:%len(%trimr(Element)));

       // define papersize
       Element = '/MediaBox [ 0 0 ' + %char(pageWidth) +
                ' ' + %char(pageHeight) + ' ]' +LF;
       WriteData(Element:%len(%trimr(Element)));

       // define object reference to each page
       WriteData('/Kids [':7);
       for i = 1 to pageNo;
         if %rem(i:10) = 0;
           WriteData(LF:1);
         endif;
         Element = ' ' + %char(PageObject(i)) + ' 0 R';
         WriteData(Element:%len(%trimr(Element)));
       endfor;

       WriteData(' ]'+LF:3);
       WriteData('>>'+LF:3);
       WriteData('endobj'+LF:7);

      /end-free
     PWritePagesTree   E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Write xRef
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PWriteXRef        B
     DWriteXRef        PI

     D i               S              5I 0

     D Element         S            128A

      /free

       // write xRef table
       xRef = xOffset;
       WriteData('xref'+LF:5);

       // ... number of entries
       Element = '0 ' + %char(xObject + 1) + LF;
       WriteData(Element:%len(%trimr(Element)));

       // ... free entry - head of linked list
       Element = '0000000000 65535 f ' + LF;
       WriteData(Element:%len(%trimr(Element)));

       // ... xRef entries
       for i = 1 to xObject;
         Element = %trim(%editc(%dec(Locations(i):10:0):'X')) +
                  ' 00000 n ' + LF;
         WriteData(Element:%len(%trimr(Element)));
       endfor;

      /end-free
     PWriteXRef        E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Write trailer
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PWriteTrailer     B
     DWriteTrailer     PI

     D Element         S            128A

      /free

       WriteData('trailer'+LF:8);
       WriteData('<<'+LF:3);

       // total number of entries in xRef
       Element = '/Size ' + %char(xObject + 1) + LF;
       WriteData(Element:%len(%trimr(Element)));
       WriteData('/Root 2 0 R'+LF:12);     // reference to Catalog
       WriteData('/Info 1 0 R'+LF:12);     // reference to Info dictionary
       WriteData('>>'+LF:3);

       // offset of xRef
       WriteData('startxref'+LF:10);
       Element = %char(xRef) + LF;
       WriteData(Element:%len(%trimr(Element)));

       // final
       WriteData('%%EOF'+LF:5);

      /end-free
     PWriteTrailer     E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Close PDF stream file
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PClosePDFstmf     B
     DClosePDFstmf     PI
     DErrMsg           S            128A

      /free
       If close(fd) = -1;
         ErrMsg = 'close() failed. ' + geterrinfo;
         SndPgmMsg ('*ESCAPE':'CloPDFstmt': ' ' : ErrMsg);
       EndIf;
      /end-free

     PClosePDFstmf     E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Initialize Table Ebcdic -> Ascii
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PInzTblAscii      B
     DInzTblAscii      PI           256A

      // Convert a Graphic Character String API
     DCDRCVRT          PR                  extpgm('CDRCVRT')
     D CCSID1                        10I 0 CONST
     D ST1                           10I 0 CONST
     D S1                           256    CONST
     D L1                            10I 0 CONST
     D CCSID2                        10I 0 CONST
     D ST2                           10I 0 CONST
     D GCCASN                        10I 0 CONST
     D L2                            10I 0 CONST
     D S2                           256
     D L3                            10I 0
     D L4                            10I 0
     D FB                            12

     DQUSRJOBI         PR                  extpgm('QUSRJOBI')
     D jobi0400                    1024    OPTIONS(*VARSIZE)
     D jobiBytes                      9B 0 CONST
     D jobiFormat                    10    CONST
     D jobiJobName                   26    CONST
     D jobiJobInt                    16    CONST
     D ApiError                     120    OPTIONS(*VARSIZE)
     D jobi0400        DS
     D  CCSID                         9B 0 overlay(jobi0400:373)

      // conversion tables and CDRCVRT rtn flds
     DTblAscii         s            256    inz(*allx'ff')
     DTblEbcdic        s            256    inz(*allx'ff')
     DL3               s             10i 0
     DL4               s             10i 0
     DFB               s             12

      // conversion binary - hex
     dxValue           ds
     d bValue                         3U 0

      /free
        // get CCSID
        QUSRJOBI (jobi0400:%len(jobi0400):'JOBI0400':'*':' ':QUSEC);
        // create a conversion table
        for bValue = 0 to 254;
          %subst(TblEbcdic:bValue+1:1) = xValue;
        endfor;
        // create table
        CDRCVRT (CCSID:0:TblEbcdic:256:819:0:0:256:TblAscii:L3:L4:FB);
        // return table
        return TblAscii;
      /end-free

     PInzTblAscii      E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Get C error data
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     Pgeterrinfo       B
     Dgeterrinfo       PI           128
     Dgeterrno         PR              *   EXTPROC('__errno')
     Dstrerror         PR              *   EXTPROC('strerror')
     D errno                         10I 0 VALUE
     Derrnum           S             10I 0 BASED(errnum_p)
      /free
       errnum_p = geterrno;
       Return %TRIM(%EDITC(errnum : '3')) + ' : ' +
           %STR(strerror(errnum));
      /end-free
     Pgeterrinfo       E

      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      // Send Program Message
      //++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     PSndPgmMsg        B
     DSndPgmMsg        PI
     D msgType                       10A   CONST
     D function                      20A   CONST
     D msgId                          7A   CONST
     D msgErr                       128A   CONST

     D QMHSNDPM        PR                  extpgm('QMHSNDPM')
     D  MessageId                     7    CONST
     D  MessageFile                  20    CONST
     D  MessageData                 512    CONST options(*varsize)
     D  MessageDataL                  9b 0 CONST
     D  MessageType                  10    CONST
     D  CallStkEntry                128    CONST options(*varsize)
     D  CallStkCount                  9b 0 CONST
     D  MessageKey                    4    CONST
     D  ApiError                    120    options(*varsize)

     D idMsg           S              7A
     D errMsg          S            128A

      /free

       if msgId <> ' ';
         idMsg  = msgId;
         errMsg = msgErr;
       else;
         if msgType = '*ESCAPE';
           idMsg  = 'CPF9898';
           errMsg = 'Error ' + %trimr(function) + ' : ' + msgErr;
         else;
           errMsg = msgErr;
         endif;
       endif;

       QMHSNDPM (idMsg: 'QCPFMSG   QSYS' : errMsg : %len(errMsg) :
                 msgType : '*CTLBDY' : 1 : ' ' : QUSEC);

      /end-free
     PSndPgmMsg        E


Retrieve save-file saved date and time


Sample from Jamie Flanary posted at 2011-12-11 18:31:50

      *********************************************************** 
      * Prototype for QUSCRTUS - Create User Space              * 
      *********************************************************** 
     D QUSCRTUS        PR                  ExtPgm('QUSCRTUS') 
     D   UserSpace                   20a   const 
     D   Attrib                      10a   const 
     D   InitSize                    10i 0 const 
     D   InitVal                      1A   const 
     D   PubAuth                     10a   const 
     D   Text                        50a   const 
      * optional group 1: 
     D   Replace                     10a   const options(*nopass) 
     D   ErrorCode                         like(MyErrCode) 
     D                                     options(*varsize: *nopass) 
      * optional group 2: 
     D   Domain                      10a   const options(*nopass) 
      * optional group 3: 
     D   XferSizeReq                 10i 0 const options(*nopass) 
     D   OptAlign                     1A   const options(*nopass) 

      *********************************************************** 
      * Prototype for QSRLSAVF - List Save File                 * 
      *********************************************************** 
     D QSRLSAVF        PR                  ExtPgm('QSRLSAVF') 
     D   UserSpace                   20a   const 
     D   Format                       8a   const 
     D   SaveFile                    20a   const 
     D   NameFilter                  10a   const 
     D   TypeFilter                  10a   const 
     D   ContHandle                  36a   const 
     D   ErrorCode                         like(MyErrCode) 
     D                                     options(*varsize: *nopass) 

      *********************************************************** 
      * Prototype for QUSPTRUS - Retrieve Pointer to User Space * 
      *********************************************************** 
     D QUSPTRUS        PR                  ExtPgm('QUSPTRUS') 
     D   UserSpace                   20a   const 
     D   Format                        * 
     D   ErrorCode                         like(MyErrCode) 
     D                                     options(*varsize: *nopass) 

      *********************************************************** 
      * Prototype for QUSRTVUS - Retrieve User Space            * 
      *********************************************************** 
     D QUSRTVUS        PR                  ExtPgm('QUSRTVUS') 
     D   UserSpace                   20a   const 
     D   StartPos                    10i 0 const 
     D   Length                      10i 0 const 
     D   UsrSpcData                 203a   const 
     D   ErrorCode                         like(MyErrCode) 
     D                                     options(*varsize: *nopass) 

      *********************************************************** 
      * Prototype for QWCCVTDT - Convert Date and Time Format   * 
      *********************************************************** 
     D QWCCVTDT        PR                  ExtPgm( 'QWCCVTDT' ) 
     D  CvtInputFmt                  10 
     D  CvtInputDate                 17 
     D  CvtOutputFmt                 10 
     D  CvtOutputDate                17 
     D   ErrorCode                         like(MyErrCode) 
     D                                     options(*varsize: *nopass) 

     D  InputFmt       S             10 
     D  InputDate      S             17 
     D  OutputFmt      S             10 
     D  OutputDate     S             17 

      *********************************************************** 
      * API error code data structure                           * 
      *********************************************************** 
     D MyErrCode       DS 
     D  BytesProv                    10i 0 inz(%size(MyErrCode)) 
     D  BytesAvail                   10i 0 inz(0) 
     D  MsgID                         7a 
     D  Reserved                      1a 
     D  MessageData                 512a 

      *********************************************************** 
      * Header Definition                                       * 
      *********************************************************** 
     dListHdr          DS                  based(HdrPtr) 
     d                              124a 
     d OffLstEnt                     10i 0 
     d SizDtaSec                     10i 0 
     d NbrLstEnt                     10i 0 
     d SizLstEnt                     10i 0 

     d UsrSpc          S             20a   inz('USRSPC    QTEMP     ') 
     d ErrCod          S             10i 0 inz(0) 

     d Savf            DS               
     d  SavfName                     10a   inz('MySAVF')  
     d  SavfLib                      10a   inz('MyLib')  

     d SAVF0100        DS                  based(ListPtr) 
     d                                     qualified 
     d  LibName                      10a 
     d  SavCmd                       10a 
     d  SavDT                         8a 
     d  SavASP                       10i 0 
     d  Rcds                         10i 0 
     d  SavObj                       10i 0 
     d  SavAcp                       10i 0 
     d  SavAct                       10a 
     d  RlsLvl                        6a 
     d  DtaCpd                        1a 
     d  SysSRLn                       8a 
     d  PrvAut                        1a 
     d                                2a 
     d  ASPDevNm                     10a 
     d                                2a 
     d  MbrLibSav                    10i 0 
     d  SplFilSav                    10i 0 
     d  SyncID                       10a 

     d SAVF0200        DS                  based(ListPtr) 
     d                                     qualified 
     d  ObjName                      10a 
     d  LibName                      10a 
     d  ObjType                      10a 
     d  ObjAttr                      10a 
     d  SavDate                       8a 
     d  ObjSize                      10i 0 
     d  ObjSzMl                      10i 0 
     d  StgPool                      10i 0 
     d  DatSave                       1a 
     d  ObjOwnr                      10a 
     d  DloName                      20a 
     d  FdrName                      63a 
     d  Descrip                      50a 
     d  DevName                      10a 

      *********************************************************** 
      * Work Fields                                             * 
      *********************************************************** 
     d FmtName         S              8a   inz('SAVF0100') 
     d UsSize          S             10i 0 
     d Handle          S             36a 
     d EntryNo         S             10i 0 

      *********************************************************** 
      * Create User Space for API Usage                         * 
      *********************************************************** 
     c                   if        FmtName = 'SAVF0100' 
     c                   eval      UsSize = %size(SAVF0100) * 1024 
     c                   else 
     c                   eval      UsSize = %size(SAVF0200) * 1024 
     c                   endif 

     c                   callp     QUSCRTUS( UsrSpc 
     c                                     : ' ' 
     c                                     : %size(UsSize) 
     c                                     : x'00' 
     c                                     : '*USE' 
     c                                     : 'Save File Information' 
     c                                     : '*YES' 
     c                                     : MyErrCode) 

      *********************************************************** 
      * List Save File Details                                  * 
      *********************************************************** 
     c                   callp     QSRLSAVF( UsrSpc 
     c                                     : FmtName 
     c                                     : Savf 
     c                                     : '*ALL' 
     c                                     : '*ALL' 
     c                                     : Handle 
     c                                     : MyErrCode ) 

      *********************************************************** 
      * Retrieve Pointer to User Space                          * 
      *********************************************************** 
     c                   callp     QUSPTRUS( UsrSpc 
     c                                     : HdrPtr 
     c                                     : MyErrCode) 

     c                   for       EntryNo = 0 to (NbrLstEnt - 1) 
     c                   eval      ListPtr = HdrPtr + OffLstEnt + 
     c                                (SizLstEnt * EntryNo) 
      **** DO STUFF HERE 

     c                   if        FmtName = 'SAVF0100' 
      * All the SAVF0100 stuff is in the qualified SAVF0100 DS 
     c                   Eval      InputFmt   =  '*DTS' 
     c                   Eval      InputDate  =  SAVF0100.SavDT 
     c                   Eval      OutputFmt  =  '*YYMD' 

     c                   Callp     QWCCVTDT (InputFmt  : 
     c                                       InputDate : 
     c                                       OutputFmt : 
     c                                       OutputDate: 
     c                                       MyErrCode ) 

     c                   dsply                   OutPutDate 
     c                   else 
      * All the SAVF0200 stuff is in the qualified SAVF0200 DS 
      *                  ...  
     c                   endif 

     c                   endfor 

     c                   seton                                        lr 
     c                   return  

Create IFS table (xml) of command defaults.


Sample from Jamie Flanary posted at 2011-12-11 18:26:36

pgm

   dcl  &cmd      *char     20
   dcl  &destinfo *char     64
   dcl  &destfmt  *char      8  value('DEST0200')
   dcl  &rcvvar   *char      1
   dcl  &rcvfmt   *char      8  value('CMDD0100')
   dcl  &error    *char     16  value(x'00000000')
   dcl  &null2    *char      2  value(x'0000')
   dcl  &null3    *char      3  value(x'000000')
   dcl  &null10   *char     10  value(x'00000000000000000000')

   chgvar  &cmd                  value('GENDDL    *LIBL')
   chgvar  %bin(&destinfo  1  4) value(0)       /* CCSID         */
   chgvar  %sst(&destinfo  5  2) value(&null2)  /* country       */
   chgvar  %sst(&destinfo  7  3) value(&null3)  /* language      */
   chgvar  %sst(&destinfo 10  3) value(&null3)  /* reserved      */
   chgvar  %bin(&destinfo 13  4) value(0)       /* path type     */
   chgvar  %bin(&destinfo 17  4) value(22)      /* path name len */
   chgvar  %sst(&destinfo 21  2) value('/')     /* delimiter     */
   chgvar  %sst(&destinfo 23 10) value(&null10) /* reserved      */
   chgvar  %sst(&destinfo 33 32) value('/home/xxx/xxx.xml')

   call qcdrcmdd (&cmd &destinfo &destfmt +
                  &rcvvar &rcvfmt &error)

endpgm  

Monitor IFS for .CSV table - read and process.


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

     H Option( *SrcStmt: *NoDebugIo )  BndDir( 'QC2LE' ) DFTACTGRP(*No)                             
     ‚**********************************************************************                        
     ‚* Project ID     Date  Pgmr ID  Rev  Description                                              
     ‚*                                                                                             
     ‚*            11/16/11  JJF       00  program written                                          
     ‚*              ** pulls .csv tables from directory:                                           
     ‚*                 /home/Reserve_Adjustments/                                                  
     ‚*                                                                                             
     ‚**********************************************************************                        
      *                                                                                             
      * Directory Entry Structure (dirent)                                                          
      *                                                                                             
     d p_dirent        s               *                                                            
     d dirent          ds                  based(p_dirent)                                          
     d   d_reserv1                   16A                                                            
     d   d_reserv2                   10U 0                                                          
     d   d_fileno                    10U 0                                                          
     d   d_reclen                    10U 0                                                          
     d   d_reserv3                   10I 0                                                          
     d   d_reserv4                    8A                                                            
     d   d_nlsinfo                   12A                                                            
     d     nls_ccsid                 10I 0 OVERLAY(d_nlsinfo:1)                                     
     d     nls_cntry                  2A   OVERLAY(d_nlsinfo:5)                                     
     d     nls_lang                   3A   OVERLAY(d_nlsinfo:7)                                     
     d     nls_reserv                 3A   OVERLAY(d_nlsinfo:10)                                    
     d   d_namelen                   10U 0                                                          
     d   d_name                     640A                                                            
                                                                                                    
      *------------------------------------------------------------                                 
      * Open a Directory                                                                            
      *------------------------------------------------------------                                 
     d opendir         pr              *   EXTPROC('opendir')                                       
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Read Directory Entry                                                                        
      *------------------------------------------------------------                                 
     d readdir         pr              *   EXTPROC('readdir')                                       
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Close Directory                                                                             
      *------------------------------------------------------------                                 
     d closedir        pr              *   EXTPROC('closedir')                                      
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Open IFs table                                                                              
      *------------------------------------------------------------                                 
     d open            pr            10i 0   ExtProc('open')                                        
     d   filename                      *     value                                                  
     d   openflags                   10i 0   value                                                  
     d   mode                        10u 0   value options(*nopass)                                 
     d   codepage                    10u 0   value options(*nopass)                                 
      *------------------------------------------------------------                                 
      * Read IFS table                                                                              
      *------------------------------------------------------------                                 
     d read            pr            10i 0   ExtProc('read')                                        
     d   filehandle                  10i 0   value                                                  
     d   datareceived                  *     value                                                  
     d   nbytes                      10u 0   value                                                  
      *------------------------------------------------------------                                 
      * Close IFs table                                                                             
      *------------------------------------------------------------                                 
     d close           pr            10i 0   ExtProc('close')                                       
     d   filehandle                  10i 0   value                                                  
      *------------------------------------------------------------                                 
      * read ifs table  - internal procedure                                                        
      *------------------------------------------------------------                                 
     d RdIfsFil        pr           256a                                                            
     d  FileName                    256a   const                                                    
      *------------------------------------------------------------                                 
      * Delay - sleep function                                                                      
      *------------------------------------------------------------                                 
     d sleep           pr            10i 0 ExtProc( 'sleep' )                                       
     d  seconds                      10u 0 Value                                                    
      *------------------------------------------------------------                                 
      * Command - run a command                                                                     
      *------------------------------------------------------------                                 
     d $command        pr                  extpgm('QCMDEXC')                                        
     d   command                    256                                                             
     d   length                      15  5                                                          
      *------------------------------------------------------------                                 
      * Grab the date in LongFormat                                                                 
      *------------------------------------------------------------                                 
     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)                                           
      *------------------------------------------------------------                                 
      * a few local variables...                                                                    
                                                                                                    
     d BaseDate        s               d   inz(D'1582-10-14')                                       
     d cmdlength       s             15  5                                                          
     d cmdstring       s            256                                                             
     d count           s              3  0                                                          
     d cr              c                   Const(x'0D')                                             
     d data            s          65535A                                                            
     d Data_Rec        s          65535A                                                            
     d datasize        s              5  0                                                          
     d dh              s               *                                                            
     d Eol             c                   Const(x'0D25')                                           
     d Error_Flag      s              1A   INZ('0')                                                 
     d File            s            256                                                             
     d FileName        s            256    varying                                                  
     d FolderNames     s            256    dim(50)                                                  
     d Fp              s             10i 0                                                          
     d KeepLooping     s               n   inz('1')                                                 
     d lf              C                   Const(x'25')                                             
     d MyNewName       s            265    varying                                                  
     d N               s              5  0                                                          
     d nDays           s             10i 0                                                          
      * values for oflag parameter, used by open()                                                  
     d O_RDONLY        s             10i 0   inz(1)                                                 
     d O_TEXTDATA      s             10i 0   inz(16777216)                                          
                                                                                                    
     d Oflag           s             10i 0                                                          
     d Omode           s             10u 0                                                          
     d PathName        s             26                                                             
     d Q               s              1    inz('''')                                                
     d R               S              5  0                                                          
     d Rc              S             10i 0                                                          
     d ReturnData      s             12                                                             
     d SleepSeconds    s             10i 0 inz(1)                                                   
     d ta              s              3  0                                                          
     d Today           s               d   inz(*SYS)                                                
                                                                                                    
         // entire document stored in here                                                          
     d MyData          ds                  qualified  inz                                           
     d  bighunkdata               65535                                                             
     d   OneSlice                    60    dim(1000) overlay(bighunkdata:*next)                     
      *------------------------------------------------------                                       
      * MAIN LINE                                                                                   
      *------------------------------------------------------                                       
                                                                                                    
      /free                                                                                         
                                                                                                    
                // program will loop until outside force                                            
                // stops it.                                                                        
              dow KeepLooping;                                                                      
                                                                                                    
               exsr $GetFileName;                                                                   
               if ta > *zeros;                                                                      
                // read the tables one at a time                                                    
                for count = 1 to ta;                                                                
                 filename = foldernames(count);                                                     
                 Error_flag = rdifsfil(Filename);                                                   
                 //exsr $MoveToHistory;                                                             
                endfor;                                                                             
               endif;                                                                               
                                                                                                    
               // Delay job for a number of seconds then start                                      
               // the process all over again.                                                       
               sleep(SleepSeconds);                                                                 
                                                                                                    
              enddo;                                                                                
                                                                                                    
           *inlr = *on;                                                                             
                                                                                                    
           //-------------------------------------------                                            
           // $GetFileName - get the next csv table                                                 
           //-------------------------------------------                                            
             begsr $GetFileName;                                                                    
                                                                                                    
               clear filename;                                                                      
                // tables will hold all the names of the tables                                     
               clear TA;                                                                            
               clear folderNames;                                                                   
                                                                                                    
                // loop on the directory                                                            
                // Step1: Open up the directory.                                                    
               PathName = '/home/Reserve_Adjustments/';                                             
               dh = opendir(%addr(PathName));                                                       
               if dh <> *NULL;                                                                      
                                                                                                    
                // Step2: Read each entry from the directory (in a loop)                            
                p_dirent = readdir(dh);                                                             
                                                                                                    
                dow p_dirent <> *NULL;                                                              
                 if d_namelen < 256;                                                                
                  FileName = %subst(d_name:1:d_namelen);                                            
                  // process only csv files                                                         
                  // even MT directory contains folders:                                            
                  // o .                                                                            
                  // o ..                                                                           
                  if %scan('.csv':Filename) > *zeros;                                               
                   ta+=1;                                                                           
                   foldernames(ta) = %trim(pathname) + %trim(filename);                             
                  endif;                                                                            
                 endif;                                                                             
                  p_dirent = readdir(dh);                                                           
                enddo;                                                                              
               endif;                                                                               
                                                                                                    
               // Step3: Close the directory to reprocess                                           
               closedir(dh);                                                                        
                                                                                                    
             endsr;                                                                                 
                                                                                                    
           //-------------------------------------------                                            
           // $MoveToHistory - move processed table to                                              
           //                  history                                                              
           //-------------------------------------------                                            
                                                                                                    
             begsr $MoveToHistory;                                                                  
                                                                                                    
              //  *****  Rename the file  *****                                                     
              // RNM OBJ('/home/Reserve_Adjustments/May Claim Fees.csv')                            
              // NEWOBJ('SomeNewName.csv')                                                          
              // *like: November16_2011_114547.csv                                                  
                                                                                                    
                                                                                                    
                 nDays = %diff(today : baseDate : *days);                                           
                 ceedate(nDays:'Mmmmmmmmmm':ReturnData:*OMIT);                                      
                                                                                                    
                 MyNewName = %trim(ReturnData)  +                                                   
                 %char(%subdt(Today:*days)) + '_' +                                                 
                 %char(%subdt(Today:*years)) + '_' +                                                
                 %ScanRpl('.' : '' :                                                                
                 %char(%time())) + '.csv';                                                          
                                                                                                    
                 cmdstring = 'RNM OBJ(' + Q + %trim(PathName) +                                     
                             %trim(filename) + Q + ')' +                                            
                             ' NEWOBJ(' + Q + %trim(MyNewName) +                                    
                             Q + ')';                                                               
                                                                                                    
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring:cmdlength);                                                    
                 on-error;                                                                          
                  // process for errors                                                             
                 endmon;                                                                            
                                                                                                    
                                                                                                    
              //  *****  Move file to history  *****                                                
              // MOV OBJ('/home/Reserve_Adjustments/May Claim Fees.csv')                            
              //  TODIR('/home/Reserve_Adjustments/history/')                                       
                                                                                                    
                 cmdstring = 'MOV OBJ(' + Q + %trim(PathName) +                                     
                             %trim(MyNewName) + Q + ')' +                                           
                             ' TODIR(' + Q + %trim(PathName) + 'History/' +                         
                             Q + ')';                                                               
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring:cmdlength);                                                    
                 on-error;                                                                          
                  // process for errors                                                             
                 endmon;                                                                            
                                                                                                    
             endsr;                                                                                 
                                                                                                    
           //-------------------------------------------                                            
                                                                                                    
      /end-free                                                                                     
                                                                                                    
      *-------------------------------------------------------------                                
      *    RdIfsFil - Subprocedure To Read The IFS File                                             
      *-------------------------------------------------------------                                
     p RdIfsFil        B                   Export                                                   
     d RdIfsFil        PI           256A                                                            
     d  FileName                    256A   Const                                                    
     d CharsRead       S             10i 0                                                          
     d CurChar         S              1                                                             
     d Eof             C                   const(x'00')                                             
                                                                                                    
      /free                                                                                         
             Oflag = O_Rdonly + O_Textdata;                                                         
             // need whole path here                                                                
             File = %trim(FileName) + x'00';                                                        
             Fp = open(%addr(File): Oflag);                                                         
                                                                                                    
             if  Fp < 0;                                                                            
              Error_Flag = *On;                                                                     
              Return  Error_Flag;                                                                   
             Endif;                                                                                 
                                                                                                    
             R = 0;                                                                                 
             N = 0;                                                                                 
             dou  CurChar = Eof;                                                                    
              exsr getChar;                                                                         
              R+=1;                                                                                 
              %Subst(Data: R: 1) = CurChar;                                                         
                                                                                                    
              if CurChar = X'25';                                                                   
               %Subst(Data: R: 1)  = *blanks;                                                       
              endif;                                                                                
                                                                                                    
              select;                                                                               
               when  R = 256 or CurChar = X'25';                                                    
                                                                                                    
           // if you find the  code then we still have more data in                                 
           // memory  and we need to process that remaining data.                                   
                                                                                                    
                if  CurChar = X'25';                                                                
                 %Subst(Data: R: 1)  = *blanks;                                                     
                endif;                                                                              
                                                                                                    
            // one record is here                                                                   
                clear  R;                                                                           
                clear  Data;                                                                        
                                                                                                    
              endsl;                                                                                
             enddo;                                                                                 
                                                                                                    
             Return    Error_Flag;                                                                  
                                                                                                    
          //---------------------------------------------------------                               
          //  GetChar - Process IFS Record, One Character At A Time                                 
          //---------------------------------------------------------                               
             begsr GetChar;                                                                         
                                                                                                    
               //  If input buffer is empty, or all characters have been                            
               //    processed, refill the input buffer.                                            
              if N = CharsRead;                                                                     
               CharsRead = Read(Fp:%Addr(Data_Rec): 2560);                                          
               N = *Zero;                                                                           
              endif;                                                                                
                                                                                                    
               // Get the next character in the input buffer.                                       
              if CharsRead <= 0;                                                                    
               CurChar = Eof;                                                                       
              else;                                                                                 
               N+=1;                                                                                
               CurChar = %Subst(Data_Rec: N: 1);                                                    
               select;                                                                              
                when  CurChar = *blanks or CurChar = cr  or  CurChar = lf;                          
                 mydata.bighunkdata = %trim(mydata.bighunkdata) + '|';                              
                other;                                                                              
                 mydata.Bighunkdata = %trim(mydata.bighunkdata) +                                   
                 %trim(Curchar);                                                                    
                endsl;                                                                              
              endif;                                                                                
                                                                                                    
             endsr;                                                                                 
                                                                                                    
         //---------------------------------------------------------                                
      /end-free                                                                                     
                                                                                                    
     p RdIfsFil        E                                                                            
     H Option( *SrcStmt: *NoDebugIo )  BndDir( 'QC2LE' ) DFTACTGRP(*No)                             
     ‚**********************************************************************                        
     ‚* Project ID     Date  Pgmr ID  Rev  Description                                              
     ‚*                                                                                             
     ‚*            11/16/11  JJF       00  program written                                          
     ‚*              ** pulls .csv tables from directory:                                           
     ‚*                 /home/Reserve_Adjustments/                                                  
     ‚*                                                                                             
     ‚**********************************************************************                        
      *                                                                                             
      * Directory Entry Structure (dirent)                                                          
      *                                                                                             
     d p_dirent        s               *                                                            
     d dirent          ds                  based(p_dirent)                                          
     d   d_reserv1                   16A                                                            
     d   d_reserv2                   10U 0                                                          
     d   d_fileno                    10U 0                                                          
     d   d_reclen                    10U 0                                                          
     d   d_reserv3                   10I 0                                                          
     d   d_reserv4                    8A                                                            
     d   d_nlsinfo                   12A                                                            
     d     nls_ccsid                 10I 0 OVERLAY(d_nlsinfo:1)                                     
     d     nls_cntry                  2A   OVERLAY(d_nlsinfo:5)                                     
     d     nls_lang                   3A   OVERLAY(d_nlsinfo:7)                                     
     d     nls_reserv                 3A   OVERLAY(d_nlsinfo:10)                                    
     d   d_namelen                   10U 0                                                          
     d   d_name                     640A                                                            
                                                                                                    
      *------------------------------------------------------------                                 
      * Open a Directory                                                                            
      *------------------------------------------------------------                                 
     d opendir         pr              *   EXTPROC('opendir')                                       
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Read Directory Entry                                                                        
      *------------------------------------------------------------                                 
     d readdir         pr              *   EXTPROC('readdir')                                       
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Close Directory                                                                             
      *------------------------------------------------------------                                 
     d closedir        pr              *   EXTPROC('closedir')                                      
     d  dirname                        *   VALUE                                                    
      *------------------------------------------------------------                                 
      * Open IFs table                                                                              
      *------------------------------------------------------------                                 
     d open            pr            10i 0   ExtProc('open')                                        
     d   filename                      *     value                                                  
     d   openflags                   10i 0   value                                                  
     d   mode                        10u 0   value options(*nopass)                                 
     d   codepage                    10u 0   value options(*nopass)                                 
      *------------------------------------------------------------                                 
      * Read IFS table                                                                              
      *------------------------------------------------------------                                 
     d read            pr            10i 0   ExtProc('read')                                        
     d   filehandle                  10i 0   value                                                  
     d   datareceived                  *     value                                                  
     d   nbytes                      10u 0   value                                                  
      *------------------------------------------------------------                                 
      * Close IFs table                                                                             
      *------------------------------------------------------------                                 
     d close           pr            10i 0   ExtProc('close')                                       
     d   filehandle                  10i 0   value                                                  
      *------------------------------------------------------------                                 
      * read ifs table  - internal procedure                                                        
      *------------------------------------------------------------                                 
     d RdIfsFil        pr           256a                                                            
     d  FileName                    256a   const                                                    
      *------------------------------------------------------------                                 
      * Delay - sleep function                                                                      
      *------------------------------------------------------------                                 
     d sleep           pr            10i 0 ExtProc( 'sleep' )                                       
     d  seconds                      10u 0 Value                                                    
      *------------------------------------------------------------                                 
      * Command - run a command                                                                     
      *------------------------------------------------------------                                 
     d $command        pr                  extpgm('QCMDEXC')                                        
     d   command                    256                                                             
     d   length                      15  5                                                          
      *------------------------------------------------------------                                 
      * Grab the date in LongFormat                                                                 
      *------------------------------------------------------------                                 
     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)                                           
      *------------------------------------------------------------                                 
      * a few local variables...                                                                    
                                                                                                    
     d BaseDate        s               d   inz(D'1582-10-14')                                       
     d cmdlength       s             15  5                                                          
     d cmdstring       s            256                                                             
     d count           s              3  0                                                          
     d cr              c                   Const(x'0D')                                             
     d data            s          65535A                                                            
     d Data_Rec        s          65535A                                                            
     d datasize        s              5  0                                                          
     d dh              s               *                                                            
     d Eol             c                   Const(x'0D25')                                           
     d Error_Flag      s              1A   INZ('0')                                                 
     d File            s            256                                                             
     d FileName        s            256    varying                                                  
     d FolderNames     s            256    dim(50)                                                  
     d Fp              s             10i 0                                                          
     d KeepLooping     s               n   inz('1')                                                 
     d lf              C                   Const(x'25')                                             
     d MyNewName       s            265    varying                                                  
     d N               s              5  0                                                          
     d nDays           s             10i 0                                                          
      * values for oflag parameter, used by open()                                                  
     d O_RDONLY        s             10i 0   inz(1)                                                 
     d O_TEXTDATA      s             10i 0   inz(16777216)                                          
                                                                                                    
     d Oflag           s             10i 0                                                          
     d Omode           s             10u 0                                                          
     d PathName        s             26                                                             
     d Q               s              1    inz('''')                                                
     d R               S              5  0                                                          
     d Rc              S             10i 0                                                          
     d ReturnData      s             12                                                             
     d SleepSeconds    s             10i 0 inz(1)                                                   
     d ta              s              3  0                                                          
     d Today           s               d   inz(*SYS)                                                
                                                                                                    
         // entire document stored in here                                                          
     d MyData          ds                  qualified  inz                                           
     d  bighunkdata               65535                                                             
     d   OneSlice                    60    dim(1000) overlay(bighunkdata:*next)                     
      *------------------------------------------------------                                       
      * MAIN LINE                                                                                   
      *------------------------------------------------------                                       
                                                                                                    
      /free                                                                                         
                                                                                                    
                // program will loop until outside force                                            
                // stops it.                                                                        
              dow KeepLooping;                                                                      
                                                                                                    
               exsr $GetFileName;                                                                   
               if ta > *zeros;                                                                      
                // read the tables one at a time                                                    
                for count = 1 to ta;                                                                
                 filename = foldernames(count);                                                     
                 Error_flag = rdifsfil(Filename);                                                   
                 //exsr $MoveToHistory;                                                             
                endfor;                                                                             
               endif;                                                                               
                                                                                                    
               // Delay job for a number of seconds then start                                      
               // the process all over again.                                                       
               sleep(SleepSeconds);                                                                 
                                                                                                    
              enddo;                                                                                
                                                                                                    
           *inlr = *on;                                                                             
                                                                                                    
           //-------------------------------------------                                            
           // $GetFileName - get the next csv table                                                 
           //-------------------------------------------                                            
             begsr $GetFileName;                                                                    
                                                                                                    
               clear filename;                                                                      
                // tables will hold all the names of the tables                                     
               clear TA;                                                                            
               clear folderNames;                                                                   
                                                                                                    
                // loop on the directory                                                            
                // Step1: Open up the directory.                                                    
               PathName = '/home/Reserve_Adjustments/';                                             
               dh = opendir(%addr(PathName));                                                       
               if dh <> *NULL;                                                                      
                                                                                                    
                // Step2: Read each entry from the directory (in a loop)                            
                p_dirent = readdir(dh);                                                             
                                                                                                    
                dow p_dirent <> *NULL;                                                              
                 if d_namelen < 256;                                                                
                  FileName = %subst(d_name:1:d_namelen);                                            
                  // process only csv files                                                         
                  // even MT directory contains folders:                                            
                  // o .                                                                            
                  // o ..                                                                           
                  if %scan('.csv':Filename) > *zeros;                                               
                   ta+=1;                                                                           
                   foldernames(ta) = %trim(pathname) + %trim(filename);                             
                  endif;                                                                            
                 endif;                                                                             
                  p_dirent = readdir(dh);                                                           
                enddo;                                                                              
               endif;                                                                               
                                                                                                    
               // Step3: Close the directory to reprocess                                           
               closedir(dh);                                                                        
                                                                                                    
             endsr;                                                                                 
                                                                                                    
           //-------------------------------------------                                            
           // $MoveToHistory - move processed table to                                              
           //                  history                                                              
           //-------------------------------------------                                            
                                                                                                    
             begsr $MoveToHistory;                                                                  
                                                                                                    
              //  *****  Rename the file  *****                                                     
              // RNM OBJ('/home/Reserve_Adjustments/May Claim Fees.csv')                            
              // NEWOBJ('SomeNewName.csv')                                                          
              // *like: November16_2011_114547.csv                                                  
                                                                                                    
                                                                                                    
                 nDays = %diff(today : baseDate : *days);                                           
                 ceedate(nDays:'Mmmmmmmmmm':ReturnData:*OMIT);                                      
                                                                                                    
                 MyNewName = %trim(ReturnData)  +                                                   
                 %char(%subdt(Today:*days)) + '_' +                                                 
                 %char(%subdt(Today:*years)) + '_' +                                                
                 %ScanRpl('.' : '' :                                                                
                 %char(%time())) + '.csv';                                                          
                                                                                                    
                 cmdstring = 'RNM OBJ(' + Q + %trim(PathName) +                                     
                             %trim(filename) + Q + ')' +                                            
                             ' NEWOBJ(' + Q + %trim(MyNewName) +                                    
                             Q + ')';                                                               
                                                                                                    
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring:cmdlength);                                                    
                 on-error;                                                                          
                  // process for errors                                                             
                 endmon;                                                                            
                                                                                                    
                                                                                                    
              //  *****  Move file to history  *****                                                
              // MOV OBJ('/home/Reserve_Adjustments/May Claim Fees.csv')                            
              //  TODIR('/home/Reserve_Adjustments/history/')                                       
                                                                                                    
                 cmdstring = 'MOV OBJ(' + Q + %trim(PathName) +                                     
                             %trim(MyNewName) + Q + ')' +                                           
                             ' TODIR(' + Q + %trim(PathName) + 'History/' +                         
                             Q + ')';                                                               
                 cmdlength = %len(%trim(cmdstring));                                                
                 monitor;                                                                           
                  $command(cmdstring:cmdlength);                                                    
                 on-error;                                                                          
                  // process for errors                                                             
                 endmon;                                                                            
                                                                                                    
             endsr;                                                                                 
                                                                                                    
           //-------------------------------------------                                            
                                                                                                    
      /end-free                                                                                     
                                                                                                    
      *-------------------------------------------------------------                                
      *    RdIfsFil - Subprocedure To Read The IFS File                                             
      *-------------------------------------------------------------                                
     p RdIfsFil        B                   Export                                                   
     d RdIfsFil        PI           256A                                                            
     d  FileName                    256A   Const                                                    
     d CharsRead       S             10i 0                                                          
     d CurChar         S              1                                                             
     d Eof             C                   const(x'00')                                             
                                                                                                    
      /free                                                                                         
             Oflag = O_Rdonly + O_Textdata;                                                         
             // need whole path here                                                                
             File = %trim(FileName) + x'00';                                                        
             Fp = open(%addr(File): Oflag);                                                         
                                                                                                    
             if  Fp < 0;                                                                            
              Error_Flag = *On;                                                                     
              Return  Error_Flag;                                                                   
             Endif;                                                                                 
                                                                                                    
             R = 0;                                                                                 
             N = 0;                                                                                 
             dou  CurChar = Eof;                                                                    
              exsr getChar;                                                                         
              R+=1;                                                                                 
              %Subst(Data: R: 1) = CurChar;                                                         
                                                                                                    
              if CurChar = X'25';                                                                   
               %Subst(Data: R: 1)  = *blanks;                                                       
              endif;                                                                                
                                                                                                    
              select;                                                                               
               when  R = 256 or CurChar = X'25';                                                    
                                                                                                    
           // if you find the  code then we still have more data in                                 
           // memory  and we need to process that remaining data.                                   
                                                                                                    
                if  CurChar = X'25';                                                                
                 %Subst(Data: R: 1)  = *blanks;                                                     
                endif;                                                                              
                                                                                                    
            // one record is here                                                                   
                clear  R;                                                                           
                clear  Data;                                                                        
                                                                                                    
              endsl;                                                                                
             enddo;                                                                                 
                                                                                                    
             Return    Error_Flag;                                                                  
                                                                                                    
          //---------------------------------------------

Identify jobs in *MSGW


Sample from Jamie Flanary posted at 2011-12-10 10:28:31

      *                                                                                             
      * CrtUsrSpc: Create User Space for OS/400 API's                                               
      *                                                                                             
     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)                               
      *                                                                                             
      * --- Prototype for API Retrive User Space                                                    
      *                                                                                             
     d QUSRTVUS        pr                  extpgm( 'QUSRTVUS' )                                     
     d   QRtvUserSpace...                                                                           
     d                               20                                                             
     d   QRtvStartingPosition...                                                                    
     d                               10i 0                                                          
     d   QRtvLengthOfData...                                                                        
     d                               10i 0                                                          
     d   QRtvReceiverVariable...                                                                    
     d                            32048                                                             
     d   QRtvError...                                                                               
     d                              256                                                             
      * --- Prototype for API Retrive List Job                                                      
      *                                                                                             
     d QUSLJOB         pr                  extpgm( 'QUSLJOB' )                                      
     d   QJobUserSpace...                                                                           
     d                               20                                                             
     d   QJobFormatName...                                                                          
     d                                8                                                             
     d   QJobJobName...                                                                             
     d                               26                                                             
     d   QFldStatus...                                                                              
     d                               10                                                             
     d   QFldError...                                                                               
     d                              256                                                             
     d   QJobType...                                                                                
     d                                1                                                             
     d   QNbrFldRtn...                                                                              
     d                               10i 0                                                          
     d   QKeyFldRtn...                                                                              
     d                               10i 0 dim( 100 )                                               
      *                                                                                             
     d qcmdexc         pr                  extpgm( 'QCMDEXC' )                                      
     d   os400_cmd                 2000A   options( *varsize ) const                                
     d   cmdlength                   15P 5                     const                                
      *                                                                                             
      * Defined variables                                                                           
      *                                                                                             
     d emailaddress    s             24    inz('alert@abcdomain.com')                               
     d size            s             10I 0                                                          
     d UsrSpcName      s             20    inz( 'DSPJOB    QTEMP     ' )                            
      *                                                                                             
      ******************************************************************                            
     dQUSA0100         DS                                                                           
     d QUsrSpcOffset...                                                                             
     d                         1      4B 0                                                          
     d QUsrSpcEntries...                                                                            
     d                         9     12B 0                                                          
     d QUsrSpcEntrieSize...                                                                         
     d                        13     16B 0                                                          
                                                                                                    
     dLJOBINPUT        ds                           qualified                                       
     d  JobName...                                                                                  
     d                         1     10                                                             
     d  UserName...                                                                                 
     d                        11     20                                                             
     d  JobNumber...                                                                                
     d                        21     26                                                             
     d  Status...                                                                                   
     d                        27     36                                                             
     d  UserSpace...                                                                                
     d                        37     46                                                             
     d  UserSpaceLibrary...                                                                         
     d                        47     56                                                             
     d  Format...                                                                                   
     d                        57     64                                                             
     d  JobType...                                                                                  
     d                        65     65                                                             
     d  Reserved01...                                                                               
     d                        66     68                                                             
     d  Reserved02...                                                                               
     d                        69     72B 0                                                          
      *                                                                                             
     dLJOB100          ds                           qualified                                       
     d  JobName...                                                                                  
     d                         1     10                                                             
     d  UserName...                                                                                 
     d                        11     20                                                             
     d  JobNumber...                                                                                
     d                        21     26                                                             
     d  InternalJobId...                                                                            
     d                        27     42                                                             
     d  Status...                                                                                   
     d                        43     52                                                             
     d  JobType...                                                                                  
     d                        53     53                                                             
     d  JobSubType...                                                                               
     d                        54     54                                                             
     d  Reserved01...                                                                               
     d                        55     56                                                             
      *                                                                                             
     dLJOB200          ds                           qualified                                       
     d  JobName...                                                                                  
     d                         1     10                                                             
     d  UserName...                                                                                 
     d                        11     20                                                             
     d  JobNumber...                                                                                
     d                        21     26                                                             
     d  InternalJobId...                                                                            
     d                        27     42                                                             
     d  Status...                                                                                   
     d                        43     52                                                             
     d  JobType...                                                                                  
     d                        53     53                                                             
     d  JobSubType...                                                                               
     d                        54     54                                                             
     d  Reserved01...                                                                               
     d                        55     56                                                             
     d  JobInfoStatus...                                                                            
     d                        57     57                                                             
     d  Reserved02...                                                                               
     d                        58     60                                                             
     d  NumberOfFieldsReturned...                                                                   
     d                        61     64B 0                                                          
     d  ReturnedData...                                                                             
     d                        65   1064                                                             
      *                                                                                             
     dLJOB200KEY       ds                           qualified                                       
     d  KeyNumber01...                                                                              
     d*****                    1      4B 0                                                          
     d                               10i 0                                                          
     d  NumberOfKeys...                                                                             
     d*****                    5      8B 0                                                          
     d                               10i 0                                                          
      *                                                                                             
     dLJOBKEYINFO      ds                           qualified                                       
     d  LengthOfInformation...                                                                      
     d                               10i 0                                                          
     d  KeyField...                                                                                 
     d                               10i 0                                                          
     d  TypeOfData...                                                                               
     d                                1                                                             
     d  Reserved01...                                                                               
     d                                3                                                             
     d  LengthOfData...                                                                             
     d                               10i 0                                                          
     d  KeyData...                                                                                  
     d                             1000                                                             
      *                                                                                             
      *  APIErrDef     Standard API error handling structure.                  *                    
      *                                                                                             
     dQUSEC            DS                                                                           
     d  ErrorBytesProvided...                                                                       
     d                         1      4B 0                                                          
     d  ErrorBytesAvailble...                                                                       
     d                         5      8b 0                                                          
     d  ErrorExceptionId...                                                                         
     d                         9     15                                                             
     d  ErrorReserved...                                                                            
     d                        16     16                                                             
      *                                                                                             
     dAPIError         DS                                                                           
     d APIErrorProvied...                                                                           
     d                                     LIKE( ErrorBytesProvided )                               
     d                                     INZ( %LEN( APIError ) )                                  
     d APIErrorAvailble...                                                                          
     d                                     LIKE( ErrorBytesAvailble )                               
     d APIErrorMessageID...                                                                         
     d                                     LIKE( ErrorExceptionId )                                 
     d APIErrorReserved...                                                                          
     d                                     LIKE( ErrorReserved )                                    
     d APIErrorInformation...                                                                       
     d                              240A                                                            
      *-----------------------------------------------------------------                            
      * program status dataarea                                                                     
      *-----------------------------------------------------------------                            
     d PgmSts         SDS                                                                           
     d   P1User              254    263                                                             
     d   W1Program       *PROC                                                                      
      *--------------------------------------------------------------*                              
      * work fields                                                  *                              
      *--------------------------------------------------------------*                              
     d Variables       ds                                                                           
     d   Q                            1    inz('''')                                                
     d   Count                       15  0 inz                                                      
     d   KeyCount                    15  0 inz                                                      
     d   EndPos                      15  0 inz                                                      
     d   JobbStatus                   4    inz                                                      
     d   Subsystem                   20    inz                                                      
     d   ReturnCode                   1    inz                                                      
     d   FormatName                   8    inz                                                      
     d   QualifedJobName...                                                                         
     d                               26    inz                                                      
     d   JobStatus                   10    inz                                                      
     d   JobType                      1    inz                                                      
     d   NbrOfFldRtn                 10i 0 inz                                                      
     d   KeyFldRtn                   10i 0 inz dim(100)                                             
     d   StartingPosition...                                                                        
     d                               10i 0 inz                                                      
     d   LengthOfData...                                                                            
     d                               10i 0 inz                                                      
     d   KeyStartingPosition...                                                                     
     d                                8B 0 inz                                                      
     d   KeyLengthOfData...                                                                         
     d                                8B 0 inz                                                      
     d   ReceiverVariable...                                                                        
     d                            32048                                                             
     d   OS400_Cmd                 2000    inz( ' '  )                                              
     d   CmdLength                   15P 5 inz( %size( OS400_Cmd ) )                                
     d   True                         1    inz( *on  )                                              
     d   False                        1    inz( *off )                                              
      *                                                                                             
      /free                                                                                         
                                                                                                    
            size = 10000;                                                                           
            QUSCRTUS(UsrSpcName: 'USRSPC': size: x'00': '*ALL':                                     
            'Temp User Space for  QUSLJOB API':  '*YES': APIError);                                 
            exsr CheckStatusOfJob;                                                                  
                                                                                                    
            *inlr = *on;                                                                            
                                                                                                    
           // *************************************************************                         
           // check status of an job                                                                
           // -------------------------------------------------------------                         
                                                                                                    
             begsr CheckStatusOfJob;                                                                
                                                                                                    
           // run API to fill user space with information about all iSeries job                     
              FormatName = 'JOBL0200';                                                              
              QualifedJobName = '*ALL      ' + '*ALL      ' + '*ALL  ';                             
              JobStatus = '*ACTIVE';                                                                
              JobType = '*';                                                                        
              NbrOfFldRtn = 2;                                                                      
              KeyFldRtn( 1 ) = 0101;                                                                
              KeyFldRtn( 2 ) = 1906;                                                                
              QUSLJOB( UsrSpcName : FormatName  : QualifedJobName :                                 
                       JobStatus  : APIError    :                                                   
                       JobType    : NbrOfFldRtn : KeyFldRtn         );                              
           // if error message from the retrieve job API then dump program                          
              if APIErrorMessageID <> ' ';                                                          
               dump;                                                                                
               ReturnCode = True;                                                                   
               leavesr;                                                                             
              endif;                                                                                
           // run API to get user space attribute                                                   
              StartingPosition = 125;                                                               
              LengthOfData = 16;                                                                    
              callp QUSRTVUS( UsrSpcName   : StartingPosition  :                                    
              LengthOfData : ReceiverVariable  :                                                    
              APIError                           );                                                 
              QUSA0100 = ReceiverVariable;                                                          
           //  error message from the retrieve user space API then dump program                     
              if APIErrorMessageID <> ' ';                                                          
               dump;                                                                                
               ReturnCode = True;                                                                   
               leavesr;                                                                             
              endif;                                                                                
                                                                                                    
           // preperation to read from user space                                                   
              StartingPosition = QUsrSpcOffset + 1;                                                 
              LengthOfData = QUsrSpcEntrieSize;                                                     
           // read from user space                                                                  
              for count = 1 to QUsrSpcEntries;                                                      
               QUSRTVUS( UsrSpcName   : StartingPosition  :                                         
                         LengthOfData : ReceiverVariable  :                                         
                         APIError                           );                                      
                                                                                                    
               LJOB200 = ReceiverVariable;                                                          
               if APIErrorMessageID <> ' ';                                                         
                dump;                                                                               
                ReturnCode = True;                                                                  
                leavesr;                                                                            
               endif;                                                                               
                                                                                                    
           // check status of job                                                                   
               JobbStatus = ' ';                                                                    
               Subsystem = ' ';                                                                     
               LJobKeyInfo = LJob200.ReturnedData;                                                  
               KeyStartingPosition = 1;                                                             
               KeyLengthOfData = LJobKeyInfo.LengthOfInformation;                                   
                                                                                                    
               for keycount = 1 to LJob200.NumberOfFieldsReturned;                                  
                LJobKeyInfo = %subst( LJob200.ReturnedData :                                        
                                      KeyStartingPosition :                                         
                                      KeyLengthOfData );                                            
                                                                                                    
                KeyLengthOfData = LJobKeyInfo.LengthOfInformation;                                  
                                                                                                    
                LJobKeyInfo = %subst( LJob200.ReturnedData :                                        
                                       KeyStartingPosition :                                        
                                       KeyLengthOfData );                                           
                Endpos = LJobKeyInfo.LengthOfData;                                                  
                                                                                                    
                if  LJobKeyInfo.KeyField = 0101;                                                    
                 JobbStatus = %subst( LJobKeyInfo.KeyData : 1 :  Endpos );                          
                elseif LJobKeyInfo.KeyField = 1906;                                                 
                 Subsystem = %subst( LJobKeyInfo.KeyData : 1 : Endpos );                            
                endif;                                                                              
                                                                                                    
                KeyStartingPosition = KeyStartingPosition + KeyLengthOfData;                        
               endfor;                                                                              
           // job in message wait then email message to address in                                  
           // variable email address                                                                
               if Jobbstatus = 'MSGW';                                                              
                Subsystem = %trim( %subst( Subsystem : 11 : 10 ) ) + '/' +                          
                %trim( %subst( Subsystem :  1 : 10 ) );                                             
                os400_cmd = 'snddst type(*lmsg) ' +                                                 
                            'tointnet((' + Q + %trim(EmailAddress) +                                
                             Q + ')) dstd(' + Q    +                                                
                             'Job  is in  *MSGW'   +                                                
                             Q + ') longmsg(' + Q  +                                                
                             'Job (' +                                                              
                             %trim( LJob200.JobName ) + '/' +                                       
                             %trim( LJob200.UserName ) + '/' +                                      
                             %trim( LJob200.JobNumber ) +                                           
                             ') subsystem ' + %trim( Subsystem ) +                                  
                             ' in status *MSGW' +                                                   
                             Q + ')';                                                               
                monitor;                                                                            
           //    qcmdexc ( os400_cmd : %size ( os400_cmd ) );                                       
                on-error;                                                                           
                 dump;                                                                              
                endmon;                                                                             
               endif;                                                                               
                                                                                                    
               StartingPosition = StartingPosition + LengthOfData;                                  
              endfor;                                                                               
                                                                                                    
             endsr;                                                                                 
      /end-free