contact image

Subfiles

Subfiles are specified in the DDS for a display file to allow you to handle multiple records of the same type on the display. A subfile is a group of records that is read from or written to a display-device file. For example, a program reads records from a database file and creates a subfile of output records. When the entire subfile has been written, the program sends the entire subfile to the display device in one write operation. The work-station user can change data or enter additional data in the subfile. The program then reads the entire subfile from the display device into the program and processes each record in the subfile individually. Records that you want to be included in a subfile are specified in the DDS for the file. The number of records that can be included in a subfile must also be specified in the DDS. One file can contain more than one subfile, and up to 12 subfiles can be active concurrently. Two subfiles can be displayed at the same time.


Post Your Example

Dual subfile using mouse to add and delete records


Sample from Jamie Flanary posted at 2012-06-29 19:23:31

     fdualf1    if   e           k disk                                                             
     fdualf2    uf a e           k disk                                                             
     fDUALAD    cf   e             WORKSTN INFDS(INFDS)                                             
     f                                     SFILE(SUB01:RRN1)                                        
     f                                     SFILE(SUB02:RRN2)                                        
      * Program Info                                                                                
     d                SDS                                                                           
     d  @PGM                 001    010                                                             
     d  @JOB                 244    253                                                             
     d  @USER                254    263                                                             
                                                                                                    
      *  Field Definitions.                                                                         
     d EndScreen1      s               n                                                            
     d lastrrn1        s              4  0                                                          
     d lastrrn2        s              4  0                                                          
     d LenStr          s              4  0                                                          
     d messagecsc      s             10i 0                                                          
     d messagedata     s             80A                                                            
     d messagekey      s              4A                                                            
     d messagelen      s             10i 0                                                          
     d messagefile     s             20    inz('LBIMSG    *LIBL')                                   
     d messageid       s              7                                                             
     d Q               s              1    inz('''')                                                
     d Rcvar           s           5000A   Inz                                                      
     d RecordType      s              1    Inz('O')                                                 
     d ReloadSUB01     s               n                                                            
     d RRN1            s                   like(SCRRN1)                                             
     d RRN2            s                   like(SCRRN1)                                             
     d SavRrn1         s                   like(SCRRN1)                                             
     d SavRrn2         s                   like(SCRRN1)                                             
     d Screenerror1    s               n                                                            
     d worktitle       s             30                                                             
     d Varlen          s             10i 0 Inz(5000)                                                
     d whichOne        S              1  0                                                          
                                                                                                    
     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 Infds           ds                                                       INFDS data structure
     d Choice                369    369                                                             
     d Currec                378    379I 0                                                          
                                                                                                    
      //  colors                                                                                    
     d Normal          c                   X'20'                                                    
     d White           c                   X'22'                                                    
                                                                                                    
      //  external called programs                                                                  
     d $clearmsg       pr                  extpgm('QMHRMVPM')                                       
     d   messageq                   276a   const                                                    
     d   CallStack                   10i 0 const                                                    
     d   Messagekey                   4a   const                                                    
     d   messagermv                  10a   const                                                    
     d   ErrorCode                  256                                                             
                                                                                                    
     d $sendmsg        PR                  ExtPgm('QMHSNDPM')                                       
     d   MessageID                    7A   Const                                                    
     d   QualMsgF                    20A   Const                                                    
     d   MsgData                    256A   Const                                                    
     d   MsgDtaLen                   10I 0 Const                                                    
     d   MsgType                     10A   Const                                                    
     d   CallStkEnt                  10A   Const                                                    
     d   CallStkCnt                  10I 0 Const                                                    
     d   Messagekey                   4A                                                            
     d   ErrorCode                  256A                                                            
                                                                                                    
      // Command Keys                                                                               
     d Cmd01           c                   const(x'31')                         Cmd-1               
     d Cmd02           c                   const(x'32')                         Cmd-2               
     d LeaveProgram    c                   const(x'33')                         Cmd-3               
     d Cmd04           c                   const(x'34')                         Cmd-4               
     d Cmd05           c                   const(x'35')                         Cmd-5               
     d Cmd06           c                   const(x'36')                         Cmd-6               
     d Cmd07           c                   const(x'37')                         Cmd-7               
     d Cmd08           c                   const(x'38')                         Cmd-8               
     d Cmd09           c                   const(x'39')                         Cmd-9               
     d Cmd10           c                   const(x'3A')                         Cmd-10              
     d Cmd11           c                   const(x'3B')                         Cmd-11              
     d Cmd12           c                   const(x'3C')                         Cmd-12              
     d Cmd13           c                   const(x'B1')                         Cmd-13              
     d Cmd14           c                   const(x'B2')                         Cmd-14              
     d TogWhichOne     c                   const(x'B3')                         Cmd-15              
     d SelectIt        c                   const(x'B4')                         Cmd-16              
     d Cmd17           c                   const(x'B5')                         Cmd-17              
     d Cmd18           c                   const(x'B6')                         Cmd-18              
     d Cmd19           c                   const(x'B7')                         Cmd-19              
     d Cmd20           c                   const(x'B8')                         Cmd-20              
     d Cmd21           c                   const(x'B9')                         Cmd-21              
     d Cmd22           c                   const(x'BA')                         Cmd-22              
     d Cmd23           c                   const(x'BB')                         Cmd-23              
     d Cmd24           c                   const(x'BC')                         Cmd-24              
     d EnterKey        c                   const(x'F1')                                             
     d RollUp          c                   const(x'F5')                         Roll Up             
     d RollDown        c                   const(x'F4')                         Roll Down           
                                                                                                    
      //  Procedures                                                                                
      /copy qpgmsrc,oen1ctrl                                                                        
      *                                                                                             
      /free                                                                                         
                                                                                                    
       //--------------------------------------------------------                                   
       // Main Program Processing                               -                                   
       //--------------------------------------------------------                                   
         exsr Hskpg;                                                                                
         exsr $Screen1;                                                                             
                                                                                                    
         *inlr = *on;                                                                               
                                                                                                    
        //----------------------------------------------                                            
        // $Screen1 - Set/Remove entries                                                            
        //----------------------------------------------                                            
        begsr $Screen1;                                                                             
                                                                                                    
         //Set the screen heading                                                                   
                                                                                                    
          workTitle = 'Maintain User Groups';                                                       
          LenStr =                                                                                  
          ((%len(workTitle) - %len(%trim(workTitle))) / 2) + 1;                                     
          %subst(C1TITLE:LenStr) = %trim(workTitle);                                                
                                                                                                    
         WhichOne = 1;                                                                              
         ExSr $ClearSFL1;                                                                           
         ExSr $LoadSfl1;                                                                            
                                                                                                    
         reset  EndScreen1;                                                                         
         dow  EndScreen1 = *off;                                                                    
                                                                                                    
          if ScreenError1 = *off;                                                                   
           $clearmsg('*' : *zero : *Blanks : '*ALL' : APIError);                                    
          endif;                                                                                    
                                                                                                    
          Write Header;                                                                             
          Write Footer;                                                                             
          If whichOne = 1;                                                                          
           Write Sub02Ctl;                                                                          
           ExFmt Sub01Ctl;                                                                          
           if Currec <> *Zeros;                                                                     
            RRN1 = Currec;                                                                          
            SCRRN1 = Currec;                                                                        
           endif;                                                                                   
          else;                                                                                     
           Write Sub01Ctl;                                                                          
           ExFmt Sub02Ctl;                                                                          
           if Currec <> *Zeros;                                                                     
            RRN2 = Currec;                                                                          
            SCRRN2 = Currec;                                                                        
           endif;                                                                                   
          endif;                                                                                    
          $clearmsg('*' : *zero : *Blanks : '*ALL' : APIError);                                     
          reset ScreenError1;                                                                       
                                                                                                    
          select;                                                                                   
           // F3 pressed end the program F3 = LeaveProgram                                          
           when  Choice = LeaveProgram;                                                             
            EndScreen1 = *on;                                                                       
                                                                                                    
           when Choice = TogWhichOne;                                                               
            If WhichOne = 1;                                                                        
             WhichOne = 2;                                                                          
            else;                                                                                   
             WhichOne = 1;                                                                          
            endif;                                                                                  
            exsr $clearsfl1;                                                                        
            exsr $loadsfl1;                                                                         
                                                                                                    
           when Choice = SelectIt;                                                                  
            If WhichOne = 1;                                                                        
             //Move from sub1 to sub2                                                               
             Chain where1 Sub01;                                                                    
             If %Found(DUALAD);                                                                     
              setll (@user : s1user) dualf2;                                                        
              if not%equal(dualf2);                                                                 
               //Write the record to the file                                                       
               dgroup = @user;                                                                      
               duser = s1user;                                                                      
               write dualf2r;                                                                       
              endif;                                                                                
             endif;                                                                                 
            else;                                                                                   
             //Remove                                                                               
             Chain where2 Sub02;                                                                    
             If %Found(DUALAD);                                                                     
              Chain (@user: s2user) dualf2;                                                         
              If %Found(dualf2);                                                                    
               delete dualf2r;                                                                      
              endif;                                                                                
             endif;                                                                                 
            endif;                                                                                  
                                                                                                    
            exsr $clearsfl1;                                                                        
            exsr $loadsfl1;                                                                         
                                                                                                    
           // Enter Key pressed                                                                     
           when  Choice = enterKey;                                                                 
                                                                                                    
            exsr $clearsfl1;                                                                        
            exsr $loadsfl1;                                                                         
                                                                                                    
           endsl;                                                                                   
          enddo;                                                                                    
                                                                                                    
        endsr;                                                                                      
                                                                                                    
        //----------------------------------------                                                  
        // $clearSfl1 - clear side by side subfiles                                                 
        //----------------------------------------                                                  
        begsr $clearSFL1;                                                                           
                                                                                                    
         // clear the subfile first                                                                 
                                                                                                    
          *in31 = *Off;                                                                             
          *in32 = *Off;                                                                             
          *in30 = *On;                                                                              
                                                                                                    
          *in35 = *Off;                                                                             
          *in36 = *Off;                                                                             
          *in34 = *On;                                                                              
                                                                                                    
          write SUB01CTL;                                                                           
          write SUB02CTL;                                                                           
                                                                                                    
          *in31 = *On;                                                                              
          *in32 = *On;                                                                              
          *in30 = *Off;                                                                             
                                                                                                    
          *in35 = *On;                                                                              
          *in36 = *On;                                                                              
          *in34 = *Off;                                                                             
                                                                                                    
          clear RRN1;                                                                               
          clear SCRRN1;                                                                             
          clear SavRrn1;                                                                            
                                                                                                    
          clear RRN2;                                                                               
          clear SCRRN2;                                                                             
          clear SavRrn2;                                                                            
                                                                                                    
        endsr;                                                                                      
                                                                                                    
        //--------------------------------------------------------                                  
        // $loadsfl1 - Load both side by side sfl's                                                 
        //--------------------------------------------------------                                  
        begsr $loadsfl1;                                                                            
                                                                                                    
         if  SavRrn1 > *zeros;                                                                      
          RRN1  =  SavRrn1;                                                                         
          SCRRN1=  SavRrn1;                                                                         
         endif;                                                                                     
                                                                                                    
         if  SavRrn2 > *zeros;                                                                      
          RRN2  =  SavRrn2;                                                                         
          SCRRN2=  SavRrn2;                                                                         
         endif;                                                                                     
                                                                                                    
         // load subfile# 1                                                                         
                                                                                                    
         setll *start  dualf1;                                                                      
         read dualf1;                                                                               
         dow not%eof(dualf1);                                                                       
          s1user = DUSER;                                                                           
          s1uname = DNAME;                                                                          
          RRN1 += 1;                                                                                
          SCRRN1 = RRN1;                                                                            
          write SUB01;                                                                              
          read dualf1;                                                                              
         enddo;                                                                                     
                                                                                                    
                                                                                                    
         // load subfile# 2                                                                         
                                                                                                    
         setll (@user) dualf2;                                                                      
         reade (@user) dualf2;                                                                      
         dow not %eof(dualf2);                                                                      
          //load sfl2                                                                               
          s2user = DUSER;                                                                           
          chain (s2user) dualf1;                                                                    
          if %found(dualf1);                                                                        
           s2uname = DNAME;                                                                         
          endif;                                                                                    
                                                                                                    
          RRN2 += 1;                                                                                
          SCRRN2 = RRN2;                                                                            
          write SUB02;                                                                              
          reade (@user) dualf2;                                                                     
         enddo;                                                                                     
                                                                                                    
         *in33 = *On;                                                                               
         *in37 = *On;                                                                               
         savrrn1 = SCRRN1;                                                                          
         savrrn2 = SCRRN2;                                                                          
                                                                                                    
         //  If no records in subfile then do not disply the subfile.                               
         if SavRrn1  = *zeros;                                                                      
          *in31 = *off;                                                                             
         else;                                                                                      
          //If we updated selected units make sure RRN is valid                                     
          If LastRRN1 > *zeros and LastRRN1 <= SavRRN1;                                             
           RRN1 = LastRRN1;                                                                         
           ScRRN1 = LastRRN1;                                                                       
          else;                                                                                     
           RRN1 = 1;                                                                                
           SCRRN1 = 1;                                                                              
          endif;                                                                                    
         endif;                                                                                     
                                                                                                    
         //  If no records in subfile then do not disply the subfile.                               
         if SavRrn2  = *zeros;                                                                      
          *in35 = *off;                                                                             
         else;                                                                                      
          //If we updated selected units make sure RRN is valid                                     
          If LastRRN2 > *zeros and LastRRN2 <= SavRRN2;                                             
           RRN2 = LastRRN2;                                                                         
           ScRRN2 = LastRRN2;                                                                       
          else;                                                                                     
           RRN2  = 1;                                                                               
           SCRRN2  = 1;                                                                             
          endif;                                                                                    
         endif;                                                                                     
                                                                                                    
        endsr;                                                                                      
                                                                                                    
        //----------------------------------------                                                  
        // $sendmessage - send the program message                                                  
        //----------------------------------------                                                  
        begsr $sendmessage;                                                                         
                                                                                                    
         $sendmsg(messageID   :                                                                     
                  messageFile :                                                                     
                  messagedata :                                                                     
                  messageLen  :                                                                     
                  '*DIAG'     :                                                                     
                  @PGM        :                                                                     
                  messagecsc  :                                                                     
                  messagekey  :                                                                     
                  APIError                                                                          
                              );                                                                    
                                                                                                    
        endsr;                                                                                      
                                                                                                    
        //--------------------------------------------------------                                  
        // Hskpg - one time run subroutine                                                          
        //--------------------------------------------------------                                  
        begsr Hskpg;                                                                                
                                                                                                    
                                                                                                    
        endsr;                                                                                      
                                                                                                    
      /End-Free                                                                                     

Simple subfile drop program example


Sample from Jamie Flanary posted at 2012-05-22 09:21:57

     A*%%TS  SD  20070223  103030  FLANARY     REL-V5R3M0  5722-WDS                                 
     A*%%EC                                                                                         
     A                                      DSPSIZ(24 80 *DS3)                                      
     A                                      PRINT                                                   
     A                                      CF01(01)                                                
     A*=============================================================                                
     A*  Subfile number One                                                                         
     A*       Select Command To Run                                                                 
     A*=============================================================                                
     A          R SUB01                     SFL                                                     
     A*%%TS  SD  20070223  102640  FLANARY     REL-V5R3M0  5722-WDS                                 
     A            S1HPROCESS    10A  H                                                              
     A            S1CUST#        5Y 0O  8  2EDTCDE(Z)                                               
     A            S1NAME        25A  O  8  8                                                        
     A            S1AD1         25A  O  8 34                                                        
     A            S1CITY        12A  O  8 60                                                        
     A            S1STATE        3A  O  8 73                                                        
     A            S1DROPPED     10   B  9  8                                                        
     A*=============================================================                                
     A*  Control for subfile number one                                                             
     A*       Select Command to Run                                                                 
     A*=============================================================                                
     A          R SUB01CTL                  SFLCTL(SUB01)                                           
     A*%%TS  SD  20070223  103030  FLANARY     REL-V5R3M0  5722-WDS                                 
     A                                      SFLSIZ(0016)                                            
     A                                      SFLPAG(0005)                                            
     A                                      CF03(03)                                                
     A N80                                  CF06(06)                                                
     A                                      CF12(12)                                                
     A                                      PAGEDOWN(33)                                            
     A                                      CF21(21)                                                
     A                                      RTNCSRLOC(&#REC &#FLD)                                  
     A                                      BLINK                                                   
     A  99                                  ALARM                                                   
     A                                      RTNDTA                                                  
     A                                      OVERLAY                                                 
     A                                      SFLCSRRRN(&WHERE)                                       
     A                                      SFLMODE(&MODE)                                          
     A  50                                  SFLDSP                                                  
     A  51                                  SFLDSPCTL                                               
     A  52                                  SFLCLR                                                  
     A  88                                  SFLDROP(CF14)                                           
     A N88                                  SFLFOLD(CF14)                                           
     A            SCRRN          4S 0H      SFLRCDNBR                                               
     A            #REC          10A  H                                                              
     A            #FLD          10A  H                                                              
     A            WHERE          5S 0H                                                              
     A            MODE           1A  H                                                              
     A                                  2  2DATE                                                    
     A                                      EDTCDE(Y)                                               
     A                                      COLOR(BLU)                                              
     A            C1DAY         10A  O  3  2COLOR(PNK)                                              
     A                                  2 31'Warehouse selection'                                   
     A                                  1 70USER                                                    
     A                                      COLOR(BLU)                                              
     A                                  2 70SYSNAME                                                 
     A                                      COLOR(BLU)                                              
     A                                  4  1'Place Cursor on product, press  key'                                               
     A                                      COLOR(BLU)                                              
     A                                  1  2TIME                                                    
     A                                      COLOR(BLU)                                              
     A                                  3 53'The mode says'                                         
     A            C1MODE         1   O  3 68                                                        
     A*=========================================================================                    
     A*   Window for command selection.                                                             
     A*=========================================================================                    
     A          R FMT1                                                                              
     A*%%TS  SD  20070223  102025  FLANARY     REL-V5R3M0  5722-WDS                                 
     A                                      WINDOW(3 5 18 45)                                       
     A                                      WDWBORDER((*COLOR BLU) (*DSPATR RI)-                    
     A                                       (*CHAR '        '))                                    
     A                                 17  2'F3=Exit'                                               
     A                                      COLOR(BLU)                                              
     A                                 17 11'F12=Cancel'                                            
     A                                      COLOR(BLU)                                              
     A          R DUMMY                                                                             
     A*%%TS  SD  19981208  163103  JAMIEF      REL-V3R7M0  5716-PW1                                 
     A                                      ASSUME                                                  
     A                                  1  3' '                                                     
     A          R FKEY01                                                                            
     A*%%TS  SD  20070223  102143  FLANARY     REL-V5R3M0  5722-WDS                                 
     A                                 23  3'F3=Exit'                                               
     A                                      COLOR(BLU)                                              
     A                                 23 13'F12=Cancel'                                            
     A                                      COLOR(BLU)                                              
     A                                 23 27'F21=Fold'                                              
     A                                      COLOR(BLU)                                              

Quick example of a load page at a time subroutine with position to...


Sample from Jamie Flanary posted at 2012-01-12 19:01:29

      //---------------------------------------------------                                         
      // Program -                                                                                  
      // Purpose - Load single page at a time                                                       
      // Written - xx/xx/xx                                                                         
      // Author  - xxxxxxxxxxxxxxxxxxxx                                                             
      //                                                                                            
      // INPUT PARAMETERS                                                                           
      //   Description        Type  Size    How Used                                                
      //   -----------        ----  ----    --------                                                
      //                                                                                            
      // INDICATOR USAGE                                                                            
      //   03 - leave                                                                               
      //---------------------------------------------------                                         
     fSINGLEP   if   e           k disk                                                             
     fSINGLEAD  cf   e             workstn INFDS(INFDS)                                             
     f                                     SFILE(SUB01:RRN1)                                        
                                                                                                    
      // Data Structures                                                                            
     d Infds           ds                                                       INFDS data structure
     d Choice                369    369                                                             
     d Currec                378    379B 0                                                          
      //                                                                                            
      // Program Info                                                                               
      //                                                                                            
     d                SDS                                                                           
     d  @PGM                 001    010                                                             
     d  @PARMS               037    039  0                                                          
     d  @MSGDTA               91    170                                                             
     d  @MSGID               171    174                                                             
     d  @JOB                 244    253                                                             
     d  @USER                254    263                                                             
     d  @JOB#                264    269  0                                                          
      //                                                                                            
      // Variables                                                                                  
      //                                                                                            
                                                                                                    
     d Normal          c                   X'20'                                                    
     d Red             c                   X'28'                                                    
     d White           c                   X'22'                                                    
     d Blue            c                   X'3A'                                                    
     d Pink            c                   X'38'                                                    
                                                                                                    
     d @Scrn1          s              1                                                             
     d count           s              4  0                                                          
     d EndScreen1      s               n   inz('0')                                                 
     d KeyTop          s              2                                                             
     d KeyBottom       s              2                                                             
     d pagesize        s              2  0 inz(10)                                                  
     d RRN1            s                   like(SCRRN)                                              
     d Savrrn          s                   like(SCRRN)                                              
     d ScreenError     s              1    inz('N')                                                 
      *                                                                                             
      * Command Keys                                                                                
      *                                                                                             
     d Cmd01           c                   const(x'31')                         Cmd-1               
     d Cmd02           c                   const(x'32')                         Cmd-2               
     d LeaveProgram    c                   const(x'33')                         Cmd-3               
     d Cmd04           c                   const(x'34')                         Cmd-4               
     d Cmd05           c                   const(x'35')                         Cmd-5               
     d Cmd06           c                   const(x'36')                         Cmd-6               
     d Cmd07           c                   const(x'37')                         Cmd-7               
     d Cmd08           c                   const(x'38')                         Cmd-8               
     d Cmd09           c                   const(x'39')                         Cmd-9               
     d Cmd10           c                   const(x'3A')                         Cmd-10              
     d Cmd11           c                   const(x'3B')                         Cmd-11              
     d Cmd12           c                   const(x'3C')                         Cmd-12              
     d Cmd13           c                   const(x'B1')                         Cmd-13              
     d Cmd14           c                   const(x'B2')                         Cmd-14              
     d Cmd15           c                   const(x'B3')                         Cmd-15              
     d Cmd16           c                   const(x'B4')                         Cmd-16              
     d Cmd17           c                   const(x'B5')                         Cmd-17              
     d Cmd18           c                   const(x'B6')                         Cmd-18              
     d Cmd19           c                   const(x'B7')                         Cmd-19              
     d Cmd20           c                   const(x'B8')                         Cmd-20              
     d Cmd21           c                   const(x'B9')                         Cmd-21              
     d Cmd22           c                   const(x'BA')                         Cmd-22              
     d Cmd23           c                   const(x'BB')                         Cmd-23              
     d Cmd24           c                   const(x'BC')                         Cmd-24              
     d EnterKey        c                   const(x'F1')                                             
     d PageDown        c                   const(x'F5')                         Roll Up             
     d PageUp          c                   const(x'F4')                         Roll Down           
                                                                                                    
      //                                                                                            
      // Break apart the time stamp                                                                 
      //                                                                                            
      //---------------------------------------------------                                         
      //       C a l c u l a t i o n  S p e c s                                                     
      //---------------------------------------------------                                         
      /free                                                                                         
       exsr $Screen1;                                                                               
       *inlr = *on;                                                                                 
                                                                                                    
       //===========================================                                                
       //  $Screen1 - Display all parts allow for                                                   
       //             Search.                                                                       
       //===========================================                                                
       begsr $Screen1;                                                                              
         //                                                                                         
         reset EndScreen1;                                                                          
         dow EndScreen1 = *off;                                                                     
                                                                                                    
           write FKEY01;                                                                            
           exfmt SUB01CTL;                                                                          
                                                                                                    
           if Currec <> *Zeros;                                                                     
            RRN1    =  Currec;                                                                      
            SCRRN   =  Currec;                                                                      
           endif;                                                                                   
                                                                                                    
           reset ScreenError;                                                                       
                                                                                                    
           select;                                                                                  
             // F3 pressed end the program F3 = LeaveProgram                                        
            when Choice = LeaveProgram;                                                             
             EndScreen1 = *on;                                                                      
                                                                                                    
            when Choice = PageUp;                                                                   
             exsr $Clearsfl;                                                                        
             exsr $pageup;                                                                          
                                                                                                    
            when Choice = PageDown;                                                                 
             exsr $Clearsfl;                                                                        
             exsr $pagedown;                                                                        
                                                                                                    
            other;                                                                                  
             if c1key = *blanks;                                                                    
              exsr $process;                                                                        
             else;                                                                                  
              exsr $position;                                                                       
             endif;                                                                                 
                                                                                                    
           endsl;                                                                                   
                                                                                                    
         enddo;                                                                                     
                                                                                                    
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       //  $ClearSFL- Clear the route error sub                                                     
       //===========================================                                                
       begsr $clearsfl;                                                                             
                                                                                                    
         *in31  = *Off;                                                                             
         *in32  = *Off;                                                                             
         *in30  = *On;                                                                              
                                                                                                    
         write SUB01CTL;                                                                            
                                                                                                    
         *in31  = *On;                                                                              
         *in32  = *On;                                                                              
         *in30  = *Off;                                                                             
                                                                                                    
         clear RRN1;                                                                                
         clear SCRRN;                                                                               
         clear SavRrn;                                                                              
                                                                                                    
         *in33 = *off;                                                                              
         clear count;                                                                               
                                                                                                    
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       //  $PageDown = page down 10 records                                                         
       //===========================================                                                
        begsr $PageDown;                                                                            
                                                                                                    
         if SavRrn  > *Zeros;                                                                       
          rrn1  = savrrn;                                                                           
          scrrn = savrrn;                                                                           
         endif;                                                                                     
                                                                                                    
         setgt (keybottom) SINGLEP;                                                                 
         for count = 1 to Pagesize;                                                                 
          read  SINGLEP;                                                                            
                                                                                                    
          if %eof(singlep);                                                                         
           // subfile end indicator                                                                 
           *in33 = *on;                                                                             
           leave;                                                                                   
          endif;                                                                                    
                                                                                                    
          // keep track of first and last record                                                    
          select;                                                                                   
           when count = 1;                                                                          
            keytop = key;                                                                           
           when count = Pagesize;                                                                   
            keybottom = key;                                                                        
          endsl;                                                                                    
                                                                                                    
          s1key = key;                                                                              
          s1desc = desc;                                                                            
                                                                                                    
          RRN1  +=1;                                                                                
          SCRRN  = RRN1;                                                                            
          write SUB01;                                                                              
          savrrn = scrrn;                                                                           
         endfor;                                                                                    
                                                                                                    
         //                                                                                         
         //  If no records in subfile then do not disply the subfile.                               
         //                                                                                         
                                                                                                    
         if SavRrn  = *zeros;                                                                       
           *in31 = *off;                                                                            
         endif;                                                                                     
                                                                                                    
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       //  $PageUp = page up 10 records                                                             
       //===========================================                                                
        begsr $PageUp;                                                                              
                                                                                                    
         if SavRrn  > *Zeros;                                                                       
          rrn1  = savrrn;                                                                           
          scrrn = savrrn;                                                                           
         endif;                                                                                     
                                                                                                    
         // read back records                                                                       
         setll (keytop) singlep;                                                                    
         for count = 1 to (pagesize)+1;                                                             
          readp singlep;                                                                            
          if %eof(singlep);                                                                         
           clear keytop;                                                                            
           clear keybottom;                                                                         
           leave;                                                                                   
          endif;                                                                                    
                                                                                                    
          // reset the top & bottom keys                                                            
          select;                                                                                   
           when count = (pagesize+1);                                                               
            keybottom = key;                                                                        
          endsl;                                                                                    
          keytop = key;                                                                             
         endfor;                                                                                    
         exsr $pagedown;                                                                            
                                                                                                    
         //                                                                                         
         //  If no records in subfile then do not disply the subfile.                               
         //                                                                                         
                                                                                                    
         if SavRrn  = *zeros;                                                                       
           *in31 = *off;                                                                            
         endif;                                                                                     
                                                                                                    
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       // $Position                                                                                 
       //===========================================                                                
       begsr $Position;                                                                             
                                                                                                    
                                                                                                    
       setll (c1key) singlep;       
       exsr $Clearsfl;              
       readp singlep;               
       if %eof;                     
        setll *start singlep;       
        clear keybottom;            
       else;                        
        keybottom = key;            
       endif;                       
       exsr $pagedown;                                                                                           
                                                                                                    
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       // $Process - Process the subfile(1)                                                         
       //===========================================                                                
       begsr $Process;                                                                              
                                                                                                    
                                                                                                    
       endsr;                                                                                       
                                                                                                    
       //=================================================                                          
       //  *inzsr - One time run processing                                                         
       //=================================================                                          
       begsr *inzsr;                                                                                
                                                                                                    
         exsr $Clearsfl;                                                                            
         exsr $PageDown;                                                                            
                                                                                                    
       endsr;                                                                                       
                                                                                                    
      /end-free                                                                                     

Dual Subfile example


Sample from Jamie Flanary posted at 2012-01-07 07:07:49

      //---------------------------------------------------                                         
      // Program -                                                                                  
      // Purpose - multiple subfile                                                                 
      // Written - xx/xx/xx                                                                         
      // Author  - xxxxxxxxxxxxxxxxxxxx                                                             
      //                                                                                            
      // INPUT PARAMETERS                                                                           
      //   Description        Type  Size    How Used                                                
      //   -----------        ----  ----    --------                                                
      //                                                                                            
      // INDICATOR USAGE                                                                            
      //   03 - leave                                                                               
      //   80 - controls cursor on subfiles                                                         
      //---------------------------------------------------                                         
     fDUALAD    cf   e             workstn INFDS(INFDS)                                             
     f                                     SFILE(SUB01:RRN1)                                        
     f                                     SFILE(SUB02:RRN2)                                        
                                                                                                    
      // Data Structures                                                                            
     d Infds           ds                                                       INFDS data structure
     d Choice                369    369                                                             
     d Currec                378    379B 0                                                          
      //                                                                                            
      // Program Info                                                                               
      //                                                                                            
     d                SDS                                                                           
     d  @PGM                 001    010                                                             
     d  @PARMS               037    039  0                                                          
     d  @MSGDTA               91    170                                                             
     d  @MSGID               171    174                                                             
     d  @JOB                 244    253                                                             
     d  @USER                254    263                                                             
     d  @JOB#                264    269  0                                                          
      //                                                                                            
      // Variables                                                                                  
      //                                                                                            
                                                                                                    
     d Normal          c                   X'20'                                                    
     d Red             c                   X'28'                                                    
     d White           c                   X'22'                                                    
     d Blue            c                   X'3A'                                                    
     d Pink            c                   X'38'                                                    
                                                                                                    
     d @Scrn1          s              1                                                             
     d ActiveSubfile   s              1    inz('0')                                                 
     d count           s              4  0                                                          
     d count2          s              4  0                                                          
     d count3          s              4  0                                                          
     d count4          s              4  0                                                          
     d EndScreen1      s              1    inz('N')                                                 
     d RRN1            s                   like(SCRRN)                                              
     d Savrrn          s                   like(SCRRN)                                              
     d RRN2            s                   like(SCRRN)                                              
     d Savrrn2         s                   like(SCRRN)                                              
     d ScreenError     s              1    inz('N')                                                 
     d write5          s              1  0                                                          
     d write52         s              1  0                                                          
      *                                                                                             
      * Command Keys                                                                                
      *                                                                                             
     d Cmd01           c                   const(x'31')                         Cmd-1               
     d Cmd02           c                   const(x'32')                         Cmd-2               
     d LeaveProgram    c                   const(x'33')                         Cmd-3               
     d MoreFields      c                   const(x'34')                         Cmd-4               
     d Cmd05           c                   const(x'35')                         Cmd-5               
     d Cmd06           c                   const(x'36')                         Cmd-6               
     d Cmd07           c                   const(x'37')                         Cmd-7               
     d Cmd08           c                   const(x'38')                         Cmd-8               
     d Cmd09           c                   const(x'39')                         Cmd-9               
     d Cmd10           c                   const(x'3A')                         Cmd-10              
     d Cmd11           c                   const(x'3B')                         Cmd-11              
     d Cmd12           c                   const(x'3C')                         Cmd-12              
     d Cmd13           c                   const(x'B1')                         Cmd-13              
     d Cmd14           c                   const(x'B2')                         Cmd-14              
     d Cmd15           c                   const(x'B3')                         Cmd-15              
     d Cmd16           c                   const(x'B4')                         Cmd-16              
     d Cmd17           c                   const(x'B5')                         Cmd-17              
     d Cmd18           c                   const(x'B6')                         Cmd-18              
     d Cmd19           c                   const(x'B7')                         Cmd-19              
     d Cmd20           c                   const(x'B8')                         Cmd-20              
     d Cmd21           c                   const(x'B9')                         Cmd-21              
     d Cmd22           c                   const(x'BA')                         Cmd-22              
     d Cmd23           c                   const(x'BB')                         Cmd-23              
     d Cmd24           c                   const(x'BC')                         Cmd-24              
     d EnterKey        c                   const(x'F1')                                             
     d RollUp          c                   const(x'F5')                         Roll Up             
     d RollDown        c                   const(x'F4')                         Roll Down           
                                                                                                    
      //                                                                                            
      // Break apart the time stamp                                                                 
      //                                                                                            
      //---------------------------------------------------                                         
      //       C a l c u l a t i o n  S p e c s                                                     
      //---------------------------------------------------                                         
      /free                                                                                         
       exsr $Screen1;                                                                               
       *INLR = *on;                                                                                 
                                                                                                    
       //===========================================                                                
       //  $Screen1 - Display all parts allow for                                                   
       //             Search.                                                                       
       //===========================================                                                
       begsr $Screen1;                                                                              
         //                                                                                         
         reset EndScreen1;                                                                          
         dow EndScreen1 = 'N';                                                                      
                                                                                                    
                                                                                                    
           write FKEY01;                                                                            
           if Activesubfile = '1' or                                                                
              Activesubfile = '0';                                                                  
            write SUB02CTL;                                                                         
            exfmt SUB01CTL;                                                                         
            read  SUB02CTL;                                                                         
           else;                                                                                    
            write SUB01CTL;                                                                         
            exfmt SUB02CTL;                                                                         
            read  SUB01CTL;                                                                         
           endif;                                                                                   
           clear c1text;                                                                            
           clear c2text;                                                                            
                                                                                                    
           // determine which subfile is active                                                     
           reset ActiveSubfile;                                                                     
           *in25 = *off;                                                                            
           *in26 = *off;                                                                            
           *in27 = *off;                                                                            
           *in28 = *off;                                                                            
                                                                                                    
           select;                                                                                  
            when where > *zeros and c1field = *blanks or                                            
             #fld = 'C1FIELD' and c1field = *blanks;                                                
             *in25 = *on;                                                                           
             *in26 = *on;                                                                           
             *in27 = *off;                                                                          
             *in28 = *off;                                                                          
             ActiveSubfile = '1';                                                                   
             *in80 = *off;                                                                          
                                                                                                    
            when where2 > *zeros and c2field = *blanks or                                           
             #FLD2 = 'C2FIELD' and c2field = *blanks;                                               
             *in25 = *off;                                                                          
             *in26 = *off;                                                                          
             *in27 = *on;                                                                           
             *in28 = *on;                                                                           
             ActiveSubfile = '2';                                                                   
           endsl;                                                                                   
                                                                                                    
           if Currec <> *Zeros;                                                                     
             select;                                                                                
              when ActiveSubfile = '0' or                                                           
                   ActiveSubfile = '1';                                                             
               RRN1    =  Currec;                                                                   
               SCRRN   =  Currec;                                                                   
              when ActiveSubfile = '2';                                                             
               RRN2    =  Currec;                                                                   
               SCRRN2  =  Currec;                                                                   
             endsl;                                                                                 
           endif;                                                                                   
                                                                                                    
           reset ScreenError;                                                                       
                                                                                                    
           select;                                                                                  
             // F3 pressed end the program F3 = LeaveProgram                                        
            when Choice = LeaveProgram;                                                             
             EndScreen1 = 'Y';                                                                      
                                                                                                    
            when Choice = Rollup and ActiveSubfile = '1';                                           
             exsr $removeIndicators;                                                                
             *in27 = *on;                                                                           
             exsr $loadsfl;                                                                         
            when Choice = Rollup and ActiveSubfile = '2' or                                         
                 Choice = Rollup and ActiveSubfile = '0';                                           
             exsr $removeIndicators;                                                                
             *in80 = *on;                                                                           
             *in25 = *off;                                                                          
             *in26 = *off;                                                                          
             *in27 = *on;                                                                           
             *in28 = *on;                                                                           
             exsr $loadsfl2;                                                                        
                                                                                                    
            other;                                                                                  
             if c1field = *blanks and C2field = *blanks;                                            
              exsr $process;                                                                        
             else;                                                                                  
               // fields in display that are populated by keyword RTNCSRLOC                         
               // are #rec = record format, #FLD = field cursor is on when action occured,          
               // and #POS where in the #FLD was the cursor during action.                          
              clear c1text;                                                                         
              clear c2text;                                                                         
                                                                                                    
              select;                                                                               
               when c1field <> *blanks;                                                             
                c1text = 'Format = ' + %trim(#rec) + ' Field = ' +                                  
                         %trim(#FLD) + ' in pos ' + %char(#POS) ;                                   
                clear c1field;                                                                      
                *in25 = *on;                                                                        
                ActiveSubfile = '1';                                                                
                                                                                                    
               when c2field <> *blanks;                                                             
                c2text = 'Format = ' + %trim(#rec2) + ' Field = ' +                                 
                         %trim(#FLD2) + ' in pos ' + %char(#POS2) ;                                 
                clear c2field;                                                                      
                *in27 = *on;                                                                        
                ActiveSubfile = '2';                                                                
              endsl;                                                                                
                                                                                                    
             endif;                                                                                 
                                                                                                    
           endsl;                                                                                   
                                                                                                    
         enddo;                                                                                     
                                                                                                    
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       // $Remove Indicators   (subfiles)                                                           
       //===========================================                                                
       begsr $RemoveIndicators;                                                                     
                                                                                                    
         if ActiveSubfile = '2';                                                                    
          for count3 = 1 to savrrn;                                                                 
           chain count3 sub01;                                                                      
           if %found;                                                                               
            *in26 = *off;                                                                           
            update sub01;                                                                           
           endif;                                                                                   
          endfor;                                                                                   
         endif;                                                                                     
                                                                                                    
         if ActiveSubfile = '1';                                                                    
          for count3 = 1 to savrrn2;                                                                
           chain count3 sub02;                                                                      
           if %found;                                                                               
            *in28 = *off;                                                                           
            update sub02;                                                                           
           endif;                                                                                   
          endfor;                                                                                   
         endif;                                                                                     
                                                                                                    
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       // $Process - Process the subfile(1)                                                         
       //===========================================                                                
       begsr $Process;                                                                              
                                                                                                    
         //check subfile #1 first for options                                                       
         for count4 = 1 to savrrn;                                                                  
          chain count4 sub01;                                                                       
          if %found;                                                                                
           w1opt = s1opt;                                                                           
           select;                                                                                  
            // Edit                                                                                 
            when s1opt = '2';                                                                       
             exfmt extcall;                                                                         
            // delete                                                                               
            when s1opt = '4';                                                                       
             exfmt extcall;                                                                         
            // display                                                                              
            when s1opt = '5';                                                                       
             exfmt extcall;                                                                         
           endsl;                                                                                   
           clear s1opt;                                                                             
           update sub01;                                                                            
          endif;                                                                                    
         endfor;                                                                                    
                                                                                                    
         //check subfile #2                                                                         
         for count4 = 1 to savrrn2;                                                                 
          chain count4 sub02;                                                                       
          if %found;                                                                                
           w1opt = s2opt;                                                                           
           select;                                                                                  
            // Edit                                                                                 
            when s2opt = '2';                                                                       
             exfmt extcall;                                                                         
            // delete                                                                               
            when s2opt = '4';                                                                       
             exfmt extcall;                                                                         
            // display                                                                              
            when s2opt = '5';                                                                       
             exfmt extcall;                                                                         
           endsl;                                                                                   
           clear s2opt;                                                                             
           update sub02;                                                                            
          endif;                                                                                    
         endfor;                                                                                    
                                                                                                    
       endsr;                                                                                       
       //===========================================                                                
       //  $ClearSFL- Clear the route error sub                                                     
       //===========================================                                                
       begsr $clearsfl;                                                                             
                                                                                                    
         *in31  = *Off;                                                                             
         *in32  = *Off;                                                                             
         *in30  = *On;                                                                              
                                                                                                    
         write SUB01CTL;                                                                            
                                                                                                    
         *in31  = *On;                                                                              
         *in32  = *On;                                                                              
         *in30  = *Off;                                                                             
                                                                                                    
         clear RRN1;                                                                                
         clear SCRRN;                                                                               
         clear SavRrn;                                                                              
                                                                                                    
         *in33 = *off;                                                                              
         clear count;                                                                               
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       //  $LoadSfl  - Load up the route errors                                                     
       //===========================================                                                
        begsr $loadsfl;                                                                             
                                                                                                    
         if SavRrn  > *Zeros;                                                                       
          rrn1  = savrrn;                                                                           
          scrrn = savrrn;                                                                           
         endif;                                                                                     
         //                                                                                         
               *in26 = *on;                                                                         
               dou write5 = 5;                                                                      
                write5 +=1;                                                                         
                exsr $kindaFile;                                                                    
                                                                                                    
              // just to show the indicators                                                        
              // this not required just for demo purpose                                            
                if *in25;                                                                           
                 s125 = 'On';                                                                       
                else;                                                                               
                 clear s125;                                                                        
                endif;                                                                              
                if *in26;                                                                           
                 s126 = 'On';                                                                       
                else;                                                                               
                 clear s126;                                                                        
                endif;                                                                              
                if *in27;                                                                           
                 s127 = 'On';                                                                       
                else;                                                                               
                 clear s127;                                                                        
                endif;                                                                              
                if *in28;                                                                           
                 s128 = 'On';                                                                       
                else;                                                                               
                 clear s128;                                                                        
                endif;                                                                              
                                                                                                    
                RRN1  +=1;                                                                          
                SCRRN  = RRN1;                                                                      
                write SUB01;                                                                        
                *in26 = *off;                                                                       
               enddo;                                                                               
               clear Write5;                                                                        
         //                                                                                         
         savrrn = scrrn;                                                                            
                                                                                                    
         //                                                                                         
         //  If no records in subfile then do not disply the subfile.                               
         //                                                                                         
                                                                                                    
         if SavRrn  = *zeros;                                                                       
           *in31 = *off;                                                                            
         endif;                                                                                     
                                                                                                    
         //                                                                                         
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       //  $ClearSFL2-                                                                              
       //===========================================                                                
                                                                                                    
       begsr $clearsfl2;                                                                            
                                                                                                    
         *in35  = *Off;                                                                             
         *in36  = *Off;                                                                             
         *in34  = *On;                                                                              
                                                                                                    
         write SUB01CTL;                                                                            
                                                                                                    
         *in35  = *On;                                                                              
         *in36  = *On;                                                                              
         *in34  = *Off;                                                                             
                                                                                                    
         clear RRN2;                                                                                
         clear SCRRN2;                                                                              
         clear SavRrn2;                                                                             
                                                                                                    
         *in37 = *off;                                                                              
         clear count2;                                                                              
       endsr;                                                                                       
                                                                                                    
       //===========================================                                                
       //  $LoadSfl2 -                                                                              
       //===========================================                                                
        begsr $loadsfl2;                                                                            
                                                                                                    
         if SavRrn2  > *Zeros;                                                                      
          rrn2  = savrrn2;                                                                          
          scrrn2 = savrrn2;                                                                         
         endif;                                                                                     
                                                                                                    
         //                                                                                         
                                                                                                    
               *in28 = *on;                                                                         
               dou write52 = 5;                                                                     
                write52 +=1;                                                                        
                exsr $kindaFile2;                                                                   
                                                                                                    
              // just to show the indicators                                                        
                if *in25;                                                                           
                 s225 = 'On';                                                                       
                else;                                                                               
                 clear s225;                                                                        
                endif;                                                                              
                if *in26;                                                                           
                 s226 = 'On';                                                                       
                else;                                                                               
                 clear s226;                                                                        
                endif;                                                                              
                if *in27;                                                                           
                 s227 = 'On';                                                                       
                else;                                                                               
                 clear s227;                                                                        
                endif;                                                                              
                if *in28;                                                                           
                 s228 = 'On';                                                                       
                else;                                                                               
                 clear s228;                                                                        
                endif;                                                                              
                                                                                                    
                RRN2  +=1;                                                                          
                SCRRN2  = RRN2;                                                                     
                write SUB02;                                                                        
                *in28 = *off;                                                                       
               enddo;                                                                               
               clear Write52;                                                                       
         //                                                                                         
         savrrn2 = scrrn2;                                                                          
                                                                                                    
         //                                                                                         
         //  If no records in subfile then do not disply the subfile.                               
         //                                                                                         
                                                                                                    
         if SavRrn2 = *zeros;                                                                       
           *in35 = *off;                                                                            
         endif;                                                                                     
                                                                                                    
         //                                                                                         
       endsr;                                                                                       
       //===========================================                                                
       //  $KindaF le - this is sorta a file                                                        
       //===========================================                                                
        begsr $KindaFile;                                                                           
          count +=1;                                                                                
          s1field1 = 'I Like Pizza -' +  %char(count);                                              
        endsr;                                                                                      
       //===========================================                                                
       //  $KindaF le - this is sorta a file                                                        
       //===========================================                                                
        begsr $KindaFile2;                                                                          
          count2 +=1;                                                                               
          s2field1 = 'But cheese is better -' +  %char(count2);                                     
        endsr;                                                                                      
       //=================================================                                          
       //  *inzsr - One time run processing                                                         
       //=================================================                                          
       begsr *inzsr;                                                                                
                                                                                                    
         exsr $ClearSFL;                                                                            
         exsr $LoadSFL;                                                                             
         exsr $ClearSFL2;                                                                           
         exsr $LoadSFL2;                                                                            
                                                                                                    
       endsr;                                                                                       
                                                                                                    
      /end-free                                                                                     

Message subfile example


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

      *=======================================================================                      
      * Program Name: MSGSUB                                                                        
      * Description : Message subfile example                                                       
      * Written On  : 06/25/2004                                                                    
      *                                                                                             
      *                                                                                             
      * Modification                                                                                
      * ~~~~~~~~~~~~                                                                                
      * Date        Description                                                                     
      * ~~~~~~~~    ~~~~~~~~~~~                                                                     
      *                                                                                             
      *=========================================================================                    
     H Option(*SrcStmt: *NoDebugIO) DftActGRP(*No)                                                  
      *                                                                                             
      * Display File                                                                                
      * ~~~~~~~~~~~~                                                                                
     FMSGSUBAD  CF   E             WORKSTN                                                          
      *                                                                                             
      * Program Info                                                                                
      *                                                                                             
     D                SDS                                                                           
     D  @PGM                 001    010                                                             
     D  @PARMS               037    039  0                                                          
     D  @MSGID                40     46                                                             
     D  @MSGDTA               91    170                                                             
     D  @JOB                 244    253                                                             
     D  @USER                254    263                                                             
     D  @JOB#                264    269  0                                                          
      *                                                                                             
      * formational data structure  Message subfile                                                 
      *                                                                                             
     D                 DS                        INZ                                                
     D STKCNT                001    004B 0                                                          
     D DTALEN                005    008B 0                                                          
     D ERRCOD                009    012B 0                                                          
      *                                                                                             
      * Subprocedure(s)                                                                             
      * ~~~~~~~~~~~~~~~                                                                             
     D $DayOfWeek      PR            12A                                                            
      *                                                                                             
      *  Field Definitions.                                                                         
      *                                                                                             
     D @Scrn1          S              1    Inz('Y')                                                 
     D Chr8            S             08                                                             
     D ChrField3       S             02                                                             
     D ChrField4       S             02                                                             
     D CmdString       S            256                                                             
     D CmdLength       S             15  5                                                          
     D CurDayofWeek    S             12    Inz(*blanks)                                             
     D DayOfWeek       S             07  0                                                          
     D DayOfWeekTxt    S             12    Inz(*blanks)                                             
     D ISOdate         S               D                                                            
     D Len             S             03  0                                                          
     D ScreenError     S              1                                                             
      *=========================================================================                    
      *  M A I N     L I N E                                                                        
      *=========================================================================                    
     C                   Movel(p)  @PGM          PGMQ                                               
     C                   Z-Add     60.           DTALEN                                             
      *                                                                                             
     C                   Dow       @Scrn1 = 'Y'                                                     
      *                                                                                             
     C                   If        ScreenError = *blanks                                            
     C                   Eval      MSGID = 'GEN0001'                                                
     C                   Eval      MSGDTA = *blanks                                                 
     C                   Exsr      $SNDMSG                                                          
     C                   Endif                                                                      
      *                                                                                             
     C                   Write     MSGCTL                               99                          
     C                   Exfmt     SCRN1                                                            
      *                                                                                             
     C                   Exsr      $CLRMSG                                                          
      *                                                                                             
     C                   Select                                                                     
      *                                                                                             
      * F3 pressed end the program                                                                  
      *                                                                                             
     C                   When      *In03                                                            
     C                   Eval      @Scrn1 = *blanks                                                 
      *                                                                                             
      * F21 Command line entry                                                                      
      *                                                                                             
     C                   When      *In21                                                            
     C                   Call      'QUSCMDLN'                                                       
      *                                                                                             
      * F23 Work with Spooled files                                                                 
      *                                                                                             
     C                   When      *In23                                                            
     C                   Call      'QEZOUTPT'                                                       
      *                                                                                             
      * Other = ENTER key has been pressed.                                                         
      *                                                                                             
     C                   Other                                                                      
      *                                                                                             
     c                   exsr      $Validate                                                        
      *                                                                                             
     C                   Endsl                                                                      
      *                                                                                             
     C                   Enddo                                                                      
      *                                                                                             
     C                   Eval      *Inlr = *On                                                      
     C                   Return                                                                     
     C                   Clear                   ScreenError                                        
      *=========================================================================                    
      *    $Validate - Validate the data from the screen                                            
      *=========================================================================                    
     c     $Validate     Begsr                                                                      
      *                                                                                             
     c                   eval      *In50 = *Off                                                     
     c                   eval      *In51 = *Off                                                     
     c                   eval      *In52 = *Off                                                     
     c                   Clear                   ScreenError                                        
      *                                                                                             
      * validate field number 1     must be length of 6                                             
      *                                                                                             
     c                   eval      Len = %len(%trim(FIELD1))                                        
     c                   if        Len <> 6.                                                        
     c                   eval      MSGID = 'TST0001'                                                
     c                   eval      MSGDTA = %trim(FIELD1)                                           
     c                   exsr      $SNDMSG                                                          
     c                   eval      ScreenError = 'Y'                                                
     c                   eval      *In50 = *On                                                      
     c                   endif                                                                      
      *                                                                                             
      * validate field number 2     must be equal to A, E or  F                                     
      *                                                                                             
     c                   if        FIELD2 <> 'A'                                                    
     c                             and FIELD2 <> 'E'                                                
     c                             and FIELD2 <> 'F'                                                
     c                   eval      MSGID = 'TST0002'                                                
     c                   eval      MSGDTA = %trim(FIELD2)                                           
     c                   exsr      $SNDMSG                                                          
     c                   eval      ScreenError = 'Y'                                                
     c                   eval      *In51 = *On                                                      
     c                   endif                                                                      
      *                                                                                             
      * validate field number 3/4   must be added together to equal 30                              
      *                                                                                             
     c                   if        FIELD3 + FIELD4 <> 30.                                           
     c                   Move      FIELD3        ChrField3                                          
     c                   Move      FIELD4        ChrField4                                          
     c                   eval      %Subst(MSGDTA:1:2) = ChrField3                                   
     c                   eval      %Subst(MSGDTA:3:2) = ChrField4                                   
     c                   eval      MSGID = 'TST0003'                                                
     c                   exsr      $SNDMSG                                                          
     c                   eval      ScreenError = 'Y'                                                
     c                   eval      *In52 = *On                                                      
     c                   endif                                                                      
      *                                                                                             
     c                   endsr                                                                      
      *==============================================================-=============                 
      *    $SndMsg - Send a message to the message subfile                                          
      *=========================================================================                    
     c     $SndMsg       Begsr                                                                      
      *                                                                                             
     c                   call      'QMHSNDPM'                                                       
     c                   parm                    MSGID                                              
     c                   parm                    MSGF                                               
     c                   parm                    MSGDTA                                             
     c                   parm                    DTALEN                                             
     c                   parm                    MSGTYP                                             
     c                   parm                    PGMQ                                               
     c                   parm                    STKCNT                                             
     c                   parm                    MSGKEY                                             
     c                   Parm                    ERRCOD                                             
      *                                                                                             
     c                   endsr                                                                      
      *=========================================================================                    
      *    $ClrMsg - Clear the messages from the screen                                             
      *=========================================================================                    
     c     $ClrMsg       Begsr                                                                      
      *                                                                                             
     c                   call      'QMHRMVPM'                                                       
     c                   parm                    PGMQ                                               
     c                   parm                    STKCNT                                             
     c                   parm                    MSGKY                                              
     c                   parm                    MSGRMV                                             
     c                   parm                    ERRCOD                                             
      *                                                                                             
     c                   endsr                                                                      
      *==================================================================                           
      * *INZSR - Initial one time run subroutine                                                    
      *==================================================================                           
     c     *INZSR        Begsr                                                                      
      *                                                                                             
      * Initialize the message subfile fields                                                       
      *                                                                                             
     c                   Movel     'LBIMSGF'     MSGF             20                                
     c                   Movel     '*LIBL'       MSGLIB           10                                
     c                   Move      MSGLIB        MSGF                                               
     c                   Move      *blanks       MSGKY            04                                
     c                   Move      *blanks       MSGDTA           80                                
     c                   Movel     '*DIAG'       MSGTYP           10                                
     c                   Movel     '*ALL'        MSGRMV           10                                
     c                   Movel     *blanks       MSGID            07                                
      *                                                                                             
     c                   Eval      H1DAY        = $DayOfWeek                                        
     c                   Movel(p)  @PGM          H1PGM                                              
      *                                                                                             
      *                                                                                             
     c                   Endsr                                                                      
      *=========================================================================                    
      * $DayofWeek - Get Day of Week.                                                               
      *=========================================================================                    
     p$DayOfWeek       B                                                                            
     d $DayOfWeek      PI            12A                                                            
     d ISOdate         S               D                                                            
     d DayOfWeek       S             07  0                                                          
     d DayOfWeekTxt    S             12    Inz(*blanks)                                             
      *                                                                                             
     c                   eval      Isodate = %Date()                                                
     c     IsoDate       Subdur    D'1899-12-30' DayofWeek:*D                                       
     c                   Div       7             DayOfWeek                                          
     c                   Mvr                     DayOfWeek                                          
      *                                                                                             
     c                   If        DayOfWeek < 1.                                                   
     c                   Eval      DayOfWeek = DayOfWeek + 7.                                       
     c                   EndIF                                                                      
      *                                                                                             
     c                   Select                                                                     
     c                   When      DayOfWeek = 1.                                                   
     c                   MoveL(p)  'Sunday'      DayofWeekTxt                                       
     c                   When      DayOfWeek = 2.                                                   
     c                   MoveL(p)  'Monday'      DayofWeekTxt                                       
     c                   When      DayOfWeek = 3.                                                   
     c                   MoveL(p)  'Tuesday'     DayofWeekTxt                                       
     c                   When      DayOfWeek = 4.                                                   
     c                   MoveL(p)  'Wednesday'   DayofWeekTxt                                       
     c                   When      DayOfWeek = 5.                                                   
     c                   MoveL(p)  'Thursday'    DayofWeekTxt                                       
     c                   When      DayOfWeek = 6.                                                   
     c                   MoveL(p)  'Friday'      DayofWeekTxt                                       
     c                   When      DayOfWeek = 7.                                                   
     c                   MoveL(p)  'Saturday'    DayofWeekTxt                                       
     c                   EndSL                                                                      
      *                                                                                             
     c                   Return    DayofWeekTxt                                                     
      *                                                                                             
     p$DayOfWeek       E                                                                            
      *-============================================================================================

Subfile that lists all spooled files in an outq and allows them to be copied to local PC hard drive.


Sample from Jamie Flanary posted at 2011-12-17 14:41:15

     H Option(*SrcStmt: *NoDebugIO) DftActGRP(*No)                                                  
      *=======================================================================                      
      * PROGRAM - OUTQR                                                                             
      * PURPOSE - Process spooled files from outqueue(s)                                            
      * WRITTEN -                                                                                   
      * AUTHOR  -                                                                                   
      *                                                                                             
      * PROGRAM DESCRIPTION                                                                         
      *   Process spooled files from outqueue(s)                                                    
      *                                                                                             
      *                                                                                             
      * INPUT PARAMETERS                                                                            
      *   Description        Type  Size    How Used                                                 
      *   -----------        ----  ----    --------                                                 
      *                                                                                             
      *                                                                                             
      * INDICATOR USAGE                                                                             
      *   03 - Cancel current screen and return to previous screen                                  
      *   25 - Rollup                                                                               
      *   26 - RollDown                                                                             
      *   30 - SFLCLR                                                                               
      *   31 - SFLDSP                                                                               
      *   32 - SFLDSPCTL                                                                            
      *   33 - SFLEND                                                                               
      *   34 - SFLCLR2                                                                              
      *   35 - SFLDSP2                                                                              
      *   36 - SFLDSPCTL2                                                                           
      *   37 - SFLEND2                                                                              
      *                                                                                             
      *========================================================================                     
     fOUTQD     cf   e             WORKSTN INFDS(INFDS)                                             
     f                                     SFILE(SUB01:RRN1)                                        
     f                                     SFILE(SUB02:RRN2)                                        
      *                                                                                             
      * Informational data structure.                                                               
      *                                                                                             
     d INFDS           DS                                                                           
     d Choice                369    369                                                             
     d Currec                378    379B 0                                                          
      *                                                                                             
      *  Command Keys                                                                               
      *                                                                                             
     d Cmd01           c                   const(x'31')                         Cmd-1               
     d Cmd02           c                   const(x'32')                         Cmd-2               
     d LeaveProgram    c                   const(x'33')                         Cmd-3               
     d Prompt          c                   const(x'34')                         Cmd-4               
     d Refresh         c                   const(x'35')                         Cmd-5               
     d Cmd06           c                   const(x'36')                         Cmd-6               
     d Cmd07           c                   const(x'37')                         Cmd-7               
     d Cmd08           c                   const(x'38')                         Cmd-8               
     d Cmd09           c                   const(x'39')                         Cmd-9               
     d Cmd10           c                   const(x'3A')                         Cmd-10              
     d Cmd11           c                   const(x'3B')                         Cmd-11              
     d Cmd12           c                   const(x'3C')                         Cmd-12              
     d Cmd13           c                   const(x'B1')                         Cmd-13              
     d Cmd14           c                   const(x'B2')                         Cmd-14              
     d Cmd15           c                   const(x'B3')                         Cmd-15              
     d Cmd16           c                   const(x'B4')                         Cmd-16              
     d Cmd17           c                   const(x'B5')                         Cmd-17              
     d Cmd18           c                   const(x'B6')                         Cmd-18              
     d Cmd19           c                   const(x'B7')                         Cmd-19              
     d Cmd20           c                   const(x'B8')                         Cmd-20              
     d Cmd21           c                   const(x'B9')                         Cmd-21              
     d Cmd22           c                   const(x'BA')                         Cmd-22              
     d Cmd23           c                   const(x'BB')                         Cmd-23              
     d Cmd24           c                   const(x'BC')                         Cmd-24              
     d EnterKey        c                   const(x'F1')                                             
     d RollUp          c                   const(x'F5')                         Roll Up             
     d RollDown        c                   const(x'F4')                         Roll Down           
                                                                                                    
      * Program Info                                                                                
      *                                                                                             
     d                SDS                                                                           
     d  @PGM                 001    010                                                             
     d  @PARMS               037    039  0                                                          
     d  @JOB                 244    253                                                             
     d  @USER                254    263                                                             
     d  @JOB#                264    269  0                                                          
      *                                                                                             
      *  Field Definitions.                                                                         
      *                                                                                             
     D NotAuthorized   c                   00202                                                    
     d Cmdstring       s           1024                                                             
     d Cmdlength       s             15  5                                                          
     d Count           s              4  0                                                          
     d Counter         s              7  0                                                          
     d CYMD            s              7  0                                                          
     d digits          c                   const('0123456789')                                      
     d EndScreen1      s               n                                                            
     d EndScreen2      s               n                                                            
     d Format          s              8                                                             
     d GenLen          s              8                                                             
     d ISODate         s               D                                                            
     d JobInfo         s            512    inz(*blanks)                                             
     d LenStr          s              4  0                                                          
     d Lo              c                   CONST('abcdefghijklmnopqrstuvwxyz')                      
     d MSGF            s             20    inz('LBIMSG    *LIBL')                                   
     d MSGKY           s              4                                                             
     d MSGDTA          s             80                                                             
     d MSGTYP          s             10    inz('*DIAG')                                             
     d MSGRMV          s             10    inz('*ALL')                                              
     d MSGID           s              7                                                             
     d MYSPACE         c                   const('SPLFLIST  QTEMP     ')                            
     d mystatus        s              5  0                                                          
     d Normal          c                   X'20'                                                    
     d ObjectLib       s             20                                                             
     d Q               s              1    inz('''')                                                
     d RRN1            s                   like(SCRRN)                                              
     d RRN2            s                   like(SCRRN)                                              
     d ReloadSUB01     s               n                                                            
     d ReloadSUB02     s               n                                                            
     d SavRrn          s                   like(SCRRN)                                              
     d SavRrn2         s                   like(SCRRN)                                              
     d ScreenError     s               n                                                            
     d size            s             10I 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 SQ              s              1    inz('''')                                                
     d Title           s             40                                                             
     d Up              c                   CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')                      
     d UserSpaceOut    s             20                                                             
     d Worktype        s             10    inz('*OUTQ')                                             
     d White           c                   X'22'                                                    
     d WorkISO         s               D                                                            
     d wJobName        s             10    inz(*blanks)                                             
     d wSPLFName       s             10    inz(*blanks)                                             
     d wUserData       s             10    inz(*blanks)                                             
     d YMD             s              6  0                                                          
      *                                                                                             
      * map network drive (IFS) for copy parms                                                      
      *                                                                                             
     d Data            s           4096                                                             
     d Parm1Srv        s             15    Inz(X'00001000')                                         
     d LstI            s             64                                                             
     d Parm2Srv        s              8    Inz('ZLSL0201')                                          
     d Parm3Srv        s             15    Inz('               ')                                   
     d Parm4Srv        s             15    Inz(X'00000000')                                         
     d SerVer          s             15                                                             
     d SharePath       s             25                                                             
     d ShareName       s             12                                                             
     d ShareText       s             50                                                             
     d PathLength      s             10i 0                                                          
     d PathCCSID       s             10i 0                                                          
     d MaxUsers        s             10i 0                                                          
     d Permission      s             10i 0                                                          
     d NetDrive        s              1    inz('W')                                                 
                                                                                                    
      * formational data structure  Message subfile                                                 
      *                                                                                             
     d                 ds                        inz                                                
     d STKCNT                        10i 0                                                          
     d DTALEN                        10i 0                                                          
     d ERRCOD                        10i 0                                                          
      *                                                                                             
      * API - List spooled files                                                                    
      *                                                                                             
     d QUSLSPL         PR                  extpgm('QUSLSPL')                                        
      * required parameters                                                                         
     d   UsrSpc                      20A   const                                                    
     d   Format                       8A   const                                                    
     d   UserName                    10A   const                                                    
     d   QualOutQ                    20A   const                                                    
     d   FormType                    10A   const                                                    
     d   UserData                    10A   const                                                    
      * optional group 1:                                                                           
     d   ErrorCode                32766A   options(*nopass: *varsize)                               
      * optional group 2:                                                                           
     d   QualJob                     26A   options(*nopass) const                                   
     d   FieldKeys                   10I 0 options(*nopass: *varsize)                               
     d                                     dim(9999)                                                
     d   NumFields                   10I 0 options(*nopass) const                                   
      * optional group 3:                                                                           
     d   AuxStgPool                  10I 0 options(*nopass) const                                   
      * optional group 4:                                                                           
     d   JobSysName                   8A   options(*nopass) const                                   
     d   StartCrtDate                 7A   options(*nopass) const                                   
     d   StartCrtTime                 6A   options(*nopass) const                                   
     d   EndCrtDate                   7A   options(*nopass) const                                   
     d   EndCrtTime                   6A   options(*nopass) const                                   
      *                                                                                             
     d QUSCRTUS        PR                  extpgm('QUSCRTUS')                                       
     d   UsrSpc                      20A   const                                                    
     d   ExtAttr                     10A   const                                                    
     d   InitialSize                 10I 0 const                                                    
     d   InitialVal                   1A   const                                                    
     d   PublicAuth                  10A   const                                                    
     d   Text                        50A   const                                                    
     d   Replace                     10A   const                                                    
     d   ErrorCode                32766A   options(*nopass: *varsize)                               
      *                                                                                             
     d QUSPTRUS        PR                  extpgm('QUSPTRUS')                                       
     d   UsrSpc                      20A   const                                                    
     d   Pointer                       *                                                            
      *                                                                                             
     d QUSDLTUS        PR                  extpgm('QUSDLTUS')                                       
     d   UsrSpc                      20A   const                                                    
     d   ErrorCode                32766A   options(*varsize)                                        
      *                                                                                             
     d p_UsrSpc        s               *                                                            
     d dsLH            DS                   based(p_UsrSpc)                                         
     d                                      qualified                                               
     d   Filler1                    103A                                                            
     d   Status                       1A                                                            
     d   Filler2                     12A                                                            
     d   HdrOffset                   10I 0                                                          
     d   HdrSize                     10I 0                                                          
     d   ListOffset                  10I 0                                                          
     d   ListSize                    10I 0                                                          
     d   NumEntries                  10I 0                                                          
     d   EntrySize                   10I 0                                                          
      *                                                                                             
     d p_Entry         s               *                                                            
     d dsSF            DS                   based(p_Entry)                                          
     d                                      qualified                                               
     d   JobName                     10A                                                            
     d   UserName                    10A                                                            
     d   JobNumber                    6A                                                            
     d   SplfName                    10A                                                            
     d   SplfNbr                     10I 0                                                          
     d   SplfStatus                  10I 0                                                          
     d   OpenDate                     7A                                                            
     d   OpenTime                     6A                                                            
     d   Schedule                     1A                                                            
     d   SysName                     10A                                                            
     d   UserData                    10A                                                            
     d   FormType                    10A                                                            
     d   OutQueue                    10A                                                            
     d   OutQueueLib                 10A                                                            
     d   AuxPool                     10I 0                                                          
     d   SplfSize                    10I 0                                                          
     d   SizeMult                    10I 0                                                          
      *                                                                                             
     d   TotalPages                  10I 0                                                          
     d   CopiesLeft                  10I 0                                                          
     d   Priority                     1A                                                            
     d   Reserved                     3A                                                            
      *                                                                                             
     d dsEC            DS                  qualified                                                
     d  BytesProvided                10I 0 inz(%size(dsEC))                                         
     d  BytesAvail                   10I 0 inz(0)                                                   
     d  MessageID                     7A                                                            
     d  Reserved                      1A                                                            
     d  MessageData                 240A                                                            
      *                                                                                             
     d OutQName        ds                                                                           
     d   OutQ                        10A                                                            
     d   OutQLib                     10A   inz('*LIBL')                                             
     ‚*                                                                                             
     ‚* Some working environment                                                                    
     ‚* ~~~~~~~~~~~~~~~~~~~~~~~~                                                                    
     D ObjNam          s             10a                                                            
     D ObjLib          s             10a                                                            
     D ObjTyp          s             10a                                                            
     **-- Api error data structure:  ----------------------------------                             
     D ApiError        Ds                                                                           
     D  AeBytPro                     10i 0 Inz( %Size( ApiError ))                                  
     D  AeBytAvl                     10i 0 Inz                                                      
     D  AeMsgId                       7a                                                            
     D                                1a                                                            
     D  AeMsgDta                    128a                                                            
     **-- Object description structure OBJD0200:  ---------------------                             
     D RoData          Ds                                                                           
     D  RoBytRtn                     10i 0                                                          
     D  RoBytAvl                     10i 0                                                          
     D  RoObjNam                     10a                                                            
     D  RoObjLib                     10a                                                            
     D  RoObjTypRt                   10a                                                            
     D  RoObjLibRt                   10a                                                            
     D  RoObjASP                     10i 0                                                          
     D  RoObjOwn                     10a                                                            
     D  RoObjDmn                      2a                                                            
     D  RoObjCrtDts                  13a                                                            
     D  RoObjChgDts                  13a                                                            
     D  RoExtAtr                     10a                                                            
     D  RoTxtDsc                     50a                                                            
     D  RoSrcF                       10a                                                            
     D  RoSrcLib                     10a                                                            
     D  RoSrcMbr                     10a                                                            
     **-- 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 )                                
     ‚*                                                                                             
     dTheData          DS                                                                           
     ‚*                                                                                             
     d QUSBR05                 1      4B 0                                                          
     d QUSBA05                 5      8B 0                                                          
     d QUSJN08                 9     18                                                             
     d QUSUN07                19     28                                                             
     d QUSJNBR07              29     34                                                             
     d QUSIJID05              35     50                                                             
     d QUSJS14                51     60                                                             
     d QUSJT08                61     61                                                             
     d QUSJS15                62     62                                                             
     d QUSJS16                63     70                                                             
     d QUSES00                71     71                                                             
     d QUSSN00                72     81                                                             
     d QUSSL06                82     91                                                             
     d QUSCUN                 92    101                                                             
     d QUSDE                 102    102                                                             
     d QUSEK                 103    103                                                             
     d QUSCK00               104    104                                                             
     d QUSPRC                105    108B 0                                                          
     d QUSURC                109    112B 0                                                          
     d QUSPGMRC              113    116B 0                                                          
     d QUSSE02               117    126                                                             
     d QUSDN                 127    136                                                             
     d QUSGPN                137    146                                                             
     d QUSGRP                        10    DIM(00015)                                               
     d  QUSGN00                      10    OVERLAY(QUSGRP:00001)                                    
     d QUSJUID               297    306                                                             
     d QUSJUIDS              307    307                                                             
‚     *                                                                                            €
‚     * GenHdr                                                                                     €
‚     *                                                                                            €
     d GenHdr          ds                  inz                                                      
     d  OffSet                 1      4B 0                                                          
     d  NumEnt                 9     12B 0                                                          
     d  Lstsiz                13     16B 0                                                          
‚     *                                                                                            €
‚     *  Data structures                                                                           €
‚     *                                                                                            €
     d GENDS           ds                                                                           
     d  OffsetHdr              1      4B 0                                                          
     d  NbrInList              9     12B 0                                                          
     d  SizeEntry             13     16B 0                                                          
      *                                                                                             
      *                                                                                             
      *                                                                                             
     d HeaderDs        ds                                                                           
     d  OutFileNam             1     10                                                             
     d  OutLibName            11     20                                                             
     d  OutType               21     25                                                             
     d  OutFormat             31     40                                                             
     d  RecordLen             41     44B 0                                                          
      *                                                                                             
      * API Error Data Structure                                                                    
      *                                                                                             
     d ErrorDs         DS                  INZ                                                      
     d  BytesPrv               1      4B 0                                                          
     d  BytesAvl               5      8B 0                                                          
     d  MessageId              9     15                                                             
     d  ERR###                16     16                                                             
     d  MessageDta            17    116                                                             
      *                                                                                             
      * Create userspace datastructure                                                              
      *                                                                                             
     d                 DS                                                                           
     d  StartPosit             1      4B 0                                                          
     d  StartLen               5      8B 0                                                          
     d  SpaceLen               9     12B 0                                                          
     d  ReceiveLen            13     16B 0                                                          
     d  MessageKey            17     20B 0                                                          
     d  MsgDtaLen             21     24B 0                                                          
     d  MsgQueNbr             25     28B 0                                                          
      *                                                                                             
      * 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 ObjectDs        ds                                                                           
     d  Object                       10                                                             
     d  Library                      10                                                             
     d  ObjectType                   10                                                             
     d  InfoStatus                    1                                                             
     d  ExtObjAttrib                 10                                                             
     d  Description                  50                                                             
      *                                                                                             
     c                   exsr      Hskpg                                                            
      *                                                                                             
      * Load up the subfile (Show all Non-Routed production Orders)                                 
      *                                                                                             
     c                   exsr      $Screen1                                                         
      *                                                                                             
      * remove the mapped drive leave the share ;)                                                  
      *                                                                                             
     c                   eval      cmdstring = 'strpccmd ' + Q +                                    
     c                             'net use '                                                       
     c                             + %trim(NetDrive)                                                
     c                             + ': /delete'+ Q +' pause(*yes)'                                 
      *                                                                                             
     c                   eval      cmdlength = %len(%trim(cmdstring))                               
     c                   call(e)   'QCMDEXC'                                                        
     c                   parm                    cmdstring                                          
     c                   parm                    cmdlength                                          
      *                                                                                             
     c                   Eval      *Inlr = *On                                                      
      *                                                                                             
      *===========================================                                                  
      *  $Screen1 - Display subfile of all routes                                                   
      *             in error                                                                        
      *===========================================                                                  
      *                                                                                             
     c     $Screen1      begsr                                                                      
      *                                                                                             
     c                   reset                   EndScreen1                                         
     c                   dow       EndScreen1 = *off                                                
      *                                                                                             
     c                   if        ScreenError = *off                                               
     c                   exsr      $CLRMSG                                                          
     c                   endif                                                                      
      *                                                                                             
     c                   write     FKEY01                                                           
     c                   write(e)  MSGCTL                                                           
     c                   exfmt     SUB01CTL                                                         
     c                   exsr      $clrmsg                                                          
     c                   if        Currec <> *Zeros                                                 
     c                   eval      RRN1    =  Currec                                                
     c                   eval      SCRRN   =  Currec                                                
     c                   endif                                                                      
     c                   reset                   ScreenError                                        
      *                                                                                             
     c                   select                                                                     
      *                                                                                             
      * F3 pressed end the program F3 = LeaveProgram                                                
      *                                                                                             
     c                   when      Choice = LeaveProgram                                            
     c                   eval      EndScreen1 = *on                                                 
      *                                                                                             
      * F4 pressed prompt screen requested                                                          
      *                                                                                             
     c                   when      Choice = Prompt                                                  
     c                   exsr      $Prompt                                                          
      *                                                                                             
      * F5 refresh spooled files                                                                    
      *                                                                                             
     c                   when      Choice = Refresh                                                 
     c                   exsr      $clearSFL                                                        
     c                   exsr      $Loadsfl                                                         
      *                                                                                             
      * pagedown/rollup                                                                             
      *                                                                                             
     c                   when      Choice = Rollup                                                  
     c                   exsr      $Loadsfl                                                         
      *                                                                                             
      *  ENTER key has been pressed.                                                                
      *                                                                                             
     c                   when      Choice  = EnterKey                                               
     c                   if        C1OUTQ  <> H1OUTQ and                                            
     c                             C1OUTQ  <> *blanks                                               
     c                   eval      H1OUTQ  = C1OUTQ                                                 
     c                   eval      outq    = C1OUTQ                                                 
     c                   eval      OutQLib = H1LIBRARY                                              
     c                   eval      c1outqnow   = C1OUTQ                                             
     c                   clear                   C1OUTQ                                             
     c                   exsr      $clearSFL                                                        
     c                   exsr      $Loadsfl                                                         
     c                   else                                                                       
     c                   exsr      $Process                                                         
     c                   endif                                                                      
      *                                                                                             
     c                   endsl                                                                      
      *                                                                                             
     c                   enddo                                                                      
      *                                                                                             
     c                   endsr                                                                      
      *===========================================                                                  
      *  $ClearSFL- Clear the route error sub                                                       
      *===========================================                                                  
     cSR   $ClearSfl     Begsr                                                                      
      *                                                                                             
     c                   eval      *in31           = *Off                                           
     c                   eval      *in32           = *Off                                           
     c                   eval      *in30           = *On                                            
      *                                                                                             
     c                   write     SUB01CTL                                                         
      *                                                                                             
     c                   eval      *in31           = *On                                            
     c                   eval      *in32           = *On                                            
     c                   eval      *in30           = *Off                                           
      *                                                                                             
     c                   clear                   RRN1                                               
     c                   clear                   SCRRN                                              
     c                   clear                   SavRrn                                             
      *                                                                                             
     c                   clear                   S1OPT                                              
      *                                                                                             
      * delete user space                                                                           
      *                                                                                             
      /free                                                                                         
          monitor;                                                                                  
           QUSDLTUS(MYSPACE: dsEC);                                                                 
          on-error;                                                                                 
          endmon;                                                                                   
      /end-free                                                                                     
      *                                                                                             
      *                                                                                             
      * set this to zero to let OS/400 handle errors                                                
      *                                                                                             
     c                   eval      dsEC.BytesProvided = 0                                           
      *                                                                                             
      * Make space for (approx) 1000 spooled files to be listed                                     
      *                                                                                             
     c                   eval      size = %size(dsLH) + 512 +                                       
     c                                    (%size(dsSF) * 1000)                                      
      *                                                                                             
      * Create a user space                                                                         
      * List spooled files to the user space                                                        
      * Get a pointer to the returned user space                                                    
      *                                                                                             
      /free                                                                                         
         // Create a user space                                                                     
         QUSCRTUS(MYSPACE: 'USRSPC': size: x'00': '*ALL':                                           
          'Temp User Space for QUSLSPL API':  '*YES': dsEC);                                        
                                                                                                    
         // List spooled files to the user space                                                    
         monitor;                                                                                   
         QUSLSPL(MYSPACE: 'SPLF0300': '*ALL': OutQName:                                             
            '*ALL': '*ALL': dsEC );                                                                 
         On-error NotAuthorized;                                                                    
          // shows how to get the status number                                                     
         mystatus = %status;                                                                        
                                                                                                    
         endmon;                                                                                    
                                                                                                    
         // Get a pointer to the returned user space                                                
         QUSPTRUS(MYSPACE: p_UsrSpc);                                                               
      /end-free                                                                                     
      *                                                                                             
     c                   endsr                                                                      
      *                                                                                             
      *===========================================                                                  
      *  $LoadSfl  - Load up the route errors                                                       
      *===========================================                                                  
     cSR   $LoadSFL      begsr                                                                      
      *                                                                                             
     c                   if        SavRrn  > *Zeros                                                 
     c                   z-add     SavRrn        RRN1                                               
     c                   z-add     SavRrn        SCRRN                                              
     c                   endif                                                                      
      *                                                                                             
      * Loop through list, for each spooled file, display the                                       
      * Status: 1=RDY , 2=OPN, 3=CLO, 4=SAV, 5=WRT, 6=HLD,                                          
      *         7=MSGW, 8=PND, 9=PRT,10=FIN,11=SND,12=DFR                                           
      *                                                                                             
     c                   eval      p_Entry = p_UsrSpc + dsLH.ListOffset                             
                                                                                                    
     c                   do        10                                                               
                                                                                                    
     c                   if        RRN1 = dsLH.NumEntries                                           
     c                   eval      *in33      = *On                                                 
     c                   endif                                                                      
      *                                                                                             
     c                   eval      S1JOB     = dsSF.jobname                                         
     c                   eval      S1USER    = dsSF.username                                        
     c                   eval      S1JOB#    = dsSF.jobnumber                                       
     c                   eval      S1SPOOLNM = dsSF.splfname                                        
      *                                                                                             
      * make spool status readable                                                                  
      *                                                                                             
     c                   select                                                                     
     c                   when      dsSF.SplfStatus = 1                                              
     c                   eval      S1SPOOLSTS = 'RDY'                                               
     c                   when      dsSF.SplfStatus = 2                                              
     c                   eval      S1SPOOLSTS = 'OPN'                                               
     c                   when      dsSF.SplfStatus = 3                                              
     c                   eval      S1SPOOLSTS = 'CLO'                                               
     c                   when      dsSF.SplfStatus = 4                                              
     c                   eval      S1SPOOLSTS = 'SAV'                                               
     c                   when      dsSF.SplfStatus = 5                                              
     c                   eval      S1SPOOLSTS = 'WRT'                                               
     c                   when      dsSF.SplfStatus = 6                                              
     c                   eval      S1SPOOLSTS = 'HLD'                                               
     c                   when      dsSF.SplfStatus = 7                                              
     c                   eval      S1SPOOLSTS = 'MSG'                                               
     c                   when      dsSF.SplfStatus = 8                                              
     c                   eval      S1SPOOLSTS = 'PND'                                               
     c                   when      dsSF.SplfStatus = 9                                              
     c                   eval      S1SPOOLSTS = 'PRT'                                               
     c                   when      dsSF.SplfStatus = 10                                             
     c                   eval      S1SPOOLSTS = 'FIN'                                               
     c                   when      dsSF.SplfStatus = 11                                             
     c                   eval      S1SPOOLSTS = 'SND'                                               
     c                   when      dsSF.SplfStatus = 12                                             
     c                   eval      S1SPOOLSTS = 'DFR'                                               
     c                   endsl                                                                      
      *                                                                                             
      * date is *char CYMD                                                                          
      *                                                                                             
     c                   if        %Check(Digits : dsSF.opendate ) = 0                              
     c                   eval      CYMD = %dec(dsSF.opendate:7:0)                                   
     c                   endif                                                                      
     c     *CYMD         test(de)                CYMD                                               
     c                   if        not%error                                                        
     c                                                                                              
     c                   eval      S1SPOOLDT =                                                      
     c                             %uns(%char(%Date(CYMD:*CYMD)                                     
     c                             :*MDY0))                                                         
     c                   endif                                                                      
      *                                                                                             
     c                   eval      S1PAGES = dsSF.TotalPages                                        
     c                   eval      H1SPOOL# = dsSF.splfnbr                                          
      *                                                                                             
     c                   eval      RRN1  +=1                                                        
     c                   eval      SCRRN  = RRN1                                                    
     c                   write     SUB01                                                            
      *                                                                                             
     c                   eval      p_Entry = p_Entry + dsLH.EntrySize                               
     c                   enddo                                                                      
      *                                                                                             
      *                                                                                             
     c                   z-add     SCRRN         SavRrn                                             
      *                                                                                             
      *  If no records in subfile then do not disply the subfile.                                   
      *                                                                                             
     c                   if        SavRrn  = *Zeros  And   *in33                                    
     c                   eval      *in31 = *off                                                     
     c                   endif                                                                      
     c                                                                                              
      *                                                                                             
     c                   endsr                                                                      
      *===========================================                                                  
      * $Process - Process the subfile(s)                                                           
      *===========================================                                                  
     c     $Process      begsr                                                                      
      *                                                                                             
     c                   reset                   ScreenError                                        
     c                   reset                   ReloadSub01                                        
      *                                                                                             
      *  Check for changes in subfile01 - route errors                                              
      *                                                                                             
     c                   for       count = 1 to Savrrn                                              
     c     count         chain     SUB01                                                            
     c                   if        %Found                                                           
      *                                                                                             
     c                   select                                                                     
     c                   when      s1opt = 'G'                                                      
     c                   exsr      $ToPDF          

Attached is a simple example of a load entire subfile. It used message subfile and also the hex values for the function keys. If anyone is interested in expanding the example let me know and we can start a seperate forum.


Sample from Jamie Flanary posted at 2011-12-16 19:43:03

      *=====================================================
      * PROGRAM - RPG
      * PURPOSE - List members in source file QRPGLESRC
      *
      * PROGRAM DESCRIPTION
      *   This program will list members in a source file
      *   to a subfile.
      *
      *
      * INPUT PARAMETERS
      *   Description        Type  Size    How Used
      *   -----------        ----  ----    --------
      *
      * INDICATOR USAGE
      *   n/a
      *
      *=====================================================
     fRPGD      cf   e             workstn INFDS(INFDS)
     f                                     SFILE(SUB01:RRN1)
      // Data Structures
     d Infds           ds
     d Choice                369    369
     d Currec                378    379B 0

      // Command Keys
     d Cmd01           c                   const(x'31')                         Cmd-1
     d Cmd02           c                   const(x'32')                         Cmd-2
     d LeaveProgram    c                   const(x'33')                         Cmd-3
     d Cmd04           c                   const(x'34')                         Cmd-4
     d Cmd05           c                   const(x'35')                         Cmd-5
     d Cmd06           c                   const(x'36')                         Cmd-6
     d Cmd07           c                   const(x'37')                         Cmd-7
     d Cmd08           c                   const(x'38')                         Cmd-8
     d Cmd09           c                   const(x'39')                         Cmd-9
     d Cmd10           c                   const(x'3A')                         Cmd-10
     d Cmd11           c                   const(x'3B')                         Cmd-11
     d Cmd12           c                   const(x'3C')                         Cmd-12
     d Cmd13           c                   const(x'B1')                         Cmd-13
     d Cmd14           c                   const(x'B2')                         Cmd-14
     d Cmd15           c                   const(x'B3')                         Cmd-15
     d Cmd16           c                   const(x'B4')                         Cmd-16
     d Cmd17           c                   const(x'B5')                         Cmd-17
     d Cmd18           c                   const(x'B6')                         Cmd-18
     d Cmd19           c                   const(x'B7')                         Cmd-19
     d Cmd20           c                   const(x'B8')                         Cmd-20
     d Cmd21           c                   const(x'B9')                         Cmd-21
     d Cmd22           c                   const(x'BA')                         Cmd-22
     d Cmd23           c                   const(x'BB')                         Cmd-23
     d Cmd24           c                   const(x'BC')                         Cmd-24
     d EnterKey        c                   const(x'F1')
     d RollUp          c                   const(x'F5')                         Roll Up
     d RollDown        c                   const(x'F4')                         Roll Down
      *
      * Program Info
      *
     d                SDS
     d  @PGM                 001    010
     d  @PARMS               037    039  0
     d  @MSGDTA               91    170
     d  @MSGID               171    174
     d  @JOB                 244    253
     d  @USER                254    263
     d  @JOB#                264    269  0

      // constants
      //
      *
      *  Field Definitions.
      *
     d @Scrn1          s              1    inz('Y')
     d AllMembers      s             10a   inz('*ALL')
     d ApiFile         s             10    inz('QRPGLESRC')
     d ApiLibrary      s             10    inz('*LIBL')
     d ApiMember       s             10
     d bOvr            s              1a   inz('0')
     d cmdstring       s            256
     d cmdlength       s             15  5
     d Digits          c                   const('01235456789')
     d FileLib         s             20a
     d Format          s              8a
     d IsoDate         s               D
     d LenStr          s              4  0
     d MemberName      s             10
     d MESSAGEKY       s              4
      *
     d MSGF            s             20    inz('QCPFMSG   *LIBL')
     d MSGKY           s              4
     d MSGDTA          s             80
     d MSGTYP          s             10    inz('*DIAG')
     d MSGRMV          s             10    inz('*ALL')
     d MSGID           s              7
      *
     d nBufLen         s             10i 0
     d ObjectLib       s             10
     d ReceiverLen     s              9b 0 inz(100)
     d Reloadsub01     s              1
     d RRN1            s                   like(SCRRN)
     d SavRrn          s                   like(SCRRN)
     d Screenerror     s              1    inz('N')
     d sizelist        S             10i 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 Title           s             40
     d Title30         s             30
     d UserSpaceOut    s             20
     d WorkDate8       s              8  0
      *
      * 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
      *
      * Create userspace datastructure
      *
     d                 DS
     d  StartPosit             1      4B 0
     d  StartLen               5      8B 0
     d  SpaceLen               9     12B 0
     d  ReceiveLen            13     16B 0
     d  MessageKey            17     20B 0
     d  MsgDtaLen             21     24B 0
     d  MsgQueNbr             25     28B 0
      *
      * 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
      *
      *  Data structure for the retrieve user space command
      *
     d GENDS           DS
     d  OffsetHdr            117    120B 0
     d  SizeHeader           121    124B 0
     d  OffsetList           125    128B 0
     d  NbrInList            133    136B 0
     d  SizeEntry            137    140B 0
      *
      * Datastructure for retrieving elements from userspace
      *
     d HeaderDs        DS
     d  OutFileNam             1     10
     d  OutLibName            11     20
     d  OutType               21     25
     d  OutFormat             31     40
     d  RecordLen             41     44B 0
      *
      * List the members
      *
     d ListDs          DS
     d  LmMember                     10
     d  LmType                       10
     d  LmCreationDt                  7
     d  LmCreationTm                  6
     d  LmLastChgDt                   7
     d  LmLastChgTm                   6
     d  LmDescription                50
      *
      * 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
      *
      * formational data structure  Message subfile
      *
     d                 DS                        INZ
     d STKCNT                        10i 0
     d DTALEN                        10i 0
     d ERRCOD                        10i 0
      *

      *===========================================
      * MAIN LINE
      *===========================================

     c                   exsr      $ListMembers
     c                   exsr      $ClearSFL
     c                   exsr      $LoadSFL

     c                   dow       @Scrn1 = 'Y'
     c                   if        screenerror = 'N'
     c                   exsr      $CLRMSG
     c                   endif

     c                   write     fkey01
     c                   write(e)  msgctl
     c                   exfmt     sub01ctl
     c                   exsr      $CLRMSG
     c                   select
     c                   when      Choice = LeaveProgram
     c                   clear                   @Scrn1
     c                   other
     c                   reset                   screenerror
     c                   endsl
     c                   enddo

     c                   eval      *inlr = *on

      *===========================================
      *  $Listmembers - list members to userspace
      *===========================================
     c     $ListMembers  begsr
      *
      *
     c                   eval      FileLib     = ApiFile  + ApiLibrary
      *
      * Now List the members of this source file to a userspace
      *
     c                   exsr      $QUSCRTUS
      *
     c                   eval      MemberName = '*ALL'
     c                   eval      Format  = 'MBRL0200'
     c                   exsr      $QUSLMBR
      *
      *  Read back the members
      *
     c                   eval      StartPosit = 1
     c                   eval      StartLen = 140
      *
      * First call to get data offsets(start)
      *
     c                   call(e)   'QUSRTVUS'
     c                   parm                    UserSpaceOut
     c                   parm                    StartPosit
     c                   parm                    StartLen
     c                   parm                    GENDS
     c                   parm                    APIError
      *
      * Then call to get number of entries
      *
     c                   eval      StartPosit = OffsetHdr + 1
     c                   eval      StartLen = SizeHeader
      *
     c                   call(e)   'QUSRTVUS'
     c                   parm                    UserSpaceOut
     c                   parm                    StartPosit
     c                   parm                    StartLen
     c                   parm                    HeaderDs
     c                   parm                    ApiError
      *
     c                   eval      StartPosit = OffsetList + 1
     c                   eval      StartLen = SizeEntry
      *
     c                   endsr
      *===========================================
      *  $ClearSFL- Clear the route error sub
      *===========================================
     cSR   $ClearSfl     Begsr
      *
     c                   eval      *in31           = *Off
     c                   eval      *in32           = *Off
     c                   eval      *in30           = *On
      *
     c                   write     SUB01CTL
      *
     c                   eval      *in31           = *On
     c                   eval      *in32           = *On
     c                   eval      *in30           = *Off
      *
     c                   clear                   RRN1
     c                   clear                   SCRRN
     c                   clear                   SavRrn
      *
     c                   clear                   S1OPT
      *
     c                   endsr
      *
      *===========================================
      *  $LoadSfl  - Load up the route errors
      *===========================================
     cSR   $LoadSFL      begsr
      *
     c                   if        SavRrn  > *Zeros
     c                   z-add     SavRrn        RRN1
     c                   z-add     SavRrn        SCRRN
     c                   endif
      *
      *  Do for number of members
      *
     c                   do        NbrInList
     c                   call(e)   'QUSRTVUS'
     c                   parm                    UserSpaceOut
     c                   parm                    StartPosit
     c                   parm                    StartLen
     c                   parm                    ListDs
     c                   parm                    ApiError
      *
     c                   eval      s1name = lmmember
     c                   eval      s1type = lmtype
     c                   eval      s1desc = LmDescription
      *
     c                   eval      RRN1  +=1
     c                   eval      SCRRN  = RRN1
     c                   write     SUB01
      *
      *
     c                   eval      StartPosit = StartPosit + SizeEntry
     c                   enddo
      *
     c                   eval      *in33      = *On
     c                   z-add     SCRRN         SavRrn
      *
      *  If no records in subfile then do not disply the subfile.
      *
     c                   if        SavRrn  = *zeros  and  *in33
     c                   eval      *in31 = *off
     c                   else
     c                   eval      RRN1  = 1.
     c                   eval      SCRRN  = 1.
     c                   endif
     c
      *
     c                   endsr
      *========================================================================
      * $QUSCRTUS - API to create user space
      *========================================================================
     c     $QUSCRTUS     begsr
      *
      * Create a user space named ListMember in QTEMP.
      *
     c                   Eval      ApiError.BytesP   = 116
     c                   movel(p)  'MEMBERS'     SpaceName
     c                   movel(p)  'QTEMP'       SpaceLib
      *
      * Create the user space
      *
     c                   call(e)   'QUSCRTUS'
     c                   parm      UserSpace     UserSpaceOut
     c                   parm                    SpaceAttr
     c                   parm      4096          SpaceLen
     c                   parm                    SpaceVal
     c                   parm                    SpaceAuth
     c                   parm                    SpaceText
     c                   parm                    SpaceRepl
     c                   parm                    ApiError
      *
     c                   endsr

      *========================================================================
      * $QUSLMBR  - API List all members in a file
      *========================================================================
     c     $QUSLMBR      begsr
      *
     c                   eval      nBufLen = %size(MbrD0100)
      *
     c                   call(e)   'QUSLMBR'
     c                   parm                    UserSpaceOut
     c                   parm                    Format
     c                   parm                    FileLib
     c                   parm                    AllMembers
     c                   parm                    bOvr
     c                   parm                    ApiError
      *
     c                   endsr

      *=================================================
      *    $SndMsg - Send a message to the msg subfile
      *=================================================
     c     $SndMsg       begsr
      *
     c                   call      'QMHSNDPM'
     c                   parm                    MSGID
     c                   parm                    MSGF
     c                   parm                    MSGDTA
     c                   parm                    DTALEN
     c                   parm                    MSGTYP
     c                   parm                    PGMQ
     c                   parm                    STKCNT
     c                   parm                    MSGKEY
     c                   parm                    Apierror
      *
     c                   endsr

      *=================================================
      *    $ClrMsg - Clear the msg from the screen
      *=================================================
     c     $ClrMsg       begsr
      *
     c                   call      'QMHRMVPM'
     c                   parm                    PGMQ
     c                   parm                    STKCNT
     c                   parm                    MSGKY
     c                   parm                    MSGRMV
     c                   parm                    ApiError
      *
     c                   endsr

      *=================================================
      *    *inzsr - One time run House keeping subroutine
      *=================================================
     c     *inzsr        begsr
      *
     c                   eval      PGMQ = @PGM
     c                   eval      DTALEN = 60
      *
     c                   eval      Title = 'Subfile Shell Program'
     c                   eval      LenStr = ((%len(Title) -
     c                             %len(%trim(Title))) / 2) + 1
     c                   eval      %subst(C1TITLE:LenStr) = %trim(Title)
      *
     c                   eval      Title30 = 'Test Company'
     c                   eval      LenStr = ((%len(Title30) -
     c                             %len(%trim(Title30))) / 2) + 1
     c                   eval      %subst(HDCOMPANY:LenStr) = %trim(Title30)
      *
           // send message that report was printed.

     c                   eval      MSGID = 'CPF9898'
     c                   eval      MSGDTA = 'Enter Data, Press ' +
     c                                      ' to continue'
     c                   exsr      $SNDMSG
     c                   eval      screenerror = 'Y'
      *
     c                   endsr


Load all subfile example with sql


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

      *
      * PROGRAM - LOR01
      * PURPOSE - Laborout Transaction maintenance
      * WRITTEN - 01/12/2007
      * AUTHOR  - jamie 

      * PROGRAM DESCRIPTION
      *   This program will allow maintenance of Laborout PO's
      *
      * INDICATOR USAGE
      *   03 - subfile end indicator
      *   30 - subfile clear
      *   31 - subfile display
      *   32 - subfile display control
      *   33 - subfile end
      *--------------------------------------------------------
     fLOR01AD   cf   e             workstn INFDS(INFDS)
     f                                     SFILE(SUB01:RRN1)
      *
      * Variable Definition
      *
     d CmdLength       s             15  5 inz(0)
     d CmdString       s          14000    inz(*blanks)
     d EndScreen1      s              1    inz('N')
     d ISodate         s               d
     d LenStr          s              4  0
     d Lo              c                   CONST('abcdefghijklmnopqrstuvwxyz')
     d messagecsc      s             10i 0
     d messagedata     s             80A
     d messagekey      s              4A
     d messagelen      s             10i 0
     d messagefile     s             20    inz('LBIMSG    *LIBL')
     d messageid       s              7
     d pos             s              3  0
     d Q               s              1    inz('''')
     d RRN1            s                   like(SCRRN)
     d s1error         s              1
     d Savrrn          s                   like(SCRRN)
     d ScreenError     s              1    inz('N')
     d sql             s            512
     d Title           s             40
     d Up              c                   CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
      *
      * Program Info
      *
     d                SDS
     d  @PGM                 001    010
     d  @PARMS               037    039  0
     d  @MSGDTA               91    170
     d  @MSGID               171    174
     d  @JOB                 244    253
     d  @USER                254    263
     d  @JOB#                264    269  0

      * Command Keys
     d Cmd01           c                   const(x'31')                         Cmd-1
     d Cmd02           c                   const(x'32')                         Cmd-2
     d LeaveProgram    c                   const(x'33')                         Cmd-3
     d Cmd04           c                   const(x'34')                         Cmd-4
     d Cmd05           c                   const(x'35')                         Cmd-5
     d Cmd06           c                   const(x'36')                         Cmd-6
     d Cmd07           c                   const(x'37')                         Cmd-7
     d Cmd08           c                   const(x'38')                         Cmd-8
     d Cmd09           c                   const(x'39')                         Cmd-9
     d Cmd10           c                   const(x'3A')                         Cmd-10
     d Cmd11           c                   const(x'3B')                         Cmd-11
     d Cmd12           c                   const(x'3C')                         Cmd-12
     d Cmd13           c                   const(x'B1')                         Cmd-13
     d Cmd14           c                   const(x'B2')                         Cmd-14
     d Cmd15           c                   const(x'B3')                         Cmd-15
     d Cmd16           c                   const(x'B4')                         Cmd-16
     d Cmd17           c                   const(x'B5')                         Cmd-17
     d Cmd18           c                   const(x'B6')                         Cmd-18
     d Cmd19           c                   const(x'B7')                         Cmd-19
     d Cmd20           c                   const(x'B8')                         Cmd-20
     d Cmd21           c                   const(x'B9')                         Cmd-21
     d Cmd22           c                   const(x'BA')                         Cmd-22
     d Cmd23           c                   const(x'BB')                         Cmd-23
     d Cmd24           c                   const(x'BC')                         Cmd-24
     d EnterKey        c                   const(x'F1')
     d RollUp          c                   const(x'F5')                         Roll Up
     d RollDown        c                   const(x'F4')                         Roll Down
      *
      *
     d Infds           ds                                                       INFDS data structure
     d Choice                369    369
     d Currec                378    379I 0
      *

     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 SQLData         ds                  qualified
     d po#                            7  0
     d counter                        3  0
     d description                   30
     d etadate                        7  0

      //
      //  external calls
      //

     d $command        pr                  extpgm('QCMDEXC')
     d   command                   5000    options(*varsize)
     d   Length                      15  5

     d $sendmsg        PR                  ExtPgm('QMHSNDPM')
     d   MessageID                    7A   Const
     d   QualMsgF                    20A   Const
     d   MsgData                    256A   Const
     d   MsgDtaLen                   10I 0 Const
     d   MsgType                     10A   Const
     d   CallStkEnt                  10A   Const
     d   CallStkCnt                  10I 0 Const
     d   Messagekey                   4A
     d   ErrorCode                  256A

     d $clearmsg       pr                  extpgm('QMHRMVPM')
     d   messageq                   276a   const
     d   CallStack                   10i 0 const
     d   Messagekey                   4a   const
     d   messagermv                  10a   const
     d   ErrorCode                  256

         //Procedures to process dynamic SQL

     d openOrderList   pr
     d FetchNextOrder  pr              n
     d closeOrderList  pr
     d Titletext       pr           512A
     d   thestring                  512A   const

      /copy qpgmsrc,pch1ctrl

      /Free

        //--------------------------------------------------------
        // MAIN PROGRAM
        //--------------------------------------------------------

            exsr  Hskpg;
            exsr  $clearsfl;
            exsr  $loadsfl;
            exsr  $Screen1;

             *inlr = *on;

        //--------------------------------------------------------
        // $Screen1 - parameter screen
        //--------------------------------------------------------

             begsr $Screen1;

             reset  EndScreen1;
               dow  EndScreen1 = 'N';

                 if ScreenError = 'N';
                   exsr $clrmsg;
                 endif;


               monitor;
               write  MSGCTL;
               on-error;
               endmon;

               write  FKEY01;
               exfmt     SUB01CTL;
               exsr $clrmsg;


               reset ScreenError;

                 select;
            //
            // F3 pressed end the program F3 = LeaveProgram
            //
                   when  Choice = LeaveProgram;
                     eval EndScreen1 = 'Y';

            //
            // Enter Key pressed
            //
                   when  Choice = enterKey;
                     exsr  $Validate;
                   endsl;
               enddo;

             endsr;
        //--------------------------------------------------------
        // $Validate - Validate screen entries
        //--------------------------------------------------------

             begsr $Validate;

               reset screenerror;

             endsr;

        //----------------------------------------
        // $clearSfl - clear the subfile
        //----------------------------------------

             begsr $clearSFL;

               clear s1opt;

              // clear the subfile first

               *in31 = *Off;
               *in32 = *Off;
               *in30 = *On;

               write  SUB01CTL;
               clear s1error;

               *in31 = *On;
               *in32 = *On;
               *in30 = *Off;

               clear RRN1;
               clear SCRRN;
               clear SavRrn;

               sql = 'Select LPPO#, LICNTP ,LPSPI, LIETA ' +
                     ' from ' +
                     ' LOPLPCH A left join LOILPCH b on ' +
                     ' (A.LPPO# = B.LIPO#) ';


             endsr;

        //--------------------------------------------------------
        // $loadsfl- load up the entire subfile
        //--------------------------------------------------------

             begsr $loadsfl;

                 if  SavRrn  > *zeros;
                   RRN1  =  SavRrn;
                   SCRRN =  SavRrn;
                 endif;

               openOrderList();
                Dow fetchNextOrder();

              // start populate the subfile fields

                s1po#    = sqldata.po#;
                s1seq#   = sqldata.counter;
                s1poinfo = sqldata.description;



              // end populate the subfile fields

                 RRN1 += 1;
                 SCRRN  = RRN1;
                 write SUB01;
                enddo;
               closeOrderList();

               *in33 = *on;
               savrrn = SCRRN;

           //
           //  If no records in subfile then do not disply the subfile.
           //
                 if SavRrn  = *zeros;
                   *in31 = *off;
                 else;
                   RRN1  = 1;
                   SCRRN  = 1;
                 endif;

             endsr;
        //--------------------------------------------------------
        // $sndmsg - send subfile message
        //--------------------------------------------------------

             begsr $sndmsg;

               $sendmsg(messageID   :
                        messageFile :
                        messagedata :
                        messageLen  :
                        '*DIAG'     :
                        @PGM        :
                        messagecsc  :
                        messagekey  :
                        APIError
                                    );


             endsr;

        //--------------------------------------------------------
        // $clrmsg - clear all subfile message(s)
        //--------------------------------------------------------

             begsr $clrmsg;

               $clearmsg('*'      :
                         *zero    :
                         *blanks  :
                         '*ALL'   :
                         APIError
                                  );

             endsr;
        //--------------------------------------------------------
        // Hskpg - one time run subroutine
        //--------------------------------------------------------

             begsr Hskpg;
      /end-free

     c/exec sql
     c+ set option commit=*none,
     c+ datfmt=*iso
     c/end-exec

      /free

                 in   dactrl;

                   HDPROGRAM = @PGM;
                   PGMQ = @PGM;
                   HDCOMPANY = DACONM;

                   Title = 'Select Labor out PO';
                   LenStr = ((%len(Title) - %len(%trim(Title))) / 2) + 1;
                            %subst(HDTITLE:LenStr) = %trim(Title);




             endsr;

      /End-Free

      *--------------------------------------------------------
      *  openOrderList  - Open a cursor to read the Orders file
      *--------------------------------------------------------
     p openOrderList   b

     d openOrderList   pi

     c/exec sql
     c+ declare Cursor cursor
     c+    for wkStatement
     c/end-exec
     c/exec sql
     c+ prepare wkStatement from :sql
     c/end-exec
     c/exec sql
     c+ open Cursor
     c/end-exec

     p openOrderList   e
      *--------------------------------------------------------
      *  fetchNextOrder - read order one at a time
      *--------------------------------------------------------
     p fetchNextOrder  b

     d fetchNextOrder  pi              N

     c/exec sql
     c+ fetch next from Cursor
     c+    into :SQLdata
     c/end-exec

      /free
         if sqlstt < '02000';
           return  *on;
         else;
           return  *off;
         endif;
      /end-free

     p fetchNextOrder  e
      *--------------------------------------------------------
      *  closeOrderList  - Close the OrderHdr cursor
      *--------------------------------------------------------
     p closeOrderList  b

     d closeOrderList  pi

     c/exec sql
     c+ close Cursor
     c/end-exec

     p closeOrderList  e
      *--------------------------------------------------------
      *  TitleText - convert text string to title format
      *--------------------------------------------------------
      * Begin Procedure
     P Titletext       B
     d  TitleText      Pi           512A
     d   TheString                  512A   const
      * After below line of code is processed
      * Thestring    = my name is
      * AfterString =  My Name Is
      *
     d AfterString     s            512A
     d BeforeString    s            512A
     d Count           s              4  0
     d CurrentOne      s              1
     d LastOne         s              1
      *
     d Up              c                   CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
     d Lo              c                   CONST('abcdefghijklmnopqrstuvwxyz')
      *
     c                   clear                   AfterString
      *
      * Lower case the entire thing
      *
     c                   Eval      BeforeString =
     c                             %Xlate(Up:Lo:TheString)
      *
     c                   for       count   = 1 to %len(%trim(BeforeString))
     c                   eval      CurrentOne = %subst(BeforeString:count:1)
      *
     c                   select
      *
     c                   when      count = 1
     c                   eval      AfterString = %Trim(
     c                             %Xlate(Lo:Up:%Subst(
     c                             BeforeString:1:1)))
      *
     c                   when      %subst(BeforeString:count:4) = 'mfg ' or
     c                             %subst(BeforeString:count:4) = 'inc ' or
     c                             %subst(BeforeString:count:4) = 'inc.' or
     c                             %subst(BeforeString:count:4) = 'ind ' or
     c                             %subst(BeforeString:count:4) = 'co. ' or
     c                             %subst(BeforeString:count:4) = 'co  ' or
     c                             %subst(BeforeString:count:4) = 'llc.' or
     c                             %subst(BeforeString:count:4) = 'llc '
     c                   eval      %subst(AfterString:count:3)=
     c                             %Trim(
     c                             %Xlate(Lo:Up:%Subst(
     c                             BeforeString:count:3)))
     c                   eval      count +=2
     c                   iter
      *
     c                   when      LastOne = *blanks or
     c                             LastOne = '-'     or
     c                             LastOne = '.'     or
     c                             LastOne = '/'
     c                   eval      AfterString = %Subst(
     c                             AfterString:1:count-1)
     c                             +             %Trim(
     c                             %Xlate(Lo:Up:%Subst(
     c                             BeforeString:count:1)) +
     c                             %Subst(AfterString:count+1))
     c                   other
     c                   eval      %subst(AfterString:count:1) =
     c                             %subst(BeforeString:count:1)
     c                   endsl
      *
     c                   eval      LastOne = %subst(BeforeString:count:1)
     c                   endfor
      *


     c                   return    AfterString


     p Titletext       E
      *--------------------------------------------------------