AS/400 Code Samples - AS/400 - SUBFILE1- Simple RPG-LE Subfile Example Author: George Pearson Company: Green Springs Software, Inc. www.green-springs.com Purpose: Simple RPG-ILE Subfile Program Example Components: SUBFILER RPG-LE SUBFILED Display File SUBFILEP Physical File Parameters: *None Written: 2003 ¹*---------------------------------------------------------------------------------------------* ¹* GREEN SPRINGS SOFTWARE, INC www.green-springs.com * ¹*--------------------------------------------------------------------------------------------* ¹* Object Name: SUBFILER RPG-ILE Program * ¹* Purpose : A Simple Subfile Program Example * ¹* Description: Maintain Account Distribution by Employee * ¹* Narrative : This program allows maintenamce to a custom table file * ¹* SUBFILEP. * ¹* Creation : 01/30/2003 * ¹* Author : George Pearson, Green Springs Software, Inc. * ¹*--------------------------------------------------------------------------------------------* ¹*--------------------------------------------------------------------------------------------* ¹* Modifications * ¹* * ¹* --Date-- Who Scan For -------- C O M M M E N T S -----------------------------------------* ¹* 01/30/03 GWP New program * ¹*--------------------------------------------------------------------------------------------* FSUBFILEP UF A E K DISK FSUBFILED CF E WORKSTN SFILE(SFL1:@RR#) F INFDS(WORKS) FPRLMS IF E K DISK FPRLCO IF E K DISK FPRLUD IF E K DISK D******************************************************************** * éPrompting Data Structures * ¹------------------------- D DPARMS DS D XDATA 1 256 D YDATA 1 128 D @WER 129 131 D @WLVL1 132 136 D @WLVL2 137 141 D @WLVL3 142 146 D @WLVL4 147 151 D @WTYPE 151 153 D @WFIVE 154 158 D @WEN 159 167 D @WDTYP 169 169 D @WTIM 170 175 0 D @WNM 184 201 D @WPLVL 233 234 0 D @WPSEQ 235 239 0 D DS D ZDATA 1 128 D @VER 1 3 D ZVL01 4 8 D ZVL02 9 13 D ZVL03 14 18 D ZVL04 19 23 D @VTYPE 24 26 D @VFIVE 27 31 D ZREN 32 40 D @VDTYP 41 41 D ZRLNM 42 59 D @VPLVL 60 61 0 D @VPSEQ 62 66 0 * éDisplay File Information Data Structure * ¹--------------------------------------- D WORKS DS D STDFIL *FILE D STDFMT *RECORD D STCMDK 287 310 D STACTN 368 369B 0 D STCSRP 370 371B 0 D STSFLR 378 379B 0 * éProgram Status Data Structure * ¹----------------------------- D SDS D @PGM *PROC D @USER 254 263 * éWorking Variables * ¹----------------- D @CALTYP S 1 D* @LINE S 2 0 D* @LR S Like(*InLR) D* @POS S 2 0 D @RELOAD S Like(*In01) D @RPG S 6 D @SAVIN S 24 D @SAVKY S 24 D @SV_PCT S Like(JDPCT) * éConstants * ¹--------- D @CONS1 C 'Employer Code is Invalid' D @CONS2 C 'Employee Number is Invalid' D @CONS3 C 'Percentages do not total 100%' D @CONS4 C '< -- Add new line here' * éFinally. The Calculations. * ¹--------------------------- C @KEY_JDE KLIST C KFLD @ER C KFLD @EN C @KEY_JDE3 KLIST C KFLD @ER C KFLD @EN C KFLD JDAID C @KEY_PR KLIST C KFLD @ER C KFLD @EN C HPLIST PLIST C PARM STDFIL C PARM STDFMT C PARM @LINE 2 0 C PARM @POS 2 0 C PARM *INLR LR 1 C DSPARM PLIST C PARM STDFIL C PARM STDFMT C PARM @LINE C PARM @POS C PARM *INLR LR C PARM XDATA C PARM FIELD 6 C EXSR SR_CLR_SF * C DOU *In03 = *On C EXFMT SCREEN1 C IF *In03 = *Off * C EXSR SR_CNVRT C STACTN CASEQ 241 SR_PROC C STACTN CASEQ 243 SR_HELP C STACTN CASEQ 52 SR_DSPLAY C STACTN CASEQ 49 SR_QUIT C STACTN CASEQ 51 SR_QUIT C CAS SR_NODEF C EndCS C EndIF C EndDO * C EXSR SR_QUIT * *ã******************************************************************************************** * ¹~SR_PROC - Process Responses * *ã******************************************************************************************** CSR SR_PROC BegSR C DOW *In12 = *Off C EVAL @ERR = *Blanks C EVAL *In71 = *Off C EVAL *In72 = *Off C @ER CHAIN PRRCO 71 C IF *In71 = *On C EVAL *In12 = *On C EVAL @ERR = @CONS1 C Else C @KEY_PR CHAIN PRRMS 72 C IF *In72 = *On C EVAL *In12 = *On C EVAL @ERR = @CONS2 C Else C EVAL UDNB3 = *Zero C @KEY_PR CHAIN PRRUD C EVAL @NB3 = UDNB3 C MOVE UDNB3 JDAN8 C EndIF C EndIF * C IF *In71 = *Off And *In72 = *Off C EXSR SR_CLR_SF C EXSR SR_LOADSF C EXSR SR_SFL C IF *In12 = *On C LEAVE C EndIf C EndIF C EndDO CSR EndSR *ã******************************************************************************************** * ¹~SR_LOADSF - Load the Subfile * *ã******************************************************************************************** CSR SR_LOADSF BegSR C @KEY_JDE SETLL FORMAT1 C EVAL *In61 = *Off C EVAL *In62 = *Off C EVAL @PCT = *Zero C DOU *In61 = *On C @KEY_JDE READE FORMAT1 61 C IF *In61 = *Off C EVAL *In31 = *Off C EVAL @SELECT = *Blank C EVAL @HPCT = JDPCT C EVAL @PCT = @PCT + JDPCT C EVAL @RR# = @RR# + 1 C EVAL @COMMENT = *Blank C WRITE SFL1 C EndIF C EndDO C EVAL *In31 = *On C EVAL @SELECT = *Blank C EVAL JDAID = *Blank C EVAL JDPCT = *Zero C EVAL @HPCT = *Zero C EVAL @RR# = @RR# + 1 C EVAL @COMMENT = @CONS4 C WRITE SFL1 C IF @PCT <> 100 C EVAL *In62 = *On C EVAL @ERR = @CONS3 C EndIF CSR EndSR *ã******************************************************************************************** * ¹~SR_CLR_SF - Clear the Subfile * *ã******************************************************************************************** CSR SR_CLR_SF BegSR C MOVEA '001' *IN(41) C WRITE CTL1 C MOVEA '110' *IN(41) C EVAL @SELECT = *Blank C EVAL @RR# = *Zero CSR EndSR *ã******************************************************************************************** * ¹~SR_SFL - Display Subfile * *ã******************************************************************************************** CSR SR_SFL BegSR C EVAL @RR# = 1 C DOW *In03 = *Off C WRITE FOOT C EXFMT CTL1 C IF *In12 = *On C EXSR SR_CLR_SF C LEAVE C EndIf C *In03 CASEQ *On SR_QUIT C CAS SR_PROC1 C ENDCS C EndDO CSR EndSR *ã******************************************************************************************** * ¹~SR_DSPLAY - Prompt key Handling, F4 was Pressed * *ã******************************************************************************************** CSR SR_DSPLAY BegSR * C STCSRP DIV 256 STCSRL C MVR STCSRC * C EVAL *IN48 = *On * éPrompt for Employer * ¹------------------- C IF STCSRC > 05 And STCSRC < 17 C EVAL FIELD = 'PRER' * C clear XDATA C call 'PRGDCO' C parm XDATA C parm @CALTYP C parm @RPG C IF @WER <> *BLANKS C movel(p) @WER @ER C EVAL STCSRL = 6 C EVAL STCSRC = 30 C********** WRITE ALIGN C ENDIF * éPrompt for Employee * ¹------------------- C ELSE C IF STCSRC > 18 C clear XDATA C EVAL FIELD = 'PREN' C EVAL @VER = @ER C MOVE ZDATA YDATA C call 'PRGALPH' C parm XDATA C parm @CALTYP C parm @RPG C IF @WEN <> *BLANKS C movel(p) @WEN @EN C EndIF C EndIF C EndIF * CSR EndSR *ã******************************************************************************************** * ¹~SR_PROC1 - Process Subfile Changes: Did we Add, Change or Delete anything??? * *ã******************************************************************************************** C SR_PROC1 BegSR C EVAL @RELOAD = *Off C EVAL *In51 = *Off C DOU *In51 = *On DO *IN99 C READC SFL1 51 C IF @SELECT = 'D' IF not *IN99 C @KEY_JDE3 CHAIN FORMAT1 C IF %Found IF not *IN99 C EXFMT WIN1 IF not *IN99 C IF *In05 IF not *IN99 C EVAL @RELOAD = *On C DELETE FORMAT1 C EndIF EndIF not *IN99 C EndIF EndIF not *IN99 C Else EndIF not *IN99 C IF JDPCT <> @HPCT IF not *IN99 C Eval @SV_PCT = JDPCT EndIF not *IN99 C EVAL @RELOAD = *On C @KEY_JDE3 CHAIN FORMAT1 C IF %Found IF not *IN99 C Eval JDPCT = @SV_PCT EndIF not *IN99 C Eval JDUSR= @USER EndIF not *IN99 C TIME JDDATE EndIF not *IN99 C UPDATE FORMAT1 EndIF not *IN99 C Else EndIF not *IN99 C EVAL @RR# = @RR# + 1 C Eval JDER = @ER EndIF not *IN99 C Eval JDEN = @EN EndIF not *IN99 C Eval JDPCT = @SV_PCT EndIF not *IN99 C Eval JDUSR= @USER EndIF not *IN99 C TIME JDDATE EndIF not *IN99 C WRITE FORMAT1 EndIF not *IN99 C EndIF EndIF not *IN99 C EndIF EndIF not *IN99 C EndIF EndIF not *IN99 C EndDO EndDo *IN99 C IF @RELOAD IF not *IN99 C EVAL @ERR = *Blanks C EXSR SR_CLR_SF C EXSR SR_LOADSF C*** EXSR SR_SFL C EndIF EndIF not *IN99 CSR EndSR *ã******************************************************************************************** * ¹~SR_QUIT - We're Done! * *ã******************************************************************************************** C SR_QUIT BegSR C EVAL *InLR = *On C RETURN CSR EndSR *ã******************************************************************************************** * ¹~SR_CNVRT - Convert Binary to Decimal... Get Action * *ã******************************************************************************************** C SR_CNVRT BegSR C EVAL *In47 = *Off C EVAL *In46 = *Off C IF STACTN < 0 C Z-SUB STACTN STWORK 5 0 C ELSE C Z-ADD STACTN STWORK C EndIF C DIV 256 STWORK C MVR STACTN C EndSR *ã******************************************************************************************** * ¹~SR_HELP - Process Help Key * *ã******************************************************************************************** C SR_HELP BegSR C Z-ADD STSFLR @WSFLR 5 0 C STCSRP DIV 256 @LINE C MVR @POS C MOVE *INLR LR C MOVEA *IN @SAVIN 24 C MOVE STCMDK @SAVKY 24 C Z-ADD @LINE STCSRL C Z-ADD @POS STCSRC C MOVE '1' *IN48 C CALL 'AMGHI1' HPLIST 99 C MOVEA @SAVKY *IN(1) C WRITE ALIGN C MOVEA @SAVIN *IN(1) C MOVE '1' *IN47 C MOVE '1' *IN46 C Z-ADD STSFLR @RR# C Z-ADD @WSFLR STSFLR C EndSR *ã******************************************************************************************** * ¹~SR_NODEF - Handle Non-defined Keys * *ã******************************************************************************************** C SR_NODEF BegSR C CALL 'PRGINV' C EndSR *ã********************************************************************************************  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ A*%%TS SD 20030207 142853 PEARSOGX REL-V5R1M0 5722-WDS A*------------------------------------------------------------------------* A* GREEN SPRINGS SOFTWARE, INC www.green-springs.com * A*------------------------------------------------------------------------* A* Object Name: SUBFILED Display File * A* Description: Simple Subfile Program Example * A* Purpose : INFINIUM / JDE INTERFACE * A* Creation : 1/30/2003 * A* Author : George Pearson, Green Springs Software, Inc. * A*------------------------------------------------------------------------* A*%%EC A DSPSIZ(24 80 *DS3) A PRINT(*LIBL/PRINTKEY) A CF03(03) A CF12(12) A HELP A*------------------------------------------------------------------------* A R SCREEN1 A*%%TS SD 20030207 142853 PEARSOGX REL-V5R1M0 5722-WDS A CF04(04) A 48 CSRLOC(STCSRL STCSRC) A STCSRL 3 0H A STCSRC 3 0H A 1 2DATE A EDTCDE(Y) A COLOR(BLU) A 1 11TIME A COLOR(BLU) A 1 23'Infinium / JDE Interface' A DSPATR(HI) A @PGM 10A O 1 61COLOR(BLU) A 1 72'SUBFILED' A COLOR(BLU) A 4 2'Select Employer and Employee' A 6 3'Employer:' A @ER 3A B 6 13DSPATR(HI) A 71 DSPATR(PC) A 71 COLOR(RED) A 6 17'+' A DSPATR(HI) A 6 20'Employee:' A @EN 9A B 6 30DSPATR(HI) A 72 DSPATR(PC) A 72 COLOR(RED) A 6 40'+' A DSPATR(HI) A @ERR 75A O 22 2COLOR(RED) A DSPATR(HI) A 23 2'F3=Exit' A COLOR(BLU) A 23 11'F4=Prompt' A COLOR(BLU) A*------------------------------------------------------------------------* A* A R SFL1 SFL A @SELECT 1A I 11 9 A 31 DSPATR(PR ND) A JDAID 8A B 11 16 A JDPCT 5Y 2B 11 32EDTCDE(1) A @COMMENT 22A 11 42COLOR(PNK) A @HPCT 5S 2H A STREC# 4S 0H A* A*----------------------------------------------------------------------* A* A R CTL1 SFLCTL(SFL1) A SFLSIZ(0012) A SFLPAG(0006) A OVERLAY A 41 SFLDSP A 42 SFLDSPCTL A 43 SFLCLR A 97 SFLEND A @RR# 4S 0H SFLRCDNBR A 1 2DATE A EDTCDE(Y) A COLOR(BLU) A 1 11TIME A COLOR(BLU) A 1 23'Infinium / JDE Interface' A DSPATR(HI) A @PGM 10A O 1 61COLOR(BLU) A 1 72'SUBFILED' A COLOR(BLU) A 6 4'Employer:' A @ER 3A O 6 14DSPATR(HI) A 6 20'Employee:' A @EN 9A O 6 30DSPATR(HI) A 6 42'JDE Address Book#' A @NB3 11Y 0O 6 60DSPATR(HI) A EDTCDE(Z) A PRCNM 39A O 7 10 A 9 52'** New **' A COLOR(PNK) A 61 DSPATR(ND) A 10 7'Delete' A 10 16'Bus Unit' A 10 33'Pct' A* A*----------------------------------------------------------------------* A R FOOT A*%%TS SD 20030130 110106 PEARSOGX REL-V5R1M0 5722-WDS A @ERR 75A O 22 2COLOR(RED) A DSPATR(HI) A 23 2'F3=Exit' A DSPATR(HI) A COLOR(BLU) A 23 11'F12=Cancel' A DSPATR(HI) A COLOR(BLU) A @PCT 5Y 2O 20 32EDTCDE(1) A 62 COLOR(RED) A*------------------------------------------------------------------------* A R ALIGN BLINK OVERLAY A 48 CSRLOC(STCSRL STCSRC) A STCSRL 3 0H A STCSRC 3 0H A*------------------------------------------------------------------------* A R WIN1 A*%%TS SD 20030207 094327 PEARSOGX REL-V5R1M0 5722-WDS A WINDOW(14 20 08 40) A OVERLAY A CF05(05) A WDWBORDER((*COLOR BLU) (*DSPATR HI)) A 2 5'Press F5 to Delete this record, ' A 3 10'Press F12 to KEEP it.' A 6 2'F5=Delete' A COLOR(BLU) A 6 13'F12=Cancel' A DSPATR(HI) A COLOR(BLU)  _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ¹A*----------------------------------------------------------------------* ¹A* OBJECT NAME: SUBFILEP Physical File * ¹A* DESCRIPTION: Infinium / JDE Interface File * ¹A* CREATED BY: George Pearson, Green Springs Software, Inc. * ¹A* DATE: 1/30/2003 * ¹A*----------------------------------------------------------------------* ¹A* * ¹A* MODIFICATIONS * ¹A* * ¹A*----------------------------------------------------------------------* ¹A* * ¹A* --Date-- Who Scan For -------- C O M M M E N T S -------------------* ¹A* 01/30/03 GWP New File * ¹A*----------------------------------------------------------------------* A REF(HRFLDREF) A R FORMAT1 A TEXT('Infinium/JDE Interface File') A JDER R REFFLD(@@ER) A TEXT('Employer') A JDEN R REFFLD(@@EN) A TEXT('Employee') A JDAID 8 TEXT('JDE Bus Unit') A JDAN8 8S 0 TEXT('JDE Address Book') A JDPCT 5S 2 TEXT('Percentage') A JDUSR 10 TEXT('Update User') A JDDATE Z TEXT('Update Date') * A K JDER A K JDEN A K JDAID