Subfile Example - RPGLE
Language(s):I-Series - RPGLE
Category(s):Subfiles

Comments=Simple Name List program, demonstrates: 1) Dynamic subfile creation. 2) Iterative subfile processing. 3) Adding/changing/deleting records. 4) Reading the cursor positiong from the INFDS. 5) Positioning the cursor on a subfile line. 6) Positioning in the subfile via lookup.

     F***************************************************************
     F** - Source Member: NMELSTR
     F***************************************************************
     F** - Simple Name List Program
     F** - RPGLE Supfield Example
     F** - Jon Vote 09/2002
     F** - www.idioma-software.com
     F***************************************************************
     F** - This program demonstrates the following:
     F**
     F**   1) Dynamic subfile creation.
     F**   2) Iterative subfile processing.
     F**   3) Adding/changing/deleting records.
     F**   4) Reading the cursor positiong from the INFDS.
     F**   5) Positioning the cursor on a subfile line.
     F**   6) Positioning in the subfile via lookup.
     F**
     F** - Related source members:
     F** -   NMELSTR: Simple Name List Program
     F**     NMELSTP: Pysical file used with NMELSTR
     F**     NMELST1: Logical over NMELSTP
     F**     NMELSTS: Display File used with NMELSTR
     F**
     F** - Name list pysical - keyed on NMELST (Last Name)
     F**
     FNMELSTP   if a e           k disk
     F**
     F** - By PRIKEY
     F**
     FNMELST1   uf   e           k disk
     F                                     rename(NMELSTF:BYPRIKEY)
     F**
     F** - Subfile - lists names in alpha order, allows selection
     F**
     FNMELSTS   cf   e             workstn
     F                                     sfile(NMELSSF:RdCtr)
     F                                     infds(FileDs)
     D**
     D** - INFDS, Row, Column, Current Subfile Number, Top Subfile Number
     D** - and Total Subfile records.
     D**
     D FileDs          DS
     D  RowCol               370    371B 0
     D  SFRR#                376    377B 0
     D  TopSF#               378    379B 0
     D  TotSF#               380    381B 0
     D**
     D** - Subfile records per page
     D**
     D SFPag           C                   const(15)
     D**
     D** - Program Variables
     D**
     D @EOF            s              1
     D @SFI            s              1
     D Cancel          s              1
     C**
     C     *Like         define    RdCtr         Count                          BOT OF PGE
     C     *Like         define    RdCtr         TopCTR                         TOP OF PGE
     C     *Like         define    RdCtr         BotCtr                         BOT OF PGE
     C     *Like         define    RdCtr         iRow                           BOT OF PGE
     C**
     C     *Like         define    PriKey        @PriKey
     C     *Like         define    PriKey        SveKey
     C     *Like         define    NmeFst        SveFst
     C     *Like         define    NmeLst        SveLst
     C     *Like         define    NmeMid        SveMid
     C     *Like         define    Phone#        SvePho
     C     *Like         define    Email@        SveEma
     C**
     C** - Initialize - Load the screen
     C**
     C                   exsr      Init
     C**
     C** - Dispaly the screen, loop until F3 keyed.
     C**
     C                   exsr      Paint
     C**
     C** - Loop until F3
     C**
     C                   Dow       *inkc='0'
     C**
     C** - React to user input
     C**
     C                   select
     C                   when      *inkc='1'
     C                   leave
     C                   when      *inke='1'                                    F6
     C                   exsr      Refresh
     C                   when      *inkf='1'                                    F6
     C                   exsr      AddRec
     C                   when      *in81='1'
     C                   exsr      RollUp
     C                   when      *in82='1'
     C                   exsr      RollDown
     C                   other
     C                   exsr      Enter
     C                   endsl
     C**
     C                   exsr      Paint
     C**
     C                   enddo
     C**
     C                   seton                                        LR
     C***************************************************************
     C** - Init : Initialize
     C***************************************************************
     C     Init          begsr
     C**
     C** - Clear the subfile
     C**
     C                   seton                                        20
     C                   write     NMELSCTL
     C                   setoff                                       20
     C**
     C** - Load the first screen
     C**
     C     *LoVal        setll     NMELSTF
     C                   eval      RdCtr=1
     C                   eval      TopCTR=0
     C                   eval      BotCTR=0
     C                   eval      @EOF='N'
     C                   exsr      LoadSF
     C**
     C                   endsr
     C***************************************************************
     C** - Paint: Paint the screen
     C***************************************************************
     C     Paint         begsr
     C**
     C                   eval      RdCtr=TopCtr
     C                   write     FOOTER
     C                   exfmt     NMELSCTL
     C                   eval      TopCtr=TopSF#
     C**
     C                   endsr
     C***************************************************************
     C** - RollUp: RollUp routine
     C***************************************************************
     C     RollUp        begsr
     C**
     C** - We get here if rolling past last subfile record written
     C**
     C                   eval      RdCtr= BotCtr +1
     C                   exsr      LoadSF
     C**
     C                   endsr
     C***************************************************************
     C** - RollDown: Rolldown Routine
     C***************************************************************
     C     RollDown      begsr
     C**
     C** - We get here at BOF
     C**
     C                   endsr
     C***************************************************************
     C** - Refresh: Refresh
     C***************************************************************
     C     Refresh       begsr
     C**
     C                   exsr      Init
     C**
     C                   endsr
     C***************************************************************
     C** - Enter: Enter keyed
     C***************************************************************
     C     Enter         begsr
     C**
     C** - Here's how to get the row and column of the cursor position
     C** - You can use this to figure out which subfile line
     C** - or whatever
     C**
     C     RowCol        div       256           CrsRow            2 0
     C                   mvr                     CrsCol            2 0
     C**
     C** - Ignore the subfile if the user is positioning
     C** - otherwise iterate through the subfile
     C**
     C                   if        PosTo<>*blanks
     C                   exsr      DoPos
     C                   else
     C                   exsr      ProcSF
     C                   endif                                                  PosTo<>" "
     C**
     C                   endsr
     C***************************************************************
     C** - DoPos : Position us in the subfile
     C***************************************************************
     C     DoPos         begsr
     C**
     C** - Refresh the screen
     C**
     C                   exsr      Refresh
     C**
     C** - Loop until we find the string or EOF
     C**
     C                   Dow       (PosTo>@Sname)and (@EOF='N')
     C                   exsr      RollUp
     C                   enddo                                                  @POS>@SName
     C**
     C** - Position the cursor...
     C** - ...unless the last entry is less than PosTo
     C** - @SName will give us the last SName put to the SF
     C**
     C                   if        @SName > PosTo
     C                   eval      RdCtr=TopCtr
     C     RdCtr         chain     NMELSSF                            91
     C                   Dow       PosTo>SName
     C                   eval      RdCtr         =RdCtr+1
     C     RdCtr         chain     NMELSSF                            91
     C                   enddo                                                  PosTo>SName
     C**
     C                   eval      TopCtr=RdCtr
     C                   endif                                                  @SName>POST
     C**
     C                   eval      PosTo=*blanks
     C**
     C                   endsr
     C***************************************************************
     C** - ProcSF: Process the subfile
     C***************************************************************
     C     ProcSF        begsr
     C**
     C                   eval      Cancel='N'
     C**
     C                   for       iRow=1 to TotSF#
     C                   eval      RdCtr=iRow
     C     RdCtr         chain     NMELSSF                            91
     C**
     C                   select
     C** - Delete?
     C                   when      Select='D'
     C                   exsr      DltRec
     C** - Edit?
     C                   when      Select='E'
     C                   exsr      EdtRec
     C** - ???
     C                   when      select<>*blanks
     C                   exsr      IvdOpt
     C**
     C** - No selection here - clear the subfile error indicator
     C** - if it was set.
     C**
     C                   other
     C                   exsr      ClrSFI
     C                   if        @SFI='Y'
     C                   update    NMELSSF
     C                   endif
     C**
     C                   endsl
     C**
     C** - Vamouse outta here if Cancel
     C**
     C                   if        Cancel='Y'
     C                   eval      DspMsg='Cancelled'
     C                   leave
     C                   endif                                                  Cancel=Y
     C**
     C                   endfor                                                 1 TO IROW
     C**
     C                   endsr
     C***************************************************************
     C** - LoadSF: Load a page to the subfile.
     C** - Sets @EOF to 'Y' if EOF 'N' if not.
     C** - updates TopCTR: Pointing to top of screen
     C** -         BOTCTR: Pointing to bottom of screen
     C***************************************************************
     C     LoadSF        begsr
     C**
     C** - Do nothing if EOF
     C**
     C                   if        @EOF<>'Y'
     C                   eval      @EOF='N'
     C                   eval      Count=0
     C**
     C** - Loop for number of rows in the subfile
     C**
     C                   for       iRow=1 to SFPag
     C**
     C** - Next record from the database
     C**
     C                   read      NMELSTF                                90
     C**
     C** - Check for EOF...if this is first time through
     C** - we never wrote anything to the subfile...so
     C** - we will write a 'nothing there' message.
     C**
     C**
     C                   if        *in90='1'
     C                   eval      @EOF='Y'
     C                   if        iRow=1
     C                   exsr      putnr
     C                   Z-ADD     1             TopCTR
     C                   else
     C                   exsr      PutEOF
     C                   endif                                                  I=1
     C                   leave
     C                   endif                                                  90=1
     C**
     C** - Put this record to the screen
     C**
     C                   exsr      PutSF
     C                   add       1             Count
     C**
     C                   endfor                                                 1 to SFPagE
     C**
     C                   eval      TopCtr=BotCtr+1
     C                   add       Count         BotCtr                         BOTTOM REC
     C                   endif                                                  Not EOF
     C**
     C                   endsr
     C***************************************************************
     C** - PutSF : write a database record to the subfile
     C***************************************************************
     C     PutSF         begsr
     C**
     C     *Like         define    SName         @SName
     C**
     C                   exsr      DB2SF
     C                   write     NMELSSF
     C                   eval      @SName=SName
     C                   add       1             RdCtr
     C**
     C                   endsr
     C***************************************************************
     C** - putnr : Put no records in the database message
     C***************************************************************
     C     putnr         begsr
     C**
     C                   seton                                        40        Prtct select
     C                   eval      SName='(no records on file)'
     C                   eval      sPhone=*blanks
     C                   eval      sEmail=*blanks
     C                   write     NMELSSF
     C                   add       1             RdCtr
     C**
     C                   endsr
     C***************************************************************
     C** - PutEOF : Put end of file message
     C***************************************************************
     C     PutEOF        begsr
     C**
     C                   seton                                        40
     C                   eval      prikey=0
     C                   eval      sName=*blanks
     C                   eval      sPhone='End of list'
     C                   eval      sEmail=*blanks
     C                   eval      Select=*blanks
     C                   write     NMELSSF
     C                   add       1             RdCtr
     C**
     C                   endsr
     C***************************************************************
     C** - DB2SF : Database fields to subfile fields
     C***************************************************************
     C     DB2SF         begsr
     C**
     C** - Clear the subfile error indicators
     C**
     C                   exsr      ClrSFI
     C                   eval      Select=*blanks
     C**
     C**- Parsing the name is much easier with RPGLE!
     C**- (Compare this routine with the RPG III version).
     C**
     C                   eval      SName=%trim(NmeLst) + ', '
     C                              + %trim(NmeFst) + ' ' + %trim(NmeMid)
     C**
     C** - The other two are easy - first 16 chars of phone number
     C** - and the first 20 or the email address
     C**
     C                   eval      sPhone=Phone#
     C                   eval      sEmail=Email@
     C**
     C                   endsr
     C***************************************************************
     C** - Dlt2SF : Deleted record to subfile
     C***************************************************************
     C     Dlt2SF        begsr
     C**
     C** - Clear the subfile error indicators
     C**
     C                   exsr      ClrSFI
     C**
     C** - Deleted record message
     C**
     C                   eval      Select=*blanks
     C                   eval      SName='(Deleted)'
     C                   eval      sPhone=*blanks
     C                   eval      sEmail=*blanks
     C**
     C                   endsr
     C***************************************************************
     C** - ClrSFI: Clear subfile error indicators
     C** - Sets @SFI = 'Y' if an error indicator had been set
     C** - Sets @SFI = 'N' if not.
     C***************************************************************
     C     ClrSFI        begsr
     C**
     C** - Add additional indicators as needed
     C** - !!! Besure to include new indicators both places
     C**
     C                   if        (*in40='1') or (*in42='1')
     C                   eval      @SFI='Y'
     C                   setoff                                       4042
     C                   else
     C                   eval      @SFI='N'
     C                   endif                                                  40 | 42=1
     C**
     C                   endsr
     C***************************************************************
     C** - AddRec: Add record
     C***************************************************************
     C     AddRec        begsr
     C**
     C** - NewKey sets @PriKey to a unique key
     C**
     C                   exsr      NewKey
     C                   eval      PriKey=@PriKey
     C                   eval      NmeFst=*blanks
     C                   eval      NmeLst=*blanks
     C                   eval      NmeMid=*blanks
     C                   eval      Phone#=*blanks
     C                   eval      Email@=*blanks
     C                   exfmt     DETAIL
     C**
     C** - Add the record unless Cancel.
     C**
     C                   if        (*inkc='0') and (*inkl='0')
     C**
     C** - Get primary key again in case someone
     C** - grabbed the last one.
     C**
     C                   exsr      NewKey
     C                   eval      PriKey=@PriKey
     C                   write     NMELSTF
     C**
     C                   endif                                                  KL=0
     C**
     C                   endsr
     C***************************************************************
     C** - DltRec: Delete routine
     C***************************************************************
     C**
     C     DltRec        begsr
     C     PRIKEY        chain     BYPRIKEY                           99
     C                   if        *in99='0'
     C                   seton                                          41
     C                   eval      Ok2Dlt='N'
     C                   exfmt     DETAIL
     C**
     C                   select
     C**
     C** - F3 Keyed? No further action if Exit
     C**
     C                   when      *inkc='1'
     C**                 noop
     C**
     C** - F12 Keyed? Set Cancel flag if Cancel
     C**
     C                   when      *inkl='1'
     C                   eval      Cancel='y'
     C**
     C** - Enter keyed here - delete if OK2DLT
     C**
     C                   other
     C                   if        Ok2Dlt='Y'
     C                   delete    BYPRIKEY
     C                   exsr      ClrSFI
     C                   exsr      Dlt2SF
     C                   update    NMELSSF
     C                   endif
     C**
     C                   endsl
     C**
     C** - Should never get here.
     C**
     C                   endif                                                  99=0
     C**
     C                   endsr
     C***************************************************************
     C** - EdtRec: Edit routine
     C***************************************************************
     C     EdtRec        begsr
     C**
     C     PRIKEY        chain     BYPRIKEY                           99
     C                   if        *in99='0'
     C                   setoff                                         41
     C                   dou          *inkc='1'
     C                             or *inki='1'
     C                             or *inkl='1'
     C                   exfmt     DETAIL
     C                   select
     C**
     C** - F3 Keyed? No further action if Exit
     C**
     C                   when      *inkc='1'
     C**                 noop
     C**
     C** - F12 Keyed? Set Cancel flag if Cancel
     C**
     C                   when      *inkl='1'
     C                   eval      Cancel='y'
     C**
     C** - Enter keyed OR F9 here - update
     C**
     C                   other
     C                   exsr      ClrSFI
     C                   update    BYPRIKEY
     C                   exsr      DB2SF
     C**
     C** - If that wasn't an F9, we're staying
     C** - so re-grab the record
     C**
     C                   update    NMELSSF
     C                   if        *inki='1'
     C     PRIKEY        chain     BYPRIKEY                           99
     C     RdCtr         chain     NMELSSF                            91
     C                   endif                                                  *INKI<>1
     C**
     C                   endsl
     C                   enddo                                                  KC,KI,KL
     C**
     C** - Should never get here
     C**
     C                   endif                                                  99=0
     C**
     C                   endsr
     C***************************************************************
     C** - IvdOpt: Invalid Option
     C***************************************************************
     C     IvdOpt        begsr
     C**
     C                   exsr      ClrSFI
     C                   eval      Select=*blanks
     C                   seton                                        42
     C                   update    NMELSSF
     C**
     C                   endsr
     C***************************************************************
     C** - NewKey: Get a new Primary Key
     C***************************************************************
     C     NewKey        begsr
     C**
     C                   eval      SveKey=PriKey
     C                   eval      SveFst=NmeFst
     C                   eval      SveLst=NmeLst
     C                   eval      SveMid=NmeMid
     C                   eval      SvePho=Phone#
     C                   eval      SveEma=Email@
     C**
     C     *HIVAL        setll     BYPRIKEY
     C                   readP     BYPRIKEY                               99
     C                   if        *in99='1'
     C                   eval      @PriKey=1
     C                   else
     C                   eval      @PriKey=PriKey+1
     C                   endif                                                  99=1
     C**
     C** - Like your mother said - put everything back
     C** - the way you found it.
     C**
     C                   eval      PriKey=SveKey
     C     PriKey        chain     BYPRIKEY                           99
     C                   eval      NmeFst=SveFst
     C                   eval      NmeLst=SveLst
     C                   eval      NmeMid=SveMid
     C                   eval      Phone#=SvePho
     C                   eval      Email@=SveEma
     C**
     C                   endsr






     A***************************************************************
     A** - Source Member: NMELSTS
     A***************************************************************
     A** - Simple Name List Program
     A** - RPG III Supfield Example
     A** - Jon Vote 09/2002
     A** - www.idioma-software.com
     A***************************************************************
     A**
     A** - Related source members:
     A** -   NMELSTR: Simple Name List Program
     A**     NMELSTP: Pysical file used with NMELSTR
     A**     NMELST1: Logical over NMELSTP
     A**     NMELSTS: Display File used with NMELSTR
     A**
     A*%%TS  SD  20020916  192219  VOTEJM      REL-V5R1M0  5722-WDS
     A*%%EC
     A                                      DSPSIZ(24 80 *DS3)
     A          R NMELSSF                   SFL
     A*%%TS  SD  20020915  212042  VOTEJM      REL-V5R1M0  5722-WDS
     A            PRIKEY         9S 0H
     A            SNAME         25A  O  7  9
     A            SPHONE        14A  O  7 37
     A            SEMAIL        25A  O  7 54
     A            SELECT         1A  B  7  6
     A  40                                  DSPATR(PR)
     A  42                                  DSPATR(RI)
     A  40                                  DSPATR(ND)
     A          R NMELSCTL                  SFLCTL(NMELSSF)
     A*%%TS  SD  20020916  192219  VOTEJM      REL-V5R1M0  5722-WDS
     A                                      SFLSIZ(0016)
     A                                      SFLPAG(0015)
     A                                      CF03
     A                                      CF05
     A                                      CF06
     A                                      ROLLUP(81)
     A                                      ROLLDOWN(82)
     A                                      OVERLAY
     A N20                                  SFLDSP
     A N20                                  SFLDSPCTL
     A  20                                  SFLCLR
     A            RDCTR          4S 0H      SFLRCDNBR(CURSOR)
     A                                  1 27'Simple Name List Program'
     A                                      COLOR(WHT)
     A                                  2 23'Subfile Example - Jon Vote - 2002'
     A                                      COLOR(WHT)
     A                                  5  9'Name'
     A                                  5 37'Phone'
     A                                  5 43'Number'
     A                                  5 54'Email Address'
     A                                  3 28'www.idioma-software.com'
     A                                      COLOR(TRQ)
     A                                      DSPATR(UL)
     A                                  6  9'-------------------------   -------
     A                                      --------   -------------------------
     A                                      -'
     A                                  3 62'Cursor'
     A                                      COLOR(YLW)
     A                                  3 69'Row:'
     A                                      COLOR(YLW)
     A                                  4 69'Col:'
     A                                      COLOR(YLW)
     A            CRSROW         2S 0O  3 76COLOR(YLW)
     A            CRSCOL         2S 0O  4 76COLOR(YLW)
     A                                  3  6'D=Delete E=Edit'
     A                                      COLOR(BLU)
     A                                  4  9'Position to:'
     A            POSTO         25A  B  4 22CHECK(LC)
     A            TOTSF#         4  0O  2 74COLOR(YLW)
     A                                  2 58'Number'
     A                                      COLOR(YLW)
     A                                  2 65'Records:'
     A                                      COLOR(YLW)
     A          R FOOTER
     A*%%TS  SD  20020915  194912  VOTEJM      REL-V5R1M0  5722-WDS
     A                                      OVERLAY
     A                                 23  2'F3=Exit'
     A                                      COLOR(BLU)
     A  13        DSPMSG        78A  O 24  2DSPATR(RI)
     A                                 23 23'F6=Add'
     A                                      COLOR(BLU)
     A                                 23 11'F5=Refresh'
     A                                      COLOR(BLU)
     A          R DETAIL
     A*%%TS  SD  20020916  164318  VOTEJM      REL-V5R1M0  5722-WDS
     A                                      CF03
     A N41                                  CF09
     A                                      CF12
     A                                  1 27'Simple Name List Program'
     A                                      COLOR(WHT)
     A                                  2 23'Subfile Example - Jon Vote - 2002'
     A                                      COLOR(WHT)
     A                                 23  2'F3=Exit'
     A                                      COLOR(BLU)
     A  13        DSPMSG        78A  O 24  2DSPATR(RI)
     A                                 23 33'F12=Cancel'
     A                                      COLOR(BLU)
     A                                  6 10'Record ID.....:'
     A            PRIKEY         9S 0O  6 26
     A                                  3 28'www.idioma-software.com'
     A                                      COLOR(TRQ)
     A                                      DSPATR(UL)
     A                                  7 10'First Name....:'
     A            NMEFST        15A  B  7 26
     A  41                                  DSPATR(PR)
     A                                      CHECK(LC)
     A                                  9 10'Last Name.....:'
     A            NMELST        15A  B  9 26
     A  41                                  DSPATR(PR)
     A                                      CHECK(LC)
     A                                  8 10'Middle Initial:'
     A            NMEMID         1A  B  8 26
     A  41                                  DSPATR(PR)
     A                                      CHECK(LC)
     A                                 10 10'Phone Number..:'
     A                                 11 10'Email Address.:'
     A            PHONE#        40A  B 10 26
     A  41                                  DSPATR(PR)
     A                                      CHECK(LC)
     A            EMAIL@        40A  B 11 26
     A  41                                  DSPATR(PR)
     A                                      CHECK(LC)
     A  41                             14 10'Delete record - are you sure?:'
     A                                      COLOR(RED)
     A  41        OK2DLT         1A  B 14 41
     A N41                             23 12'F9=Update and exit'
     A                                      COLOR(BLU)






     A**************************************************************
     A** - Source Member: NMELSTP - Simple Name List File
     A**************************************************************
     A**
     A** - Jon Vote
     A** - 09/2002
     A**
     A** - Related source members:
     A** -   NMELSTR: Simple Name List Program
     A**     NMELSTP: Pysical file used with NMELSTR
     A**     NMELST1: Logical over NMELSTP
     A**     NMELSTS: Display File used with NMELSTR
     A**
     A** - This file is used for the Name List subfile example
     A** - only and is not meant to demonstrate a properly
     A** - normalized database.
     A**
     A                                      UNIQUE
     A          R NMELSTF                   TEXT('NAME LIST')
     A**
     A            PRIKEY         9S 0       TEXT('Primary Key')
     A            NMEFST        15          TEXT('First Name')
     A            NMEMID         1          TEXT('Middle Initial')
     A            NMELST        15          TEXT('Last Name')
     A            PHONE#        40          TEXT('Phone Number')
     A            EMAIL@        40          TEXT('Email Address')
     A**
     A** - This key is being defined here to simplify the example.
     A** - Normally you should not key a physical file.
     A**
     A          K NMELST
     A          K NMEFST
     A          K NMEMID
     A          K PHONE#
     A          K PRIKEY






     A**************************************************************
     A** - Source Member: NMELST1 - Simple Name List File - By PRIKEY
     A**************************************************************
     A**
     A** - Jon Vote
     A** - 09/2002
     A** - www.idioma-software.com
     A**
     A** - Related source members:
     A** -   NMELSTR: Simple Name List Program
     A**     NMELSTP: Pysical file used with NMELSTR
     A**     NMELST1: Logical over NMELSTP
     A**     NMELSTS: Display File used with NMELSTR
     A**
     A                                      UNIQUE
     A          R NMELSTF                   PFILE(NMELSTP)
     A          K PRIKEY

This article has been viewed 20997 times.
The examples on this page are presented "as is". They may be used in code as long as credit is given to the original author. Contents of this page may not be reproduced or published in any other manner what so ever without written permission from Idioma Software Inc.