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