Progress Bar

The RPG to generate a Progress Bar for source files

      *====================================================================*   
      *          Progress Bar                                              *   
      *--------------------------------------------------------------------*   
      *                                                                    *   
      *  9/00  Booth Martin, created program                               *   
      *                                                                    *   
      *--------------------------------------------------------------------*   
     FUtl4020D  cf   e             WorkStn                                     
      *---------------------------------------------------------------------   
     D TimeStart       S               T                                       
     D TimeNow         S               T                                       
     D TimeHMS         S               T   TimFmt(*HMS)                        
     D TotalSecs       S              9S 0                                     
     D TimeHMSa        S              8                                        
      *                                                                        
     D CurrentRec      S              7S 0                                     
     D TotalRecs       S              7S 0                                     
     D PCT             S              3S 0                                     
                                                                                         
      *                                                                                  
      * play stuff                                                                       
     C                   Eval      TotalRecs = 2000                                      
     C                   Time                    TimeStart                               
                                                                                         
     C                   dow       CurrentRec < currentrec =" CurrentRec" pct =" CurrentRec" prgbar =" '"> 5                                               
     C                   Time                    TimeNow                                 
      * Time elapsed so far:?                                                            
     C     TimeNow       SubDur    TimeStart     TotalSecs:*S                  
     C                   Eval      TotalSecs = TotalSecs/pct * (100 - pct)     
     C     T'00.00.00'   AddDur    TotalSecs:*S  TimeHMS                       
     C                   MoveL     TimeHMS       Tmp20            20           
     C                   Move      'remaining  ' Tmp20                         
     C                   Move      Tmp20         PrgBar                        
     C                   End                                                   
                                                                               
      * Set the RI placement                                                   
     C*                  EVAL      pct = (CurrentRec * %size(PRGBAR))/TotalRecs
     C                   EVAL      pct = (CurrentRec * 74)/TotalRecs           
                                                                               
     C                   If        Pct > 0                                     
     C                   EVAL      %subst(PRGBAR:pct:1) = x'21'                
     C                   Write     FMT01                                       
     C                   End                                                   
                                                                               
     C                   EndDo                                                 
                                                                               
     C                   EVAL      %subst(PRGBAR:74:1) = ' '                   
     C                   Exfmt     FMT01                                       
                                                                               
     C                   eval      *inLR = *on                                 
      * ---------------------------------------------------------------------

The DDS Source (display file source code)

     A*%%TS  SD  20000914  162243  BMARTIN     REL-V3R7M0  5716-PW1        
     A******************************************************************   
     A*                                                                    
     A*  DISPLAY FILE ID     -    Progress Bar Window                      
     A*  DISPLAY FILE NAME   -                                             
     A*  DATE CREATED        -    9/00                                     
     A*                                                                    
     A******************************************************************   
     A*%%EC                                                                
     A                                      DSPSIZ(24 80 *DS3)             
     A                                      ERRSFL                         
     A          R FMT01                                                    
     A*%%TS  SD  20000914  162243  BMARTIN     REL-V3R7M0  5716-PW1        
     A                                      TEXT('A displayable Progress bar')
     A                                      OVERLAY                        
     A                                      WINDOW(22 2 1 74 *NOMSGLIN)    
     A            PRGBAR        74   O  1  1DSPATR(RI)                     
     A                                      COLOR(RED)                     
     A          R DUMMY                                                      
     A                                      TEXT('PREVENTS PREVIOUS SCREEN FROM-
     A                                       BEING CLEARED')                 
     A                                      ASSUME                           
     A                                  1  9' '              

Read more!

RPGIV : After Update Trigger

    DB2 Example: After Update Trigger 
 
     *========================================================*
      * This program is intended to illustrate an after update *
      * trigger that simulates an update cascade.              *
      *                                                        *
      *                                                        *
      * CRTSQLRPGI OBJ(CORPDATA/TRG03) SRCFILE(MJASRC/RPG)     *
      *            COMMIT(*NONE) OUTPUT(*PRINT)                *
      *            OPTION(*XREF *NOGEN) DBGVIEW(*SOURCE)       *
      *            USRPRF(*OWNER) DYNUSRPRF(*ONER)             *
      *                                                        *
      * CRTBNDRPG PGM(CORPDATA/TRG03) SRCFILE(QTEMP/QSQLTEMP1) *
      *           DFTACTGRP(*NO) ACTGRP(*CALLER)               *
      *           DBGVIEW(*SOURCE) ALWNULL(*YES)               *
      *           USRPRF(*OWNER)                               *
      *                                                        *
      * ADDPFTRG FILE(CORPDATA/DEPARTMENT)                     *
      *          TRGTIME(*AFTER) TRGEVENT(*UPDATE)             *
      *          PGM(CORPDATA/TRG03) ALWREPCHG(*YES)           *
      *                                                        *
      *                                                        *
      *========================================================*
      *
      *========================================================*
      * Definition of the structure passed as the first        *
      * parameter from database to the trigger program.        *
      * The include is used so that any additional fields      *
      * in the interface template in the future will be        *
      * brought into the program if it is recompiled.          *
      *                                                        *
      * The includes in the QSYSINC library must be on         *
      * your system to compile this program. Option 13 of      *
      * the OS/400 install will install them.                  *
      *                                                        *
      *========================================================*
     D/COPY QSYSINC/QRPGLESRC,TRGBUF
      *
      *========================================================*
      * This is an overlay used to set addressability          *
      * to the various sections of the interface buffer        *
      * such as the before and after record images.            *
      *========================================================*
     D INTARR          S              1A   BASED(INTPTR) DIM(32767)
     D INTPTR          S               *
      *
      *========================================================*
      * Definition of the trigger buffer length passed as      *
      * the second parameter from database to the trigger      *
      * program.                                               *
      *========================================================*
     D PARM2           DS
     D  LENG                   1      4B 0
      *
      *========================================================*
      * These pointers are used to point to the before         *
      * and after images. The before and after images          *
      * are passed in the first parameter structure.           *
      *========================================================*
     D BIMAGE          S               *
     D AIMAGE          S               *
      *
      *========================================================*
      * These based structures provide the subfields of        *
      * the record images. Externally defined data             *
      * structures are used so a recompile of the              *
      * program will always pick up the latest field           *
      * defintions.                                            *
      *========================================================*
     D BEMP          E DS                  EXTNAME(DEPARTMENT)
     D                                     BASED(BIMAGE)
     D                                     PREFIX(B)
     D AEMP          E DS                  EXTNAME(DEPARTMENT)
     D                                     BASED(AIMAGE)
     D                                     PREFIX(A)
      *
      *========================================================*
      * Error output from QMHSNDPM                             *
      *========================================================*
     D/COPY QSYSINC/QRPGLESRC,QUSEC
     D  RTNDTA                17     56
      *
      *========================================================*
      * Parameters for QMHSNDPM                                *
      *========================================================*
     D FLDS            DS
     D  MSGLEN                 1      4B 0
     D  PGMSTK                 5      8B 0
     D  RTVLEN                 9     12B 0
     D  MSGQLEN               13     16B 0
     D  PGMWTT                17     20B 0
     D  LASTOPEN              21     21A
      *
      *========================================================*
      * If an error occurs, the trigger program should send an *
      * error to database to indicate that the operation has   *
      * failed. To send an escape message, use the QMHSNDPM    *
      * API. We must send the message to the call stack entry  *
      * that comes immediately before the trigger program.     *
      * The first call stack entry in an ILE RPG trigger       *
      * program is the PEP. Below, we have defined the         *
      * name of the PEP for this ILE trigger program.          *
      *========================================================*
     D MSGQNAM         C                   CONST('_QRNP_PEP_TRG02')
      *
      *========================================================*
      * Place the name of your message file in the first 10    *
      * characters, padding with blanks to the 10th character. *
      * Place the library name in the second 10 characters     *
      * padding with blanks.                                   *
      *========================================================*
     D MSGFNAME        C                   CONST('MSGF      MJATST ')
     D LEN             C                   CONST(15)
     D MODNAME         C                   CONST('*NONE     *NONE  ')
      *
     C     *ENTRY        PLIST
     C     QDBTB         PARM                    QDBTB
     C     PARM2         PARM                    PARM2
      *
      *========================================================*
      * This is the parameter list of QMHSNDPM.                *
      *========================================================*
     C     PLIST1        PLIST
     C                   PARM                    MSGID            7
     C                   PARM                    MSGF            20
     C                   PARM                    MSGDTA          25
     C                   PARM                    MSGLEN
     C                   PARM                    MSGTYP          10
     C                   PARM                    MSGQUE          19
     C                   PARM                    PGMSTK
     C                   PARM                    MSGKEY           4
     C                   PARM                    QUSEC
     C                   PARM                    MSGQLEN
     C                   PARM                    CSEQUAL         20
     C                   PARM                    PGMWTT
      *========================================================*
      * Set the basing pointers for the interface              *
      * structure and the before and after images              *
      *========================================================*
     C                   EVAL      INTPTR = %ADDR(QDBTB)
     C                   EVAL      BIMAGE = %ADDR(INTARR(QDBORO+1))
     C                   EVAL      AIMAGE = %ADDR(INTARR(QDBNRO+1))
      *
      *========================================================*
      * Only open or perform an update if the manager          *
      * number has changed.                                    *
      *========================================================*
     C     AMGRNO        IFNE      BMGRNO
      *
      *========================================================*
      * Update the employee record. Note that SQL will keep    *
      * any of the used ODPs open.                             *
      * Also SQL is able to use a specific isolation level     *
      * either by using the SET TRANSACTION statement or       *
      * by statement level isolation levels.                   *
      *========================================================*
     C     QDBCLL        IFEQ      '0'
     C/EXEC SQL UPDATE CORPDATA/EMPLOYEE SET WORKDEPT = :ADEPTNO
     C+         WHERE EMPNO = :AMGRNO WITH NC
     C/END-EXEC
     C                   ELSE
     C     QDBCLL        IFEQ      '1'
     C/EXEC SQL UPDATE CORPDATA/EMPLOYEE SET WORKDEPT = :ADEPTNO
     C+         WHERE EMPNO = :AMGRNO WITH UR
     C/END-EXEC
     C                   ELSE
     C     QDBCLL        IFEQ      '2'
     C/EXEC SQL UPDATE CORPDATA/EMPLOYEE SET WORKDEPT = :ADEPTNO
     C+         WHERE EMPNO = :AMGRNO WITH CS
     C/END-EXEC
     C                   ELSE
     C     QDBCLL        IFEQ      '3'
     C/EXEC SQL UPDATE CORPDATA/EMPLOYEE SET WORKDEPT = :ADEPTNO
     C+         WHERE EMPNO = :AMGRNO WITH RS
     C/END-EXEC
     C                   ELSE
     C/EXEC SQL UPDATE CORPDATA/EMPLOYEE SET WORKDEPT = :ADEPTNO
     C+         WHERE EMPNO = :AMGRNO WITH RR
     C/END-EXEC
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
     C                   ENDIF
      *
      *========================================================*
      * If the SQL operation is unsuccessful for               *
      * some reason return a message to the application to     *
      * make the update fail.                                  *
      *========================================================*
     C     SQLCOD        IFLT      0
      *
      *========================================================*
      * Place the appropriate message ID here.                 *
      *========================================================*
     C                   MOVEL     'TRG0001'     MSGID
     C                   MOVEL     MSGFNAME      MSGF
     C                   MOVE      '  '          MSGDTA
     C                   Z-ADD     25            MSGLEN
     C                   MOVEL(P)  '*ESCAPE'     MSGTYP
     C                   MOVEL(P)  MSGQNAM       MSGQUE
     C                   MOVEL(P)  MODNAME       CSEQUAL
     C                   MOVE      '  '          MSGDTA
     C                   Z-ADD     1             PGMSTK
     C                   Z-ADD     LEN           MSGQLEN
     C                   MOVE      ' '           MSGKEY
     C                   Z-ADD     66            QUSBPRV
     C                   Z-ADD     0             QUSBAVL
     C                   MOVE      ' '           QUSEI
     C                   MOVE      ' '           QUSERVED
     C                   MOVE      ' '           RTNDTA
     C                   CALL      'QMHSNDPM'    PLIST1
     C                   ENDIF
     C                   ENDIF
      *
     C                   RETURN

Reference from JimmyOctane at Code400

Read more!

Trigger AS/400

This template deals with triggers on physical files.The triggered file itself need not be referenced here unless you have need to access it beyond the record that caused the trigger to be pulled.

      /TITLE TRIGGER ** Trigger program shell **

      *                 Pete Hall
      *                 http://www.inwave.com/~peteh/

      * Replace (PFile) with physical file name
      * Replace (AFile) with ancillary file name

      * ---------------------------------------------
      * Ancillary files
      * ---------------------------------------------
     F(AFile)   UF A E           K DISK    Commit(RunCommit) UsrOpn

      * ------------------------------------------
      * Entry Parameters
      * ---------------------------------------------
     DBuffer           DS         32767
     D PFName                        10
     D PFLibrary                     10
     D PFMember                      10
     D TrgEvent                       1
     D TrgTime                        1
     D TrgCmtLvl                      1
     D                                3
     D TrgCCSID                       7B 0
     D                                8
     D OrOffset                       7B 0
     D OrRcdLen                       7B 0
     D OrNBMapOfs                     7B 0
     D OrNBMapLen                     7B 0
     D NwOffset                       7B 0
     D NwRcdLen                       7B 0
     D NwNBMapOfs                     7B 0
     D NwNBMapLen                     7B 0
     D DataSpace               1  32767
     D Bytes                          1    Overlay(DataSpace) Dim(32767)

     DBufferLen        S              7B 0
      * ---------------------------------------------
      * Original Record
      * ---------------------------------------------
     D@OrRecord        S               *   Inz(*Null)

     DOrRecord       E DS                  ExtName((PFile)) Prefix(OR_)
     D                                     Based(@OrRecord)

      * ---------------------------------------------
      * New Record
      * ---------------------------------------------
     D@NwRecord        S               *   Inz(*Null)

     DNwRecord       E DS                  ExtName((PFile)) Prefix(NW_)
     D                                     Based(@NwRecord)

      * ---------------------------------------------
      * Constant Definitions
      * ---------------------------------------------
      * Commit Levels
     DCL_NONE          C                   '0'
     DCL_CHG           C                   '1'
     DCL_CS            C                   '2'
     DCL_ALL           C                   '3'

      * Null byte status
     DNB_NOTNULL       C                   '0'
     DNB_NULL          C                   '1'

      * Trigger events
     DTE_INSERT        C                   '1'
     DTE_DELETE        C                   '2'
     DTE_UPDATE        C                   '3'

      * Trigger times
     DTT_AFTER         C                   '1'
     DTT_BEFORE        C                   '2'
     C     *ENTRY        plist
     C                   parm                    Buffer
     C                   parm                    BufferLen


      * ---------------------------------------------
      * Main-line Procedure
      * ---------------------------------------------

      * Assign the record templates to their data space
     C                   eval      @OrRecord = %Addr(Bytes(OrOffset+1))
     C                   eval      @NwRecord = %Addr(Bytes(NwOffset+1))

      * Execute the correct procedure based on trigger event
     C     TrgEvent      caseq     TE_INSERT     DoInsert
     C     TrgEvent      caseq     TE_DELETE     DoDelete
     C     TrgEvent      caseq     TE_UPDATE     DoUpdate
     C                   endcs
     C                   return

      * ---------------------------------------------
      * Process a delete event
      * ---------------------------------------------
     CSR   DoDelete      BEGSR


     CSR                 ENDSR

      * ---------------------------------------------
      * Process an insert event
      * ---------------------------------------------
     CSR   DoInsert      BEGSR


     CSR                 ENDSR

      * ---------------------------------------------
      * Process an update event
      * ---------------------------------------------
     CSR   DoUpdate      BEGSR


     CSR                 ENDSR

      * ---------------------------------------------
      * Program Initialization
      * ---------------------------------------------
     CSR   *INZSR        BEGSR

     C                   if        TrgCmtLvl > CL_NONE
     C                   move      *ON           RunCommit
     C                   endif
      *                                          > if TrgCmtLvl > CL_NONE    
     C                   open    

     CSR                 ENDSR

Reference from  Pete Hall's web site .

Read more!

The RPGIV for the 3-Column Subfile

      ************************************************************* 
      * A program to select from 3 different files                * 
      *    6/00  Booth Martin                                     * 
      *                                                           * 
      *                                                           * 
      ************************************************************* 
     FSFL3ColFM CF   E             WORKSTN                          
     F                                     SFILE(SFLA:RRN)          
     FFilters1P IF   E             DISK                             
     FFilters2P IF   E             DISK                             
     FFilters3P IF   E             DISK                             
                                                                    
     D ReadFilters1P   S              3    INZ('Yes')               
     D ReadFilters2P   S              3    INZ('Yes')               
     D ReadFilters3P   S              3    INZ('Yes')               
                                                                    
      * Arrays of Selected Items                                    
     D Inx             S              3S 0                          
     D Inx1            S              3S 0                          
     D AR1             S              2    DIM(60)                   
     D Inx2            S              3S 0                           
     D AR2             S              2    DIM(60)                   
     D Inx3            S              3S 0                           
     D AR3             S              2    DIM(60)                   
                                                                     
      *  ..................................................          
                                                                     
     C                   Z-ADD     1             RRN               4 0
                                                                     
      * Clear subfile & screen, prepare to re-fill or fill:          
     C                   Eval      *IN90=*OFF                        
     C                   Clear                   SFLA                
     C                   Write     FOOTer                            
     C                   Write     FMT01                             
     C                   EXSR      FillSubfileSR                     
                                                                     
      **                                                             
     C     RRN           IFLT      11                                
     C                   MOVE      *ON           *IN91               
     C                   END                                
     C                   MOVE      *ON           *IN90      
     C                   WRITE     FOOTer                   
                                                            
     C                   DoW       *INLR = *Off             
     C                   EXFMT     FMT01                    
     C                   Read      Footer                   
                                                            
     C                   Select                             
                                                            
      * Footer Push button Choices:                         
      * Refresh Subfile:                                    
     C                   When      PB1 = 1 Or *INKE = *On   
     C                   Eval      ReadFilters1P = 'Yes'    
     C                   Eval      ReadFilters2P = 'Yes'    
     C                   Eval      ReadFilters3P = 'Yes'    
     C                   GOTO      RefreshTag               
      * Run the job                                         
     C                   When      PB1 = 2 Or *INKJ         
     C                   Exsr      AcceptSR                 
     C                   Eval      *INLR = *ON                               
      * end the job                                                          
     C                   When      PB1 = 3 or *INKC Or *INKL                 
     C                   Eval      *INLR = *ON                               
                                                                             
      * Mouse clicked in Column 1, toggle the field                          
      *  (Note: The DDS has a mouse button click = F11.  The reason for this is
      *         so that a regular Enter while the cursor is in a Filter field
      *         won't toggle the field's value.  F11=*INKK)                  
                                                                             
     C                   When      FLD = 'COL1O' And *INKK                   
     C     Relrcd        Chain     SFLA                                      
     C                   If        Col1o = 'Y'                               
     C                   Eval      Col1o = ' '                               
     C                   Else                                                
     C                   Eval      Col1o = 'Y'                               
     C                   End                                                 
     C                   Update    Sfla                                      
                                                                             
      * Mouse clicked in Column 2, toggle the field                          
     C                   When      FLD = 'COL2O' And *INKK   
     C     Relrcd        Chain     SFLA                      
     C                   If        Col2o = 'Y'               
     C                   Eval      Col2o = ' '               
     C                   Else                                
     C                   Eval      Col2o = 'Y'               
     C                   End                                 
     C                   Update    Sfla                      
                                                             
      * Mouse clicked in Column 3, toggle the field          
     C                   When      FLD = 'COL3O' And *INKK   
     C     Relrcd        Chain     SFLA                      
     C                   If        Col3o = 'Y'               
     C                   Eval      Col3o = ' '               
     C                   Else                                
     C                   Eval      Col3o = 'Y'               
     C                   End                                 
     C                   Update    Sfla                      
                                                             
     C                   EndSL                               
     C                   END                                          
                                                                      
     C     RefreshTag    Tag                                          
      *  _________________________________________________________________
     C     AcceptSR      BegSR                                        
      * If a choice was made, then do the required action:            
     C                   Eval      Inx  = 1                           
     C                   Eval      Inx1 = 1                           
     C                   Eval      Inx2 = 1                           
     C                   Eval      Inx3 = 1                           
                                                                      
     C     Inx           Chain     SFLA                               
                                                                      
     C                   If        %Found                             
     C                   DoU       %EOF or Not %Found                 
                                                                      
     C                   If        Col1o = 'Y'                        
     C                   Eval      Ar1(Inx1) = Col1H                  
     C                   Eval      Inx1 = Inx1 + 1                    
     C                   End                                          
                                                    
     C                   If        Col2o = 'Y'      
     C                   Eval      Ar2(Inx2) = Col2H
     C                   Eval      Inx2 = Inx2 + 1  
     C                   End                        
                                                    
     C                   If        Col3o = 'Y'      
     C                   Eval      Ar3(Inx3) = Col3H
     C                   Eval      Inx3 = Inx3 + 1  
     C                   End                        
                                                    
     C                   Eval      Inx = Inx + 1    
     C     Inx           Chain     SFLA             
     C                   EndDo                      
     C                   EndIf                      
      * Sort the arrays so we can do look ups:      
     C                   Sorta     AR1              
     C                   Sorta     AR2              
     C                   Sorta     AR3              
                                                    
      * Write a file of records for printing the report(s):                
     C                   Exsr      WriteRecordSR                           
                                                                           
     C                   EndSR                                             
      *  _________________________________________________________________ 
     C     WriteRecordSR BegSR                                             
      * This sub routine is blank.  It is trivial to add whatever code is  
      * needed to make the filters selected be useful.  The purpose of this
      * exercise is to show the 3-column subfile and the toggling of the values
     C                   EndSR                                             
      *  _________________________________________________________________ 
     C     FillSubfileSR BegSR                                             
                                                                           
     C     1             Setll     Filters1P                               
     C     1             Setll     Filters2P                               
     C     1             Setll     Filters3P                               
                                                                           
     C                   DoW       ReadFilters1P = 'Yes' Or                
     C                             ReadFilters2P = 'Yes' Or                
     C                             ReadFilters3P = 'Yes'                   
     C                   Exsr      WriteLineSR                         
     C                   Write     SFLA                                
     C                   Eval      RRN = RRN + 1                       
     C                   End                                           
                                                                       
     C                   Eval      NBRREC = RRN                        
     C                   EndSR                                         
      *  _________________________________________________________________
      * Write the line in the subfile:                                 
     C     WriteLineSR   BegSR                                         
                                                                       
      * Column 1: Status                                               
     C                   Eval      Col1O = ' '                         
     C                   Eval      Col2O = ' '                         
     C                   Eval      Col3O = ' '                         
                                                                       
      * Column 1: Filters 1                                            
     C                   Eval      Col1  =*Blanks                      
     C                   Eval      Col1H =' '                          
     C                   If        ReadFilters1P = 'Yes'               
     C                   Read      Filters1P                           
                                                                       
     C                   If        Not %EOF                            
     C                   Eval      Col1  = TypeID + ' ' + TYPEDS       
     C                   Eval      Col1H = TypeID                      
     C                   Eval      Col1O = 'Y'                         
     C                   Else                                          
     C                   Eval      ReadFilters1P = 'No '               
     C                   End                                           
                                                                       
     C                   End                                           
                                                                       
      * Column 2: Filters2P                                            
     C                   Eval      Col2  =*Blanks                      
     C                   Eval      Col2H =' '                          
                                                                       
     C                   If        ReadFilters2P = 'Yes'               
     C                   Read      Filters2P                           
                                                                       
     C                   If        Not %EOF                       
     C                   Eval      Col2  = ST + ' ' + STATE       
     C                   Eval      Col2H = ST                     
     C                   Eval      Col2O = 'Y'                    
     C                   Else                                     
     C                   Eval      ReadFilters2P = 'No '          
     C                   End                                      
                                                                  
     C                   End                                      
                                                                  
      * Column 3: FiltersP                                        
     C                   Eval      Col3  =*Blanks                 
     C                   Eval      Col3H =' '                     
                                                                  
     C                   If        ReadFilters3P = 'Yes'          
     C                   Read      Filters3P                      
                                                                  
     C                   If        Not %EOF                       
     C                   Eval      Col3  = CNTRY + ' ' + COUNTRY  
     C                   Eval      Col3H = CNTRY                  
     C                   Eval      Col3O = 'Y'            
     C                   Else                             
     C                   Eval      ReadFilters3P = 'No '  
     C                   End                              
                                                          
     C                   End                              
                                                          
     C                   EndSR                            
      *  _____________________________________________________

The DSPF code of 3-Column Subfile

A                                      DSPSIZ(24 80 *DS3)            
A                                      CHGINPDFT(HI UL)              
A                                      CSRINPONLY                    
A                                      ERRSFL                        
A                                      CF03(03 'Exit')               
A                                      CF05(05 'Refresh')            
A                                      CF10(10 'Run')                
A                                      CF11(11 'Toggle field')       
A                                      CF12(12 'Exit')               
A                                      MOUBTN(*ULD CF11)             
A          R SFLA                      SFL                           
A* 
A            COL1O          1A  B 11  4SFLCSRPRG                     
A            COL1          20A  O 11  6DSPATR(HI)                    
A            COL2O          1A  B 11 29SFLCSRPRG                     
A            COL2          20A  O 11 31DSPATR(HI)                    
A            COL3O          1A  B 11 54SFLCSRPRG                   
A            COL3          20A  O 11 56DSPATR(HI)                  
A            COL1H          2A  H                                  
A            COL2H          2A  H                                  
A            COL3H          2A  H        
A*                          
A          R FMT01                     SFLCTL(SFLA)                
A                                      SFLPAG(0011)                
A                                      SFLSIZ(&NBRREC)             
A                                      OVERLAY                     
A                                      RTNCSRLOC(&REC &FLD)        
A                                      SFLCSRRRN(&RELRCD)          
A  90                                  SFLDSP                      
A  90                                  SFLDSPCTL                   
A N90                                  SFLCLR                      
A  91                                  SFLEND(*SCRBAR *MORE)       
A            RELRCD         5S 0H                                  
A            NBRREC         5S 0P                                  
A            REC           10A  H                                  
A            FLD           10A  H                                  
A                                  1 69DATE                            
A                                      EDTCDE(Y)                       
A                                  2 69TIME                            
A                                  3 69SYSNAME                         
A                                  4 69'Filter'                        
A                                  5 69USER                            
A                                  7  4'Filter by these fields'        
A                                      DSPATR(HI)                      
A                                 10  4'  Type                '        
A                                      DSPATR(UL)                      
A                                      COLOR(BLU)                      
A                                 10 29'  State               '        
A                                      DSPATR(UL)                      
A                                      COLOR(BLU)                      
A                                 10 54'  Country             '        
A                                      DSPATR(UL)                      
A                                      COLOR(BLU)                      
A                                  7 49'Select for printing = "Y"'     
A                                  8 49'Print report = Run, or F10'     
A                                      DSPATR(BL)                      
A                                      COLOR(GRN)                               
A                                  1  3'   ____    _____     __           -     
A                                             ____     __   ____ __   '         
A                                  2  3'  _  /___/ ___/__  / /_ ____ _  _-     
A                                      __    / __/_ __/ /  / _(_) /__ '         
A                                  3  3' _/_ <___/ /__/ _ \/ / // /    \/ -       
A                                      _ \  _\ \/ // / _ \/ _/ / / -_)'           
A                                  4  3'/____/   \___/\___/_/\_,_/_/_/_/_/-       
A                                      /_/ /___/\_,_/_.__/_//_/_/\__/ '           
A          R FOOTER                                                               
A            PB1            2Y 0B 23  3PSHBTNFLD                                  
A                                      PSHBTNCHC(1 'Refresh (F5) ' CF05)          
A                                      PSHBTNCHC(2 'Run (F10) ' CF10)             
A                                      PSHBTNCHC(3 'Cancel (F12) ' CF12)   

reference from Booth Martin

Read more!