// Program: SF_02
// Load all subfile, max 9999 records
// this example permits positioning and page down
// uses RPGLE/free
// F5 = refresh data from file
// F11 = drop/fold second line
// inspired by: // https://www.rpgpgm.com/2016/05/example-subfile-program-using-modern-rpg.html
// Create a work file and populate with some data:
// CREATE TABLE MYLIB/ORDER_DET (
// DETAIL_NUM INT NOT NULL WITH DEFAULT,
// DETAIL_LIN INT NOT NULL WITH DEFAULT,
// DETAIL_SKU CHAR (25) NOT NULL WITH DEFAULT,
// DETAIL_QTY INT NOT NULL WITH DEFAULT,
// DETAIL_PRI DEC ( 10, 2) NOT NULL WITH DEFAULT
// )
// RCDFMT ORDER_DETR
//
// CREATE INDEX MYLIB/ORD_DETL1
// ON ORDER_DET(DETAIL_NUM, DETAIL_LIN)
ctl-opt option(*nodebugio:*srcstmt:*nounref) dftactgrp(*no) ;
dcl-ds PgmDs psds qualified ;
PgmName *proc ;
end-ds ;
dcl-f SF_02D workstn indds(Dspf) sfile(SFL01:Z1RRN) ;
dcl-c MaxSfl 9999 ;
dcl-ds Dspf qualified ;
Exit ind pos(3) ;
Refresh ind pos(5) ;
// Drop ind pos(11) ; not required here
SflDspCtl ind pos(30) ;
SflDsp ind pos(31) ;
end-ds ;
dcl-f ORD_DETL1 keyed ;
dcl-s PrvPos1 like(Z1POS1) ;
dcl-s PrvPos2 like(Z1POS2) ;
// -----------------------------------------------------------------------
Z1SCREEN = %trimr(PgmDs.PgmName) + '-1' ;
setll *loval ORDER_DETR ;
LoadSubfile() ;
dow ( Dspf.Exit = *off);
write REC01 ;
exfmt CTL01 ;
if (Dspf.Exit) ;
leave ;
elseif (Dspf.Refresh) ;
Z1POS1 = 0 ;
Z1POS2 = 0 ;
PrvPos1 = 0 ;
PrvPos2 = 0 ;
setll *loval ORDER_DETR;
LoadSubfile() ;
iter ;
elseif (Z1POS1 <> PrvPos1 or Z1POS2 <> PrvPos2);
PrvPos1 = Z1POS1 ;
PrvPos2 = Z1POS2 ;
setll (Z1POS1:Z1POS2) ORDER_DETR;
LoadSubfile() ;
iter ;
endif ;
if (Dspf.SflDsp) ;
ReadSubfile() ;
endif ;
enddo ;
*inlr = *on ;
// ---------------------------------------------------------------------
dcl-proc LoadSubfile ;
Dspf.SflDspCtl = *off ;
Dspf.SflDsp = *off ;
write CTL01 ;
Dspf.SflDspCtl = *on ;
Z1OPT = ' ' ;
for Z1RRN = 1 to MaxSfl ;
read ORDER_DETR;
if (%eof) ;
leave ;
endif ;
write SFL01 ;
endfor ;
if (Z1RRN > 1) ;
Dspf.SflDsp = *on ;
endif ;
end-proc ;
// ---------------------------------------------------------------------
dcl-proc ReadSubfile ;
dow (1 = 1) ;
readc SFL01 ;
if (%eof) ;
leave ;
endif ;
//Do something depending on value in Z1OPT
Dsply Z1OPT;
Z1OPT = ' ' ;
update SFL01 ;
enddo ;
end-proc ;
A* Display file: SF_02D A DSPSIZ(24 80 *DS3) A REF(*LIBL/ORDER_DET) A PRINT A INDARA A CA03(03 'F3=Exit') A* SubFile Record A R SFL01 SFL A Z1RRN 4S 0H A Z1OPT 1A B 5 3 A DETAIL_NUMR Y O 5 6REFFLD(DETAIL_NUM) A EDTCDE(4) A DETAIL_LINR Y O 5 24REFFLD(DETAIL_LIN) A EDTCDE(4) A DETAIL_SKUR O 6 6REFFLD(DETAIL_SKU) A* Control Record A* A R CTL01 SFLCTL(SFL01) A SFLSIZ(9999) A* SFLPAG(0017) A SFLPAG(0008) A OVERLAY A 31 SFLDSP A 30 SFLDSPCTL A N30 SFLCLR A 30 SFLEND(*MORE) A N77 SFLDROP(CF11) A 77 SFLFOLD(CF11) A CA05(05 'F5=Refresh') A CF11(11 'F11=Fold') A 1 2USER A COLOR(BLU) A 1 63TIME A COLOR(BLU) A 1 72DATE A EDTCDE(Y) A COLOR(BLU) A Z1SCREEN 12A O 2 2COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A 3 2'Position to:' A COLOR(BLU) A Z1POS1 R B 3 15REFFLD(DETAIL_NUM) A COLOR(BLU) A Z1POS2 R B 3 26REFFLD(DETAIL_LIN) A COLOR(BLU) A 4 7'Order No' A DSPATR(UL) A DSPATR(HI) A 4 26'Line No' A DSPATR(UL) A DSPATR(HI) A* A R REC01 A 23 3'F3=Exit F5=Refresh' A COLOR(BLU)
Sample output:
USERNAME 21:05:44 11/13/21
SF_02-1 SYS_NAME
Position to: _________ ________
Order No Line No
100 1
ABCD12345678901234567890
100 2
ABCD12345678901234567891
101 1
ABCD12345678901234567892
101 2
ABCD12345678901234567893
102 1
ABCD12345678901234567894
102 2
ABCD12345678901234567895
105 1
ABCD12345678901234567896
105 2
ABCD12345678901234567897
More...
F3=Exit F5=Refresh F11=Drop/Fold
// Program: SF_03
// load page at a time subfile
// this example permits positioning and page up/down
// uses RPGLE/free
// F5 = refresh data from file
// inspired by: https://www.rpgpgm.com/2019/01/another-type-of-subfile-screen-at-time.html
//
// Create a work file and populate with some data:
// CREATE TABLE MYLIB/ORDER_DET (
// DETAIL_NUM INT NOT NULL WITH DEFAULT,
// DETAIL_LIN INT NOT NULL WITH DEFAULT,
// DETAIL_SKU CHAR (25) NOT NULL WITH DEFAULT,
// DETAIL_QTY INT NOT NULL WITH DEFAULT,
// DETAIL_PRI DEC ( 10, 2) NOT NULL WITH DEFAULT
// )
// RCDFMT ORDER_DETR
//
// CREATE INDEX MYLIB/ORD_DETL1
// ON ORDER_DET(DETAIL_NUM, DETAIL_LIN)
ctl-opt option(*nodebugio:*srcstmt:*nounref)
dftactgrp(*no) ;
dcl-f SF_03D workstn indds(Dspf) sfile(SFL01:ZRRN) ;
dcl-ds Dspf qualified ;
Exit ind pos(3) ;
Drop ind pos(11) ;
PageDown ind pos(25) ;
PageUp ind pos(26) ;
SflInds char(4) pos(30) ;
SflDspCtl ind pos(30) ;
SflDsp ind pos(31) ;
SflEnd ind pos(32) ;
SflClr ind pos(33) ;
end-ds ;
dcl-f ORD_DETL1 keyed ;
dcl-s SflSize like(ZRRN) inz(16) ;
dcl-s PrvPos1 like(Z1POS1) ;
dcl-s PrvPos2 like(Z1POS2) ;
SubfileDown() ;
dow not(Dspf.Exit) ;
write FOOT01 ;
exfmt CTL01 ;
// page down
if (Dspf.PageDown) ;
if not(Dspf.SflEnd) ;
SubfileDown() ;
endif ;
// page up
elseif (Dspf.PageUp) ;
SubfileUp() ;
elseif (Z1POS1 <> PrvPos1 or Z1POS2 <> PrvPos2);
setll (Z1POS1:Z1POS2) ORDER_DETR;
SubfileDown() ;
PrvPos1 = Z1POS1 ;
PrvPos2 = Z1POS2 ;
endif ;
if (Dspf.SflDsp) ;
ReadSubfile() ;
endif ;
enddo ;
*inlr = *on ;
//-------------------------------------------------------
dcl-proc SubfileDown ;
Dspf.SflInds = '0001' ;
write CTL01 ;
Dspf.SflInds = '1000' ;
for ZRRN = 1 to SflSize ;
read ORDER_DETR;
if (%eof) ;
Dspf.SflEnd = *on ;
leave ;
endif ;
write SFL01 ;
endfor ;
if (ZRRN > 1) ;
Dspf.SflDsp = *on ;
else ;
return ;
endif ;
if not(Dspf.SflEnd) ;
read ORDER_DETR;
if (%eof) ;
Dspf.SflEnd = *on ;
else ;
setll (DETAIL_NUM:DETAIL_LIN) ORDER_DETR;
endif ;
endif ;
end-proc;
//-------------------------------------------------------
dcl-proc SubfileUp ;
chain 1 SFL01 ;
setll (DETAIL_NUM:DETAIL_LIN) ORDER_DETR;
for ZRRN = 1 to SflSize ;
readp ORDER_DETR;
if (%eof) ;
leave ;
endif ;
endfor ;
setll (DETAIL_NUM:DETAIL_LIN) ORDER_DETR;
SubfileDown() ;
end-proc;
// ---------------------------------------------------------------------
dcl-proc ReadSubfile ;
dow (1 = 1) ;
readc SFL01 ;
if (%eof) ;
leave ;
endif ;
//Do something depending on value in Z1OPT
Dsply Z1OPT;
Z1OPT = ' ' ;
update SFL01 ;
enddo ;
end-proc ;
DDS
A DSPSIZ(24 80 *DS3)
A REF(*LIBL/ORDER_DET)
A PRINT
A INDARA
A CA03(03 'F3=Exit')
A* SubFile Record
A*
A R SFL01 SFL
A ZRRN 2S 0H
A Z1OPT 1A B 5 3
A DETAIL_NUMR Y O 5 6REFFLD(DETAIL_NUM)
A EDTCDE(4)
A DETAIL_LINR Y O 5 24REFFLD(DETAIL_LIN)
A EDTCDE(4)
A DETAIL_SKUR O 5 41REFFLD(DETAIL_SKU)
A* Control Record
A*
A R CTL01 SFLCTL(SFL01)
A SFLSIZ(0016)
A SFLPAG(0016)
A OVERLAY
A PAGEDOWN(25)
A PAGEUP(26)
A 30 SFLDSPCTL
A 31 SFLDSP
A 32 SFLEND(*MORE)
A 33 SFLCLR
A 3 2'Position to'
A Z1POS1 R B 3 15REFFLD(DETAIL_NUM)
A COLOR(BLU)
A Z1POS2 R B 3 26REFFLD(DETAIL_LIN)
A COLOR(BLU)
A 4 7'Order No'
A DSPATR(UL)
A DSPATR(HI)
A 4 26'Line No'
A DSPATR(UL)
A DSPATR(HI)
A 4 41'SKU No'
A DSPATR(UL)
A DSPATR(HI)
A 1 21'Order Detail Screen'
A R FOOT01
A 23 3'F3=Exit'
Note use of prototype interface declaration (Dcl-pi) here for parameters
// Program Name: RPG_02 - This program receives two values, adds them together and returns them in third parameter.
//
// CRTBNDRPG PGM(TORONTO221/RPG_02) SRCFILE(TORONTO221/QRPGLESRC) SRCMBR(RPG_02)
// or
// CRTRPGMOD MODULE(TORONTO221/RPG_02) SRCFILE(TORONTO221/QRPGLESRC) SRCMBR(RPG_02)
// CRTPGM PGM(TORONTO221/RPG_02) MODULE(TORONTO221/RPG_02)
//
// PI (Prototype Interface) defines parameters
Dcl-pi RPG_02 ExtPgm;
Var1 packed(3:0) ;
Var2 packed(3:0) ;
Response packed(3:0) ;
End-pi ;
Eval response = var1 + var2 ;
Eval *inlr = *on;
Return;
Note use of prototype declaration (Dcl-pr) here for parameters. Also use of prototyped call (CALLP)
// Program Name: RPG_01
// This program calls RPG_02 to add up two numbers
// The CALLP operation is used to call prototyped program RPG_02
// Prototype for external program
// Here the name of the program is the same name used internally (RPG_02)
Dcl-pr RPG_02 extpgm('RPG_02');
Var1 packed(3:0) ;
Var2 packed(3:0) ;
Response packed(3:0) ;
End-pr ;
Dcl-s Var1 packed(3:0) ;
Dcl-s Var2 packed(3:0) ;
Dcl-s Response packed(3:0) ;
// Add two numbers
Var1 = 5 ;
Var2 = 10 ;
CALLP RPG_02(Var1:Var2:Response);
Dsply Response;
Eval *inlr = *on;
Return;
/* CLP_01 - CLLE program to call RPG_02 */
DCL VAR(&VAR1) TYPE(*DEC) LEN(3 0) VALUE(10)
DCL VAR(&VAR2) TYPE(*DEC) LEN(3 0) VALUE(20)
CALL PGM(RPG_01) PARM((&VAR1) (&VAR2))
// Program RPG_12
// Example of a Sub-procedure defined and used within same program
// to compile: CRTBNDRPG PGM(RPG_12) SRCMBR(RPG_12)
// dftactgrp(*no) permits compiler to use ILE functionality.
// compiler assumes we want actGrp(*Caller) as we don't specify specific activation group
Ctl-opt dftactgrp(*no) ;
// This prototype is optional (but recommended) because procedure is not exported
Dcl-pr AddTwoNumbers packed(4:0) ;
Var1 packed(3:0) ;
Var2 packed(3:0) ;
End-pr ;
Dcl-s Var1 packed(3:0) INZ(5) ;
Dcl-s Var2 packed(3:0) INZ(5) ;
Dcl-s Response packed(4:0) ;
Response = AddTwoNumbers(Var1:Var2) ;
Dsply Response;
Eval *INLR = *on;
Return;
// ---------------------------------------------------------------------
// Define the subprocedure AddTwoNumbers
// ---------------------------------------------------------------------
// Procedure is only used in this program as it is not exported
// note the return value is packed (4:0)
Dcl-proc AddTwoNumbers ;
Dcl-pi AddTwoNumbers packed(4:0) ;
Var1 packed(3:0) ;
Var2 packed(3:0) ;
End-pi ;
Dcl-s Reponse packed(4:0) ;
Eval Response = Var1 + Var2 ;
Return Response ;
End-Proc AddTwoNumbers ;
Calling program:
// Program RPG_21: Example of program calling module in service program that adds two numbers
// to compile:
// CHGCURLIB MYLIB
// Create Module:
// CRTRPGMOD MODULE(RPG_21) SRCFILE(QRPGLESRC) SRCMBR(RPG_21) DBGVIEW(*LIST)
// to run: CALL RPG_21
ctl-opt option(*srcstmt:*nodebugio);
Dcl-pr AddTwoNumbers packed(3:0) ;
Var1 packed(3:0) ;
Var2 packed(3:0) ;
End-pr ;
Dcl-s Var1 packed(3:0) ;
Dcl-s Var2 packed(3:0) ;
Dcl-s Response packed(3:0) ;
Eval Var1 = 5;
Eval Var2 = 5;
Response = AddTwoNumbers(Var1:Var2) ;
dsply Response;
Eval *INLR = *on;
Return;
Program containing subprocedure:
// Program RPG_22: Example of sub-procedure that adds up two numbers compiled into service program
// to Compile:
// 1. Create Modules:
// CHGCURLIB MYLIB
// CRTRPGMOD MODULE(RPG_21) SRCFILE(QRPGLESRC) SRCMBR(RPG_21)
// CRTRPGMOD MODULE(RPG_22) SRCFILE(QRPGLESRC) SRCMBR(RPG_22)
// 2. Create Service program:
// CRTSRVPGM SRVPGM(RPG_22) MODULE(RPG_22) EXPORT(*ALL)
// 3. Create Program that includes calling module and service program
// CRTPGM PGM(RPG_21) MODULE(RPG_21) BNDSRVPGM((RPG_22))
Ctl-opt option(*srcstmt:*nodebugio) nomain ;
Dcl-pr AddTwoNumbers packed(3:0) ;
Var1 packed(3:0) ;
Var2 packed(3:0) ;
End-pr ;
// ---------------------------------------------------------------
Dcl-proc AddTwoNumbers export ;
Dcl-pi AddTwoNumbers packed(3:0);
Var1 packed(3:0) ;
Var2 packed(3:0) ;
End-pi ;
Dcl-s Response packed(3:0) ;
Eval Response = Var1 + Var2 ;
Return Response ;
End-proc AddTwoNumbers;
Next we make a few changes to take advantage of more of IBM i's ILE features.
Move prototypes to copy book to externalize the prototypes so they can be used in other modules. Create the following source file member in mylib/QCPYSRC(RPG_21C) and add the following code
// Copy book RPG_21C
// Universal Prototype Definition
Dcl-pr AddTwoNumbers packed(3:0) ;
Var1 packed(3:0) ;
Var2 packed(3:0) ;
End-pr ;
In RPGLE programs RPG_21 and RPG_22, replace prototypes with reference to copy file
// bring in prototypes from copy book in QCPYSRC /copy qcpysrc,RPG_21C ;
We want to avoid using CRTSRVPGM with EXPORT(*ALL). Instead, we will use a binder language source file to indicate exportable procedures.
Create a source file member QSRVSRC(RPG_22B) with source type "BND" with the following text:
/* ================================================== */
/* source file: mylib/QSRVSRC(RPG_22B) */
/* source type: BND */
/* New exports MUST be added at the end. */
/* Old exports MUST NEVER be removed from the list. */
/* !!! The order should not change */
/* !!! The signature should not change */
/* ================================================== */
STRPGMEXP PGMLVL(*CURRENT) LVLCHK(*YES)
SIGNATURE('YourAppNameOrWhatever')
EXPORT SYMBOL(ADDTWONUMBERS)
ENDPGMEXP
Create a binding directory if you don't already have one. This is an object of type *BNDDIR.
You may want to use a single binding directory for each service program, or combine multiple service programs in one binding directory. Here we call binding directory MYBNDDIR
CRTBNDDIR mylib/MYBNDDIR TEXT('My Binding Directory')
Create service program using specific binding instructions.
Here, instead of exporting *ALL procedures, we specify those indicated in our binder language source file member RPG_22B.
CRTSRVPGM SRVPGM(RPG_22) MODULE(RPG_22) EXPORT(*SRCFILE) SRCFILE(*LIBL/QSRVSRC) SRCMBR(RPG_22B) TEXT('Service Program RPG_22')
ADDBNDDIRE BNDDIR(*LIBL/MYBNDDIR) OBJ((*LIBL/RPG_22 *SRVPGM))
Check contents of dinding directory.
DSPBNDDIR BNDDIR(MYBNDDIR)
Add this line to your program RPG_21 this way when you compile RPG_21, compiler with check binding directory MYBNDDIR.
ctl-opt bnddir('*LIBL/MYBNDDIR') ;
CRTPGM PGM(RPG_21) MODULE(RPG_21) CALL RPG_21
Changes to programs in green:
// Program RPG_21: Example of program calling module in service program that adds two numbers
ctl-opt option(*srcstmt:*nodebugio);
ctl-opt bnddir('*LIBL/MYBNDDIR') ;
// bring in prototypes from copy book in QCPYSRC
/copy qcpysrc,RPG_21C ;
Dcl-s Var1 packed(3:0) ;
Dcl-s Var2 packed(3:0) ;
Dcl-s Response packed(3:0) ;
Eval Var1 = 5;
Eval Var2 = 5;
Response = AddTwoNumbers(Var1:Var2) ;
dsply Response;
Eval *INLR = *on;
Return;
Program containing subprocedure:
// Program RPG_22: Example of sub-procedure that adds up two numbers compiled into service program
Ctl-opt option(*srcstmt:*nodebugio) nomain ;
ctl-opt bnddir('*LIBL/MYBNDDIR') ;
// bring in prototypes from copy book in QCPYSRC
/copy qcpysrc,RPG_21C ;
// ---------------------------------------------------------------
Dcl-proc AddTwoNumbers export ;
Dcl-pi AddTwoNumbers packed(3:0);
Var1 packed(3:0) ;
Var2 packed(3:0) ;
End-pi ;
Dcl-s Response packed(3:0) ;
Eval Response = Var1 + Var2 ;
Return Response ;
End-proc AddTwoNumbers;
Externalize the prototypes to copybook:
// Copy book RPG_21C
// Universal Prototype Definition
Dcl-pr AddTwoNumbers packed(3:0) ;
Var1 packed(3:0) ;
Var2 packed(3:0) ;
End-pr ;