// Program: SF_02
// "Load All" type subfile, max 9999 records
// this example permits positioning and page up/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-f ORD_DETL1 keyed ;
//dcl-f SF_02D workstn indds(Dspf) sfile(SFL01:Z1RRN) infds(InfDs1);
dcl-f SF_02D workstn indds(Indds1) sfile(SFL01:Z1RRN) infds(InfDs1);
// psds - Program Status Data Structure
dcl-ds PgmDs psds qualified ;
PgmName *proc ;
end-ds ;
// InfDs - File Information Data Structure
dcl-ds InfDs1 qualified ;
Choice char(1) pos(369);
Recno int(5) pos(378);
end-ds ;
dcl-ds Indds1 qualified ;
Exit ind pos(3) ;
Refresh ind pos(5) ;
SflDspCtl ind pos(30) ;
SflDsp ind pos(31) ;
end-ds ;
dcl-s RecNo_H zoned(4:0) ;
dcl-s PrvPos1 like(Z1POS1) ;
dcl-s PrvPos2 like(Z1POS2) ;
dcl-c MaxSfl 9999 ;
// -----------------------------------------------------------------------
Init();
LoadSubfile() ;
dow ( Indds1.Exit = *off);
write FOOTER;
exfmt CTL01 ;
eval RecNo_H = InfDs1.Recno;
if (Indds1.Exit) ;
leave ;
elseif (Indds1.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 (Indds1.SflDsp) ;
readSubfile() ;
endif ;
enddo ;
*inlr = *on ;
// ---------------------------------------------------------------------
dcl-proc LoadSubfile ;
Indds1.SflDspCtl = *off ;
Indds1.SflDsp = *off ;
eval RecNo_H = 1;
write CTL01 ;
Indds1.SflDspCtl = *on ;
Z1OPT = ' ' ;
for Z1RRN = 1 to MaxSfl ;
read ORDER_DETR;
if (%eof) ;
leave ;
endif ;
write SFL01 ;
endfor ;
if (Z1RRN > 1) ;
Indds1.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 ;
// ---------------------------------------------------------------------
dcl-proc Init ;
Z1SCREEN = %trimr(PgmDs.PgmName) + '-1' ;
end-proc ;
A DSPSIZ(24 80 *DS3)
A REF(*LIBL/ORDER_DET)
A PRINT
A INDARA
A CA03(03 'F3=Exit')
A* ---------------------------------------------------------------------
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 10REFFLD(DETAIL_SKU)
A* ---------------------------------------------------------------------
A* Control Record
A R CTL01 SFLCTL(SFL01)
A SFLSIZ(09)
A SFLPAG(08)
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* Use value in SFLRCDNBR to ensure that we don't loop back to first page at end of subfile
A RECNO_H 4S 0H SFLRCDNBR
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 1 21'Order Detail Screen'
A* ---------------------------------------------------------------------
A R FOOTER
A 23 2'F3=Exit'
A COLOR(BLU)
A 23 12'F5=Refresh'
A COLOR(BLU)
A 23 25'F11=Fold'
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/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-f ORD_DETL1 keyed ;
dcl-f SF_03D workstn indds(Indds1) sfile(SFL01:ZRRN) ;
dcl-ds Indds1 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-ds PgmDs psds qualified ;
PgmName *proc ;
end-ds ;
dcl-s SflSize like(ZRRN) inz(16) ;
dcl-s PrvPos1 like(Z1POS1) ;
dcl-s PrvPos2 like(Z1POS2) ;
//-------------------------------------------------------
Init();
SubfileDown() ;
dow not(Indds1.Exit) ;
write FOOT01 ;
exfmt CTL01 ;
// page down
if (Indds1.PageDown) ;
if not(Indds1.SflEnd) ;
SubfileDown() ;
endif ;
// page up
elseif (Indds1.PageUp) ;
SubfileUp() ;
elseif (Z1POS1 <> PrvPos1 or Z1POS2 <> PrvPos2);
setll (Z1POS1:Z1POS2) ORDER_DETR;
SubfileDown() ;
PrvPos1 = Z1POS1 ;
PrvPos2 = Z1POS2 ;
endif ;
if (Indds1.SflDsp) ;
ReadSubfile() ;
endif ;
enddo ;
*inlr = *on ;
//-------------------------------------------------------
dcl-proc SubfileDown ;
Indds1.SflInds = '0001' ;
write CTL01 ;
Indds1.SflInds = '1000' ;
for ZRRN = 1 to SflSize ;
read ORDER_DETR;
if (%eof) ;
Indds1.SflEnd = *on ;
leave ;
endif ;
write SFL01 ;
endfor ;
if (ZRRN > 1) ;
Indds1.SflDsp = *on ;
else ;
return ;
endif ;
if not(Indds1.SflEnd) ;
read ORDER_DETR;
if (%eof) ;
Indds1.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 ;
// ---------------------------------------------------------------------
dcl-proc Init ;
Z1SCREEN = %trimr(PgmDs.PgmName) + '-1' ;
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 Z1SCREEN 12A O 2 2COLOR(BLU)
A 2 72SYSNAME
A COLOR(BLU)
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'
// Program: SF_05
// a work in progress...
// load page at a time subfile
// uses 2 subfiles (show headers, drill through to details) - one procedure per subfile
// uses RPGLE/free
//
// Create a Order header and detail tables, indexes, then add some data.
//
// CREATE TABLE MYLIB/ORDER_HED (
// ORDER_NUM INT NOT NULL WITH DEFAULT,
// ORDER_CUST INT NOT NULL WITH DEFAULT,
// ORDER_DATE DATE NOT NULL WITH DEFAULT,
// ORDER_TIME TIME NOT NULL WITH DEFAULT,
// ORDER_VALUE DEC ( 11, 2) NOT NULL WITH DEFAULT
// )
// RCDFMT ORDER_HEDR
//
// 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
//
// Indexes:
//
// CREATE INDEX MYLIB/ORD_DETL1
// ON ORDER_DET(DETAIL_NUM, DETAIL_LIN)
//
// CREATE INDEX MYLIB/ORD_HEDL1
// ON MYLIB/ORDER_HED (ORDER_NUM)
ctl-opt option(*nodebugio:*srcstmt:*nounref)
dftactgrp(*no);
dcl-pr ProcessSubfile2 char(1) ;
End-pr ;
dcl-f ORD_HEDL1 keyed ;
dcl-f ORD_DETL1 keyed ;
dcl-f SF_05D workstn indds(Indds) sfile(SFL01:Z1RRN)
infds(infds1) sfile(SFL02:Z2RRN) ;
dcl-ds Indds qualified ;
Exit ind pos(3) ; // F3
Drop ind pos(11) ;
ReturnF12 ind pos(12) ; // F12
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) ;
Refresh ind pos(77) ;
end-ds ;
// backup for Indds
dcl-ds Indds_bk likeds(Indds);
dcl-ds PgmDs psds qualified ;
PgmName *proc ;
end-ds ;
dcl-ds infds1 qualified ;
KeyPressed char(1) pos(369);
end-ds ;
dcl-s PrvPos1 like(Z1POS1) ;
dcl-s show_subfile char(1);
dcl-c EnterKey const(x'F1');
dcl-c F1Key const(x'31');
dcl-c F3Key const(x'33');
dcl-c F5Key const(x'35');
dcl-c F12Key const(x'3C');
//-------------------------------------------------------
ProcessSubfile1();
*inlr = *on ;
//-------------------------------------------------------
//-------------------------------------------------------
// SUBFILE 1
//-------------------------------------------------------
dcl-proc ProcessSubfile1;
dcl-s myKeypressed char(1);
dcl-s SflSize1 like(Z1RRN) inz(14) ;
exsr Init;
exsr SubfileDown1 ;
dow not(Indds.Exit) and not(Indds.ReturnF12);
write FOOT01 ;
exfmt CTL01 ;
// page down
if (Indds.PageDown) ;
if not(Indds.SflEnd) ;
Exsr SubfileDown1;
endif ;
// page up
elseif (Indds.PageUp) ;
Exsr SubfileUp1 ;
// position to
elseif (Z1POS1 <> PrvPos1);
setll (Z1POS1) ORDER_HEDR;
Exsr SubfileDown1 ;
PrvPos1 = Z1POS1 ;
// refresh
elseif (Indds.Refresh) ;
setll *loval ORDER_HEDR;
Exsr Init;
exsr SubfileDown1 ;
iter ;
endif;
if (Indds.SflDsp) ;
Exsr ReadSubfile1 ;
if (Indds.Exit);
Leave;
endif ;
endif ;
enddo ;
//-------------------------------------------------------
begsr WriteControlRec1 ;
Indds.SflDspCtl = *Off ;
Indds.SflDsp = *Off ;
Indds.SflEnd = *Off ;
Indds.SflClr = *On ;
write CTL01 ;
Indds.SflDspCtl = *On ;
Indds.SflClr = *Off ;
endsr;
//-------------------------------------------------------
begsr SubfileDown1 ;
Exsr WriteControlRec1;
for Z1RRN = 1 to SflSize1 ;
read ORDER_HEDR;
if (%eof) ;
Indds.SflEnd = *on ;
leave ;
endif ;
write SFL01 ;
endfor ;
// if records found, then display on
if (Z1RRN > 1) ;
Indds.SflDsp = *on ;
else ;
Indds.SflDsp = *off ;
endif ;
//if not(Indds.SflEnd) ;
// read ORDER_HEDR;
// if (%eof) ;
// Indds.SflEnd = *on ;
// else ;
// setll (ORDER_NUM) ORDER_HEDR;
// endif ;
//endif ;
endsr;
//-------------------------------------------------------
begsr SubfileUp1 ;
chain 1 SFL01 ;
setll (ORDER_NUM) ORDER_HEDR ;
for Z1RRN = 1 to SflSize1 ;
readp ORDER_HEDR;
if (%eof) ;
leave ;
endif ;
endfor ;
setll (ORDER_NUM) ORDER_HEDR;
Exsr SubfileDown1 ;
endsr;
// ---------------------------------------------------------------------
// Read subfile and perform appropriate actions
// ---------------------------------------------------------------------
begsr ReadSubfile1;
dow (1 = 1) ;
readc SFL01 ;
if (%eof) ;
leave ;
endif ;
//Do something depending on value in Z1OPT
select;
when Z1OPT = '1' or Z1OPT = '2';
Exsr Init;
Eval Indds_bk = Indds ;
myKeypressed = ProcessSubfile2() ;
if myKeyPressed = F12Key;
Eval myKeyPressed = *blanks;
Eval Indds = Indds_bk ; // back to screen1
Eval Indds.ReturnF12 = *off;
endif;
if myKeyPressed = F3Key;
Eval Indds = Indds_bk ; // back to screen1
Return;
endif;
when Z1OPT = '7';
// delete record
other;
Eval Z1OPT = Z1OPT;
endsl;
Z1OPT = ' ' ;
update SFL01 ;
enddo ;
endsr;
//-------------------------------------------------------
begsr Init;
Z1SCREEN = %trimr(PgmDs.PgmName) + '-1';
Z1POS1 = 0;
PrvPos1 = 0;
endsr;
end-proc;
//-------------------------------------------------------
// SUBFILE 2
//-------------------------------------------------------
dcl-proc ProcessSubfile2;
dcl-pi ProcessSubfile2 char(1) ;
end-pi ;
dcl-s SflSize2 like(Z2RRN) inz(14) ;
exsr Init;
//dcl-s Keypressed char(1);
setll (ORDER_NUM) ORDER_DETR;
Exsr SubfileDown2 ;
dow (1=1);
write FOOT01 ;
exfmt CTL02 ;
If infds1.Keypressed = F3Key or
infds1.Keypressed = F12Key;
return infds1.Keypressed;
Endif;
// page down
if (Indds.PageDown) ;
if not(Indds.SflEnd) ;
Exsr SubfileDown2;
endif ;
// page up
elseif (Indds.PageUp) ;
Exsr SubfileUp2 ;
elseif (Z1POS1 <> PrvPos1);
setll (Z1POS1) ORDER_HEDR;
Exsr SubfileDown2 ;
PrvPos1 = Z1POS1 ;
// refresh
elseif (Indds.Refresh) ;
setll *loval ORDER_HEDR;
Exsr Init;
Exsr SubfileDown2 ;
iter ;
endif;
if (Indds.SflDsp) ;
exsr ReadSubfile2 ;
endif ;
enddo ;
//-------------------------------------------------------
begsr WriteControlRec2 ;
Indds.SflDspCtl = *Off ;
Indds.SflDsp = *Off ;
Indds.SflEnd = *Off ;
Indds.SflClr = *On ;
write CTL02 ;
Indds.SflDspCtl = *On ;
Indds.SflClr = *Off ;
endsr;
//-------------------------------------------------------
begsr SubfileDown2 ;
Exsr WriteControlRec2;
for Z2RRN = 1 to SflSize2;
reade (ORDER_NUM) ORDER_DETR;
if (%eof) ;
Indds.SflEnd = *on ;
leave ;
endif ;
write SFL02 ;
endfor ;
if (Z2RRN > 1) ;
Indds.SflDsp = *on ;
else ;
Indds.SflDsp = *off ;
endif ;
if not(Indds.SflEnd) ;
reade (ORDER_NUM) ORDER_DETR;
if (%eof) ;
Indds.SflEnd = *on ;
else ;
setll (DETAIL_NUM) ORDER_DETR;
endif ;
endif ;
endsr;
//-------------------------------------------------------
begsr SubfileUp2 ;
chain 1 SFL02 ;
setll (DETAIL_NUM) ORDER_DETR;
for Z2RRN = 1 to SflSize2 ;
readpe (ORDER_NUM) ORDER_DETR;
if (%eof) ;
leave ;
endif ;
endfor ;
setll (ORDER_NUM) ORDER_DETR;
Exsr SubfileDown2 ;
endsr;
// ---------------------------------------------------------------------
begsr ReadSubfile2;
dow (1 = 1) ;
readc SFL02 ;
if (%eof) ;
leave ;
endif ;
//Do something depending on value in Z1OPT
Dsply Z1OPT;
Z1OPT = ' ' ;
update SFL02 ;
enddo ;
endsr;
// ---------------------------------------------------------------------
begsr Init;
Z2SCREEN = %trimr(PgmDs.PgmName) + '-2';
Z1POS1 = 0;
PrvPos1 = 0;
endsr;
end-proc;
// ---------------------------------------------------------------------
DDS:
A* DDS SCREEN FILE: SF_05D
A DSPSIZ(24 80 *DS3)
A REF(*LIBL/ORDER_DET)
A PRINT
A INDARA
A CA03(03 'F3=Exit')
A CA12(12 'F12=Return')
A* SubFile Record
A*
A R SFL01 SFL
A Z1RRN 2S 0H
A Z1OPT 1A B 7 3
A ORDER_NUM 9Y 0O 7 6
A EDTCDE(4)
A ORDER_CUST 9Y 0O 7 24
A EDTCDE(4)
A ORDER00001 11 2O 7 41
A EDTCDE(4)
A* Control Record
A*
A R CTL01 SFLCTL(SFL01)
A*%%TS SD 20250315 223304 TORONTO22 REL-V7R5M0 5770-WDS
A SFLSIZ(0014)
A SFLPAG(0014)
A OVERLAY
A PAGEDOWN(25)
A PAGEUP(26)
A 30 SFLDSPCTL
A 31 SFLDSP
A 32 SFLEND(*MORE)
A 33 SFLCLR
A CA05(05 'F5=Refresh')
A CF11(11 'F11=Fold')
A Z1SCREEN 12A O 2 2COLOR(BLU)
A 2 72SYSNAME
A COLOR(BLU)
A 3 2'Position to'
A Z1POS1 11S 0B 3 15COLOR(BLU)
A Z1POS2 11S 0B 3 26COLOR(BLU)
A 4 2'Actions: 1=View'
A COLOR(BLU)
A 4 19'2=Edit 7=Delete'
A COLOR(BLU)
A 5 7'Order No'
A DSPATR(UL)
A DSPATR(HI)
A 5 26'Customer'
A DSPATR(UL)
A DSPATR(HI)
A 5 41'Amount'
A DSPATR(UL)
A DSPATR(HI)
A 1 21'Order Header Screen'
A R FOOT01
A 23 3'F3=Exit F12=Return'
A* SubFile Record
A*
A R SFL02 SFL
A Z2RRN 2S 0H
A Z2OPT 1A B 7 3
A DETAIL_NUMR Y O 7 6REFFLD(DETAIL_NUM)
A EDTCDE(4)
A DETAIL_LINR Y O 7 17REFFLD(DETAIL_LIN)
A DETAIL_SKUR O 7 29REFFLD(DETAIL_SKU)
A* Control Record
A*
A R CTL02 SFLCTL(SFL02)
A SFLSIZ(0014)
A SFLPAG(0014)
A OVERLAY
A PAGEDOWN(25)
A PAGEUP(26)
A 30 SFLDSPCTL
A 31 SFLDSP
A 32 SFLEND(*MORE)
A 33 SFLCLR
A*N77 SFLDROP(CF11)
A* 77 SFLFOLD(CF11)
A CA05(05 'F5=Refresh')
A CF11(11 'F11=Fold')
A Z2SCREEN 12A O 2 2COLOR(BLU)
A 2 72SYSNAME
A COLOR(BLU)
A 3 2'Position to'
A Z2POS1 R B 3 15REFFLD(DETAIL_NUM)
A COLOR(BLU)
A Z2POS2 R B 3 26REFFLD(DETAIL_LIN)
A COLOR(BLU)
A 1 21'Order Detail Screen'
A 4 2'Actions: 1=View'
A COLOR(BLU)
A 4 19'2=Edit 7=Delete'
A COLOR(BLU)
A 5 7'Order No'
A DSPATR(UL)
A DSPATR(HI)
A 5 29'SKU'
A DSPATR(UL)
A DSPATR(HI)
A 5 22'Line'
A DSPATR(UL)
A COLOR(WHT)
A R FOOT02
A 23 3'F3=Exit F12=Return'
// Program: SF_07
// a work in progress
// load page at a time subfile
// this example permits positioning and page up/down
// permits view/edit/delete
// edit with simple error message
//
// Create order detail table, indexes, then add 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
//
// Indexes:
//
// CREATE INDEX MYLIB/ORD_DETL1
// ON ORDER_DET(DETAIL_NUM, DETAIL_LIN)
ctl-opt option(*nodebugio:*srcstmt:*nounref) dftactgrp(*no) ;
dcl-f ORD_DETL1 disk keyed
usage(*input: *update: *output: *delete);
dcl-f SF_07D workstn indds(Indds) infds(InfDs) sfile(SFL01:Z1RRN) ;
dcl-ds Indds qualified ;
Exit ind pos(3) ;
Drop ind pos(11) ; //note: cannot use drop/fold when SFLSIZ=SFLPAG
Return12 ind pos(12) ;
PageDown ind pos(25) ;
PageUp ind pos(26) ;
SflDspCtl ind pos(30) ;
SflDsp ind pos(31) ;
SflEnd ind pos(32) ;
SflClr ind pos(33) ;
RecView ind pos(50) ;
RecEdit ind pos(51) ;
RecAdd ind pos(52) ;
Refresh ind pos(77) ;
end-ds ;
dcl-ds InfDs qualified ;
KeyPress char(1) pos(369);
end-ds ;
dcl-ds PgmDs psds qualified ;
PgmName *proc ;
end-ds ;
// constants
dcl-c true const(*on);
dcl-c false const(*off);
// FunctionKey values (in hex)
dcl-c EnterKey const(x'F1');
dcl-c F06 const(x'36');
// variables
dcl-s SflSize like(Z1RRN) inz(16) ; // if changed, must change in DDS as well
dcl-s SflPage like(Z1RRN) inz(16) ;
dcl-s PrvPos1 like(Z1POS1) ; // position to variable 1
dcl-s PrvPos2 like(Z1POS2) ; // position to variable 2
dcl-s ACTION char(20);
dcl-s Error ind;
dcl-s redisplay_sfl char(1);
//-------------------------------------------------------
Init();
ProcessSubfile1();
*inlr = *on ;
Return;
//-------------------------------------------------------
dcl-proc ProcessSubfile1;
SubfileDown1() ;
dow not(Indds.Exit) ;
write dummy ;
write Header01 ;
write Footer01 ;
exfmt CTL01 ;
// page down
if (Indds.PageDown) ;
if not(Indds.SflEnd) ;
SubfileDown1();
endif ;
// page up
elseif (Indds.PageUp) ;
SubfileUp1() ;
// add record (F6)
elseif (InfDs.KeyPress = F06);
// to do
RecordAdd();
// re-position subfile
elseif ((Z1POS1 <> PrvPos1) or (Z1POS2 <> PrvPos2));
setll (Z1POS1:Z1POS2) ORDER_DETR;
SubfileDown1() ;
PrvPos1 = Z1POS1 ;
PrvPos2 = Z1POS2 ;
// refresh
elseif (Indds.Refresh) ;
setll *loval ORDER_DETR;
Init();
SubfileDown1() ;
iter ;
endif;
if (Indds.SflDsp) ;
ReadSubfile() ;
endif ;
enddo ;
end-proc;
//-------------------------------------------------------
dcl-proc WriteControlRec1 ;
Indds.SflDspCtl = *Off ;
Indds.SflDsp = *Off ;
Indds.SflEnd = *Off ;
Indds.SflClr = *On ;
write CTL01 ;
Indds.SflDspCtl = *On ;
Indds.SflClr = *Off ;
end-proc;
//-------------------------------------------------------
// Read down table and write data to subfile
//-------------------------------------------------------
dcl-proc SubfileDown1 ;
WriteControlRec1();
for Z1RRN = 1 to SflSize ;
read ORDER_DETR;
if (%eof) ;
Indds.SflEnd = *on ;
leave ;
endif ;
write SFL01 ;
endfor ;
if (Z1RRN > 1) ;
Indds.SflDsp = *on ;
else ;
return ;
endif ;
end-proc;
//-------------------------------------------------------
// Page up
//-------------------------------------------------------
dcl-proc SubfileUp1 ;
chain 1 SFL01 ;
setll (DETAIL_NUM: DETAIL_LIN) ORDER_DETr;
for Z1RRN = 1 to SflSize ;
readp ORDER_DETR;
if (%eof) ;
leave ;
endif ;
endfor ;
setll (DETAIL_NUM: DETAIL_LIN) ORDER_DETR;
SubfileDown1() ;
end-proc;
// ---------------------------------------------------------------------
// Read through current subfile page and act on user input
// ---------------------------------------------------------------------
dcl-proc ReadSubfile ;
Eval redisplay_sfl = 'N';
dow (1 = 1) ;
Eval Indds.recView = false;
Eval Indds.recEdit = false;
Eval Indds.recAdd = false;
readc SFL01 ;
if (%eof) ;
leave ;
endif ;
// Act on user inpu in option field (Z1OPT)
select;
when Z1OPT = '1';
View_Record();
Eval redisplay_sfl = 'N';
when Z1OPT = '2';
Edit_Record();
Eval redisplay_sfl = 'Y';
when Z1OPT = '4';
Delete_Record();
Eval redisplay_sfl = 'Y';
other;
Eval Z1OPT = Z1OPT;
endsl;
Z1OPT = ' ' ;
update SFL01 ;
enddo ;
//If there was delete, add or modify then reload page
If redisplay_sfl ='Y';
setll (Z1POS1:Z1POS2) ORDER_DETR;
ACTION = 'SCREEN1';
SubfileDown1();
Endif;
end-proc ;
//------------------------------------------------------------------------
// Edit on detail record
//------------------------------------------------------------------------
dcl-proc Edit_Record;
Eval *IN10 = *off; // SFL Display
Eval Z2SCREEN = %trimr(PgmDs.PgmName) + '-2';
Eval Indds.recEdit = true;
Dow not(Indds.Exit) and not(Indds.Return12) ;
//Write Detail;
If (Error = false);
Eval S_SKU = DETAIL_SKU;
EndIf;
Exfmt Window02;
// Press enter to validate/update
If InfDs.KeyPress = EnterKey and
DETAIL_SKU <> S_SKU;
ValidateRecord();
If Error = *Off;
UpdateRecord();
Eval Indds.Return12 = *on;
EndIf;
EndIf;
// F12= Return
If Indds.Return12;
Eval Indds.Return12 = *off;
ACTION = 'SCREEN1';
LEAVE;
EndIf;
Enddo;
end-proc;
//-------------------------------------------------------
// View record
//------------------------------------------------------------------------
dcl-proc View_Record;
Eval *IN10 = *off; // SFL Display
Eval Indds.RecView = true;
Dow not(Indds.Exit) and not(Indds.Return12) ;
Eval S_SKU = DETAIL_SKU;
Exfmt Window02;
// Press enter to validate/update
If InfDs.KeyPress = EnterKey;
Eval Indds.Return12 = *on;
EndIf;
// F12= Return
If Indds.Return12;
// Eval Indds.Return12 = *off;
// ACTION = 'SCREEN1';
// LEAVE;
EndIf;
Enddo;
end-proc;
//------------------------------------------------------------------------
// Delete record
//------------------------------------------------------------------------
dcl-proc Delete_Record;
Chain (DETAIL_NUM:DETAIL_LIN) ORDER_DETR;
If %found();
Delete ORD_DETL1;
Endif;
end-proc;
//------------------------------------------------------------------------
// Add record
//------------------------------------------------------------------------
dcl-proc RecordAdd;
Dsply 'Add Record';
end-proc;
//-----------------------------------------------------------------
// Validation Logic
//-----------------------------------------------------------------
dcl-proc ValidateRecord;
Eval Error = *off;
Eval ErrorMsg = *blanks;
If (%Subst(S_SKU:1:1) < 'A') or
(%Subst(S_SKU:1:1) > 'Z');
Eval ERRORMSG = 'SKU must start with alpha character';
Eval Error = *on;
ElseIf (%len(%trim(S_SKU)) < 5) ;
Eval ErrorMsg = 'SKU must be at least 5 characters';
Eval Error = *on;
EndIf;
end-proc;
//------------------------------------------------------------------------
// Update Record
//------------------------------------------------------------------------
dcl-proc UpdateRecord;
If Error = *Off;
IF ACTION = 'ADD_RECORD';
Eval DETAIL_SKU =S_SKU;
Else;
Chain (DETAIL_NUM:DETAIL_LIN) ORDER_DETR;
If %found();
Eval DETAIL_SKU =S_SKU;
Update ORDER_DETR;
Endif;
EndIf;
EndIf;
end-proc;
//------------------------------------------------------------------------
// Init activities
//------------------------------------------------------------------------
dcl-proc Init;
Z1SCREEN = %trimr(PgmDs.PgmName) + '-1';
Eval Z1POS1 = 0;
Eval Z1POS2 = 0;
Eval PrvPos1 = 0;
Eval PrvPos2 = 0;
end-proc;
DDS:
A* Display file: SF_07D
A DSPSIZ(24 80 *DS3)
A REF(*LIBL/ORDER_DET)
A PRINT
A INDARA
A CA03(03 'F3=Exit')
A CA06(06 'F6=Add')
A CF12(12 'F12=RETURN')
A*----
A* SubFile Record
A R SFL01 SFL
A Z1RRN 2S 0H
A Z1OPT 1A B 6 3
A DETAIL_NUMR Y O 6 6REFFLD(DETAIL_NUM)
A EDTCDE(4)
A DETAIL_LINR Y O 6 17REFFLD(DETAIL_LIN)
A DETAIL_SKUR O 6 29REFFLD(DETAIL_SKU)
A*----
A* Control Record
A R CTL01 SFLCTL(SFL01)
A SFLSIZ(16)
A SFLPAG(16)
A OVERLAY
A PAGEDOWN(25)
A PAGEUP(26)
A 30 SFLDSPCTL
A 31 SFLDSP
A 32 SFLEND(*MORE)
A 33 SFLCLR
A CA05(05 'F5=Refresh')
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 2'Actions: 1=View'
A COLOR(BLU)
A 4 19'2=Edit 4=Delete'
A COLOR(BLU)
A 5 7'Order No'
A DSPATR(UL)
A DSPATR(HI)
A 5 29'SKU'
A DSPATR(UL)
A DSPATR(HI)
A 5 22'Line'
A DSPATR(UL)
A COLOR(WHT)
A*----
A R WINDOW02 WINDOW(3 2 15 63)
A OVERLAY
A Z2SCREEN 12A O 1 2COLOR(BLU)
A 1 53SYSNAME
A COLOR(BLU)
A 50 1 23'View Record'
A 51 1 23'Edit Record'
A 52 1 23'Add Record'
A 5 4'Order'
A COLOR(WHT)
A 6 4'Line'
A COLOR(WHT)
A 7 4'SKU'
A COLOR(WHT)
A DETAIL_NUMR O 5 22REFFLD(DETAIL_NUM)
A EDTCDE(4)
A DETAIL_LINR O 6 22REFFLD(DETAIL_LIN)
A EDTCDE(4)
A S_SKU R B 7 22REFFLD(DETAIL_SKU)
A 50 DSPATR(PR)
A N50 DSPATR(UL)
A 09 22'SKU cannot be blanks and must cont-
A ain an'
A 10 22'alpha character in first position.'
A 13 3'F3=Edit'
A 13 14'Enter=Update'
A 13 30'F12=Return'
A ERRORMSG 40A O 14 3
A COLOR(RED)
A
A
A*----
A R HEADER01
A OVERLAY
A Z1SCREEN 12A O 1 2COLOR(BLU)
A 1 72SYSNAME
A COLOR(BLU)
A 1 21'Order Detail Screen'
A*----
A R FOOTER01
A OVERLAY
A 23 3'F3=Exit F6=Add'
A*----
A R DUMMY
A ASSUME
A 1 2' '
// Program: SF_08
// shows usage of message subfile for showing errrors on data entry
// Setup:
// Create order detail table, indexes, then add 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
//
// Index:
// CREATE INDEX MYLIB/ORD_DETL1
// ON ORDER_DET(DETAIL_NUM, DETAIL_LIN)
// Create message file:
// CRTMSGF MSGF(MYLIB/MY_MSGF) TEXT('my test message file')
//
// Add messages:
// ADDMSGD MSGID(MSG0014) MSGF(MY_MSGF) MSG('SKU cannot be blanks')
// SECLVL('SKU mandatory. Cannot be blanks.')
//
// ADDMSGD MSGID(MSG0099) MSGF(MY_MSGF) MSG('Generic Message')
// inspired by
// https://www.go4as400.com/chapterload.aspx?cid=149
// https://www.ibm.com/support/pages/example-message-subfile-ile-rpg-iv-program
ctl-opt option(*nodebugio:*srcstmt:*nounref) dftactgrp(*no) ;
dcl-F SF_08D workstn indds(Indds);
dcl-f ORD_DETL1 disk keyed
usage(*input: *update: *output: *delete);
dcl-S S_Msg char(30);
dcl-pr SFMSGSFLCL extpgm('SFMSGSFLCL');
MsgID char(7);
Msgf char(10);
MsgOpt char(1);
end-pr ;
dcl-ds Indds qualified ;
Exit ind pos(3) ;
Return12 ind pos(12) ;
end-ds ;
dcl-s MSGID char(7);
dcl-s MSGF char(10);
dcl-s MSGOPT char(1);
dcl-c true const(*on);
dcl-c false const(*off);
//---------------------------------------------------------------------
eval PgmQ ='SF_08';
exsr GetNextRecord;
exsr ProcessMsgSubfile;
Dow ((Indds.Exit = false) and (Indds.Return12 = false));
if ((Indds.Exit = true) or (Indds.Return12 = true));
leave;
endif;
exsr ValidateUserInput;
if S_MSG = *blanks;
exsr UpdateRecord;
exsr GetNextRecord;
else;
eval S_MSG = 'MSG0099';
exsr ShowMsg;
endif;
exsr ProcessMsgSubfile;
exsr ClrMsgQ;
eval S_MSG = *blanks;
enddo;
eval *InLR = *On;
return;
//---------------------------------------------------------------------
begsr ProcessMsgSubfile;
write Header02;
write Footer02;
write AccCtl;
read Header02;
endsr;
//---------------------------------------------------------------------
begsr ValidateUserInput;
// SKU cannot be blanks else show message MSG0014
if DI_SKU = *blanks;
eval S_MSG = 'MSG0014';
exsr ShowMsg;
eval S_MSG = 'MSG0099';
exsr ShowMsg;
// eval S_MSG = *blanks;
endif;
endsr;
//---------------------------------------------------------------------
Begsr UpdateRecord;
Chain (DI_NUM:DI_LIN) ORDER_DETR;
If %found();
eval DETAIL_SKU = DI_SKU;
update Order_DetR;
Endif;
eval DETAIL_SKU = DI_SKU;
eval DETAIL_NUM = DI_NUM;
eval DETAIL_LIN = DI_LIN;
write Order_DetR;
eval DI_SKU = *blanks;
endsr;
//---------------------------------------------------------------------
Begsr SHOWMSG;
EVAL MSGID = S_MSG;
EVAL MSGF = 'MY_MSGF';
EVAL MSGOPT = 'I';
Exsr Send;
endsr;
//---------------------------------------------------------------------
Begsr Send;
SFMSGSFLCL(MSGID:MSGF:MSGOPT);
Endsr;
//---------------------------------------------------------------------
begsr CLRMSGQ;
EVAL MSGOPT = 'C';
Exsr Send;
endsr;
//---------------------------------------------------------------------
begsr GetNextRecord;
setgt (*hival:*hival) ORDER_DETR;
readp ORDER_DETR;
if not %Eof();
DI_NUM = DETAIL_NUM ;
DI_LIN = DETAIL_LIN + 1 ;
else;
Eval DETAIL_NUM = 1 ;
Eval DETAIL_LIN = 1 ;
DI_NUM = DETAIL_NUM ;
DI_LIN = DETAIL_LIN;
endif;
Endsr;
DDS:
A* Display File: SF_08D
A DSPSIZ(24 80 *DS3)
A REF(*LIBL/ORDER_DET)
A INDARA
A CA03(03 'EXIT')
A CA12(12 'PREVIOUS')
A*-------------------------------
A R HEADER02
A 1 30'Edit Order Detail'
A DSPATR(HI)
A COLOR(BLU)
A 9 4'Order'
A COLOR(WHT)
A 10 4'Line'
A COLOR(WHT)
A 11 4'SKU'
A COLOR(WHT)
A DI_NUM R O 9 22REFFLD(DETAIL_NUM)
A EDTCDE(4)
A DI_LIN R O 10 22REFFLD(DETAIL_LIN)
A EDTCDE(4)
A DI_SKU R B 11 22REFFLD(DETAIL_SKU)
A 50 DSPATR(PR)
A N50 DSPATR(UL)
A*-------------------------------
A R FOOTER02
A OVERLAY
A 23 5'F3 = EXIT'
A DSPATR(HI)
A COLOR(BLU)
A 23 20'F12 = CANCEL'
A DSPATR(HI)
A COLOR(BLU)
A*-------------------------------
A R ACCSFL SFL
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A PGMQ SFLPGMQ(10)
A*-------------------------------
A R ACCCTL SFLCTL(ACCSFL)
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N03 SFLEND(*PLUS)
A SFLSIZ(0002)
A SFLPAG(0001)
A PGMQ SFLPGMQ(10)
CL: SFMSGSFLCL
/* CL: SFMSGSFLCL */
PGM PARM(&MSGID &MSGF &MSGOPT)
DCL VAR(&MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&MSGOPT) TYPE(*CHAR) LEN(1)
IF COND(&MSGOPT *EQ 'I') THEN(SNDPGMMSG +
MSGID(&MSGID) MSGF(&MSGF))
IF COND(&MSGOPT *EQ 'C') THEN(RMVMSG PGMQ(*PRV +
(*)) CLEAR(*ALL))
ENDPGM
This program calls RPG_02 to add up two numbers using old-school (pre-2001) fixed-column coding for field definitions and calculations
* Program Name: RPG_01
* This program calls RPG_02 to add up two numbers
* using old-school (pre-2001) fixed-column coding
* for field definitions and calculations
* Usage: Call RPG_01
D
D Var1 S 3P 0
D Var2 S 3P 0
D Response S 4P 0
C Eval Var1 = 5
C Eval Var2 = 10
* This is a fixed format RPG IV Call to external program RPG_02
* to add up two numbers
C Call 'RPG_02'
C Parm Var1
C Parm Var2
C Parm Response
* Display response
C Response Dsply
C Eval *inlr = *on
C Return
// Program Name: RPG_02
// This program receives two values, adds them together and return sum
// in a third parameter called Response
D Var1 S 3P 0
D Var2 S 3P 0
D Response S 4P 0
C *Entry PLIST
C PARM Var1
C PARM Var2
C PARM Response
C Eval Response = var1 + var2
C Eval *inlr = *on
C Return
// Program Name: RPG_03
// This program calls RPG_04 to add up two numbers
// The CALLP operation is used to call prototyped program RPG_04
// Takes advantage of improvements in RPG language over past few years including:
// 1994 (IBM V3R1) - RPG IV (ILE RPG) Introduced (including CALLP)
// 1999 (IBM V4R4) - Prototypes (Dcl-Pr) introduced
// 2001 (V5R1) - Introduced free-form calculations - (/FREE and /END-FREE)
// 2014 (IBM 7.1) - Allowed fully free-form RPG, including D-specs
// F-specs (file definitions), and P-specs (prototypes).
// 2015 (IBM 7.2) - /FREE and /END-FREE became optional;
// all logic could be free-form by default.
// Prototype for external program
// Here the internal function name (Add_Two_Numbers) is clearer than RPG_04.
Dcl-pr Add_Two_Number extpgm('RPG_04');
Var1 packed(3:0) ;
Var2 packed(3:0) ;
Response packed(4:0) ;
End-pr ;
Dcl-s Var1 packed(3:0) ;
Dcl-s Var2 packed(3:0) ;
Dcl-s Response packed(4:0) ;
// Add two numbers
Var1 = 5 ;
Var2 = 10 ;
// CALLP with prototype replaces CALL in RPG /free
CALLP Add_Two_Number(Var1:Var2:Response);
Dsply Response;
Add_Two_Number(Var1:Var2:Response);
Dsply Response;
Eval *inlr = *on;
Return;
RPGLE program RPG_04 is used to add up two values
Note use of prototype interface declaration (Dcl-pi) here for parameters
// Program Name: RPG_04
// This program receives two values, adds them together and returns them in third paramete
// ctl-opt dftactgrp(*no) actgrp(*caller);
Dcl-pi RPG_04 extpgm('RPG_04');
Var1 packed(3:0) ;
Var2 packed(3:0) ;
Response packed(4:0) ;
End-pi ;
Eval response = var1 + var2 ;
Eval *inlr = *on;
Return;
// Program RPG_12
// Example of a sub-procedure defined and used within same program
// to compile: PDM-14 or CRTBNDRPG PGM(RPG_12) SRCMBR(RPG_12)
// dftactgrp(*no) permits compiler to use the ILE sub-procedure 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 ;
RPG Service Program:
// Program RPG_23: Two examples of sub-procedures that adds up two numbers
// to Compile:
// 1. Create Modules:
// CHGCURLIB MYLIB
// CRTRPGMOD MODULE(RPG_23) SRCFILE(PROCEDURES) SRCMBR(UTIL)
// 2. Create Service program:
// CRTSRVPGM SRVPGM(RPG_23) MODULE(UTIL) EXPORT(*ALL)
Ctl-opt option(*srcstmt:*nodebugio) nomain ;
// ---------------------------------------------------------------
// Example of function:
// this function returns sum of two packed numbers in a third parameter
Dcl-proc SUMVALUES1 export; // max 10 characters, can be lower/mixed case, but easier as uppercase
Dcl-pi *n packed(15:5);
a packed(15:5) const ;
b packed(15:5) const ;
End-pi ;
Dcl-s c packed(15:5);
c = a + b;
snd-msg %char(c);
return c;
End-proc;
// ---------------------------------------------------------------
// Example of procedure:
// this procedure returns sum of two packed numbers in a third parameter
Dcl-proc SUMVALUES2 export; // max 10 characters
Dcl-pi *n ;
a packed(15:5) const ;
b packed(15:5) const ;
c packed(15:5) ;
End-pi ;
c = a + b;
End-proc;
2. Create RPG Module:
CHGCURLIB MYLIB
CRTRPGMOD MODULE(RPG_23) SRCFILE(PROCEDURES) SRCMBR(RPG_23)
3. Create an RPG Service Program:
CRTSRVPGM SRVPGM(RPG_23) MODULE(RPG_23) EXPORT(*ALL)
4. Create an SQL Function
Use the IBM i Access Client Solutions "Run SQL Scripts tool". STRSQL does not seem to support the required syntax)
We may want to drop previously Created function first.
Drop function MYLIB.SUMVALUES1;
Create SQL function
Create or replace function MYLIB.SUMVALUES1 (a decimal(15,5), b decimal(15,5) ) returns decimal(15,5) external name 'MYLIB/RPG_23(SUMVALUES1)' language rpgle deterministic parameter style general;
5. call the Function
SELECT MYLIB.SUMVALUES1( 21.1 , 51.1 ) from sysibm.sysdummy1;
6. Creating an SQL Procedure:
Drop procedure MYLIB.SUMVALUES2; create or replace procedure MYLIB.SUMVALUES2 (in var1 decimal(15,5), in var2 decimal(15,5), out sum decimal(15,5) ) external name 'MYLIB/RPG_23(SUMVALUES2)' language rpgle deterministic parameter style general;
7. Running an SQL Procedure:
Create or replace variable MYLIB.sum dec(15,5); set MYLIB.sum = 0; call MYLIB.SUMVALUES2(1, 5, MYLIB.sum); values MYLIB.sum;
8. List of procedures and functions
SELECT substr(SPECIFIC_SCHEMA, 1, 20)as SPECIFIC_SCHEMA, substr(SPECIFIC_NAME, 1, 20) as SPECIFIC_NAME, substr(ROUTINE_SCHEMA, 1, 20) as ROUTINE_SCHEMA, substr(ROUTINE_NAME, 1, 20) as ROUTINE_NAME, substr(EXTERNAL_NAME, 1, 30), substr(ROUTINE_TYPE, 1, 20) EXTERNAL_LANGUAGE, PARAMETER_STYLE, IS_DETERMINISTIC FROM QSYS2.SYSROUTINES WHERE SPECIFIC_SCHEMA like '%MYLIB%'