F***************************************************************
F**
F** - Note, this example is made up of 4 source members:
F**
F** NMELSTR - RPG
F** NMELSTS - DSPF
F** NMELSTP - PF
F** NMELST1 - LF
F**
F** - If you are copying this off or the web, be sure to
F** - break the text up into the appropriate sections.
F** - You will find 6 blank lines between each source member.
F**
F***************************************************************
F** - Source Member: NMELSTR
F***************************************************************
F** - Simple Name List Program
F** - RPG III 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 E K DISK A
F**
F** - By PRIKEY
F**
FNMELST1 UF E K DISK
F NMELSTF KRENAMEBYPRIKEY
F**
F** - Subfile - lists names in alpha order, allows selection
F**
FNMELSTS CF E WORKSTN
F RDCTR KSFILE NMELSSF
F KINFDS FILEDS
E**
E** - Used to parse the name
E**
E @NM 15 1
E SNM 25 1
E**
E** - User messages
E**
E MSG 1 10 78
IFILEDS DS
I B 370 3710ROWCOL
I B 376 3770SFRR#
I B 378 3790TOPSF#
I B 380 3810TOTSF#
I**
I** - Subfile records per page
I**
I 15 C SFPAG
I**
I** - Max length of the parsed name field
I**
I 25 C PNMLEN
I**
I** - Length of name field in the database
I**
I 15 C NMELEN
I**
I** - Used for parsing the name fields
I**
ISNAME DS
I 1 25 SNM
I@NAME DS
I 1 15 @NM
C *LIKE DEFN RDCTR COUNT BOT OF PGE
C *LIKE DEFN RDCTR TOPCTR TOP OF PGE
C *LIKE DEFN RDCTR BOTCTR BOT OF PGE
C**
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 *INKC DOWEQ'0' F3
C**
C** - React to user input
C**
C SELEC
C *INKC WHEQ '1' F3
C LEAVE
C *INKE WHEQ '1' F6
C EXSR REFRSH
C *INKF WHEQ '1' F6
C EXSR ADDREC
C *IN81 WHEQ '1'
C EXSR ROLLUP
C *IN82 WHEQ '1'
C EXSR ROLLDN
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 WRITENMELSCTL
C SETOF 20
C**
C** - Load the first screen
C**
C *LOVAL SETLLNMELSTF
C Z-ADD1 RDCTR
C Z-ADD0 TOPCTR TOP OF PGE
C Z-ADD0 BOTCTR BOT OF PGE
C MOVEL'N' @EOF 1
C EXSR LOADSF
C**
C ENDSR
C***************************************************************
C** - PAINT: Paint the screen
C***************************************************************
C PAINT BEGSR
C**
C Z-ADDTOPCTR RDCTR
C WRITEFOOTER
C EXFMTNMELSCTL
C Z-ADDTOPSF# TOPCTR
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 BOTCTR ADD 1 RDCTR
C EXSR LOADSF
C**
C ENDSR
C***************************************************************
C** - ROLLDN: Rolldown Routine
C***************************************************************
C ROLLDN BEGSR
C**
C** - We get here at BOF
C**
C ENDSR
C***************************************************************
C** - REFRESH: Refresh
C***************************************************************
C REFRSH 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 20
C MVR CRSCOL 20
C**
C** - Ignore the subfile if the user is positioning
C** - otherwise iterate through the subfile
C**
C POSTO IFNE *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 REFRSH
C**
C** - Loop until we find the string or EOF
C**
C POSTO DOWGT@SNAME
C @EOF ANDEQ'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 @SNAME IFGT POSTO
C Z-ADDTOPCTR RDCTR
C RDCTR CHAINNMELSSF 91
C POSTO DOWGTSNAME
C ADD 1 RDCTR
C RDCTR CHAINNMELSSF 91
C ENDDO POSTO>SNAME
C**
C Z-ADDRDCTR TOPCTR
C ENDIF @SNAME>POST
C**
C MOVEL*BLANKS POSTO
C**
C ENDSR
C***************************************************************
C** - PROCSF: Process the subfile
C***************************************************************
C PROCSF BEGSR
C**
C MOVEL'N' CANCEL 1
C**
C 1 DO TOTSF# IROW
C Z-ADDIROW RDCTR
C RDCTR CHAINNMELSSF 91
C**
C SELEC
C** - Delete?
C SELECT WHEQ 'D'
C EXSR DLTREC
C** - Edit?
C SELECT WHEQ 'E'
C EXSR EDTREC
C** - ???
C SELECT WHNE *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 @SFI IFEQ 'Y'
C UPDATNMELSSF
C ENDIF
C**
C ENDSL
C**
C** - Vamouse outta here if Cancel
C**
C CANCEL IFEQ 'Y'
C MOVELMSG,2 DSPMSG
C SETON 13
C LEAVE
C ENDIF CANCEL=Y
C**
C ENDDO 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 @EOF IFNE 'Y'
C MOVEL'N' @EOF 1
C Z-ADD0 COUNT
C**
C** - Loop for number of rows in the subfile
C**
C 1 DO SFPAG IROW 30
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 *IN90 IFEQ '1' EOF?
C MOVEL'Y' @EOF 1
C I IFEQ 1 1st Time?
C EXSR PUTNR
C Z-ADD1 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 ENDDO 1 to SFPAGE
C**
C BOTCTR ADD 1 TOPCTR TOP REC
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 DEFN SNAME @SNAME
C**
C EXSR DB2SF
C WRITENMELSSF
C MOVELSNAME @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 MOVELMSG,1 SNAME No Recs Msg
C MOVEL*BLANKS SPHONE
C MOVEL*BLANKS SEMAIL
C WRITENMELSSF
C ADD 1 RDCTR
C**
C ENDSR
C***************************************************************
C** - PUTEOF : Put end of file message
C***************************************************************
C PUTEOF BEGSR
C**
C SETON 40
C MOVEL*ZEROS PRIKEY
C MOVEL*BLANKS SNAME
C MOVELMSG,3 SPHONE
C MOVEL*BLANKS SEMAIL
C MOVEL*BLANKS SELECT
C WRITENMELSSF
C ADD 1 RDCTR
C**
C ENDSR
C***************************************************************
C** - DB2SF : Database fields to subfile fields
C***************************************************************
C DB2SF BEGSR
C**
C *LIKE DEFN @L S
C**
C** - Clear the subfile error indicators
C**
C EXSR CLRSFI
C**
C**- We will parse the name into one field in the form:
C**- LastName, FirstName M
C**
C MOVEL*BLANKS SELECT
C MOVEA*BLANKS SNM
C MOVEANMELST SNM
C**
C** - GETLEN will set @L to the length of @NM
C**
C MOVELNMELST @NAME
C EXSR GETLEN
C**
C** - We want a comma just to the right of @L
C**
C @L ADD 1 S
C MOVEL',' SNM,S
C**
C** - First name goes next with a leading blank
C**
C ADD 2 S
C MOVEANMEFST SNM,S
C**
C** - Let's see how long the first name is
C**
C MOVELNMEFST @NAME
C EXSR GETLEN
C**
C** - Update S to point past the first name to where the middle
C** - initial would go.
C**
C ADD @L S
C ADD 1 S
C**
C** - Put the middle initial here if enough roowm
C**
C S IFLE PNMLEN
C MOVELNMEMID SNM,S
C ENDIF S<PNMLEN
C**
C** - The other two are easy - first 16 chars of phone number
C** - and the first 20 or the email address
C**
C MOVELPHONE# SPHONE
C MOVELEMAIL@ SEMAIL
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 MOVEL*BLANKS SELECT
C MOVEL*BLANKS SNAME
C MOVEL'(Deleted'TEMP9 9
C MOVE ')' TEMP9
C MOVELTEMP9 SNAME
C MOVEL*BLANKS SPHONE
C MOVEL*BLANKS SEMAIL
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 *IN40 IFEQ '1'
C *IN42 OREQ '1'
C MOVEL'Y' @SFI 1
C SETOF 4042
C ELSE
C MOVEL'N' @SFI
C ENDIF 40 | 42=1
C**
C ENDSR
C***************************************************************
C** - GETLEN: Returns length of name field.
C** - Expects @NAME to be set to the name, set @L to the length
C***************************************************************
C GETLEN BEGSR
C**
C** @L will be zero if the string is all blanks.
C**
C Z-ADD0 @L 30
C Z-ADDNMELEN I 30
C**
C** - Loop through the string starting from the
C** - end of the string to the beginning.
C**
C I DOWGT0
C**
C** - We're done when we find a non-blank
C**
C @NM,I IFNE *BLANKS
C Z-ADDI @L
C LEAVE
C ENDIF
C**
C** - Found a blank if here, decrement I
C**
C SUB 1 I
C ENDDO -1 = Decrement
C**
C** - @L has the lengh of the string here.
C**
C ENDSR
C***************************************************************
C** - ADDREC: Add record
C***************************************************************
C ADDREC BEGSR
C**
C** - NEWKEY sets @PRIKY to a unique key
C**
C EXSR NEWKEY
C Z-ADD@PRIKY PRIKEY
C MOVEL*BLANKS NMEFST
C MOVEL*BLANKS NMELST
C MOVEL*BLANKS NMEMID
C MOVEL*BLANKS PHONE#
C MOVEL*BLANKS EMAIL@
C EXFMTDETAIL
C**
C** - Add the record unless cancel.
C**
C *INKC IFEQ '0' F3
C *INKL ANDEQ'0' F12
C**
C** - Get primary key again in case someone
C** - grabbed the last one.
C**
C EXSR NEWKEY
C Z-ADD@PRIKY PRIKEY
C WRITENMELSTF
C**
C ENDIF KL=0
C**
C ENDSR
C***************************************************************
C** - DLTREC: Delete routine
C***************************************************************
C**
C DLTREC BEGSR
C PRIKEY CHAINBYPRIKEY 99
C *IN99 IFEQ '0'
C SETON 41
C MOVEL'N' OK2DLT
C EXFMTDETAIL
C SELEC
C**
C** - F3 Keyed? No further action if Exit
C**
C *INKC WHEQ '1' F3 - Exit
C** NOOP
C**
C** - F12 Keyed? Set cancel flag if Cancel
C**
C *INKL WHEQ '1' F12 - Cancel
C MOVEL'Y' CANCEL
C**
C** - Enter keyed here - delete if OK2DLT
C**
C OTHER
C OK2DLT IFEQ 'Y'
C DELETBYPRIKEY
C EXSR CLRSFI
C EXSR DLT2SF
C UPDATNMELSSF
C ENDIF
C**
C ENDSL
C**
C** - No record found.
C** - Something went wrong here!
C**
C ENDIF 99=0
C**
C ENDSR
C***************************************************************
C** - EDTREC: Edit routine
C***************************************************************
C EDTREC BEGSR
C**
C PRIKEY CHAINBYPRIKEY 99
C *IN99 IFEQ '0'
C SETOF 41
C *INKC DOUEQ'1' F3
C *INKI OREQ '1' F9
C *INKL OREQ '1' F12
C EXFMTDETAIL
C SELEC
C**
C** - F3 Keyed? No further action if Exit
C**
C *INKC WHEQ '1' F3 - Exit
C** NOOP
C**
C** - F12 Keyed? Set cancel flag if Cancel
C**
C *INKL WHEQ '1' F12 - Cancel
C MOVEL'Y' CANCEL
C**
C** - Enter keyed OR F9 here - update
C**
C OTHER
C EXSR CLRSFI
C UPDATBYPRIKEY
C EXSR DB2SF
C**
C** - If that wasn't an F9, we're staying
C** - so re-grab the record
C**
C UPDATNMELSSF
C *INKI IFNE '1' F9
C PRIKEY CHAINBYPRIKEY 99
C RDCTR CHAINNMELSSF 91
C ENDIF *INKI<>1
C**
C ENDSL
C ENDDO KC,KI,KL
C**
C** - No record found.
C** - Something went wrong here!
C**
C ENDIF 99=0
C**
C ENDSR
C***************************************************************
C** - IVDOPT: Invalid Option
C***************************************************************
C IVDOPT BEGSR
C**
C EXSR CLRSFI
C MOVEL*BLANKS SELECT
C SETON 42
C UPDATNMELSSF
C**
C ENDSR
C**
C***************************************************************
C** - NEWKEY: Get a new PRIMARYKEY
C***************************************************************
C NEWKEY BEGSR
C**
C *LIKE DEFN PRIKEY @PRIKY
C *LIKE DEFN PRIKEY SVEKEY
C *LIKE DEFN NMEFST SVEFST
C *LIKE DEFN NMELST SVELST
C *LIKE DEFN NMEMID SVEMID
C *LIKE DEFN PHONE# SVEPHO
C *LIKE DEFN EMAIL@ SVEEMA
C**
C Z-ADDPRIKEY SVEKEY
C MOVELNMEFST SVEFST
C MOVELNMELST SVELST
C MOVELNMEMID SVEMID
C MOVELPHONE# SVEPHO
C MOVELEMAIL@ SVEEMA
C**
C *HIVAL SETLLBYPRIKEY
C READPBYPRIKEY 99
C *IN99 IFEQ '1'
C Z-ADD1 @PRIKY
C ELSE
C PRIKEY ADD 1 @PRIKY
C ENDIF 99=1
C**
C** - Like your mother said - put everything back
C** - the way you found it.
C**
C Z-ADDSVEKEY PRIKEY
C PRIKEY CHAINBYPRIKEY 99
C MOVELSVEFST NMEFST
C MOVELSVELST NMELST
C MOVELSVEMID NMEMID
C MOVELSVEPHO PHONE#
C MOVELSVEEMA EMAIL@
C**
C ENDSR
** - MSG - User messages
(no records on file)
Cancelled.
End of list.
...(additional messages go here)...
...(additional messages go here)...
...(additional messages go here)...
...(additional messages go here)...
...(additional messages go here)...
...(additional messages go here)...
...(additional messages go here)...
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** - 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** - 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