ecki/IBM-i-RPG-Free-CLP-Code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve & cleanup

Browse Source 
Improved images, cleaned up code, revised documentation.
This commit is contained in:
SJLennon 2020-10-19 15:02:55 -04:00
parent 2dc0714b39
commit 066e786d72
12 changed files with 474 additions and 549 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
5250_Subfile/Images/Inquiry_Display.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 31 KiB

After

Width:  |  Height:  |  Size: 30 KiB

BIN
5250_Subfile/Images/Maintenance_Display.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 32 KiB

After

Width:  |  Height:  |  Size: 32 KiB

BIN
5250_Subfile/Images/State_Prompt.png
View File

Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 30 KiB

After

Width:  |  Height:  |  Size: 33 KiB

18
5250_Subfile/LOADCUST Normal file
View File

@ -0,0 +1,18 @@
PGM
CHKOBJ OBJ(CUSTMAST) OBJTYPE(*FILE)
MONMSG MSGID(CPF9801) EXEC(GOTO CMDLBL(SUBMIT))
ALCOBJ OBJ((CUSTMAST *FILE *EXCLRD)) WAIT(5) +
CONFLICT(*RQSRLS)
MONMSG MSGID(CPF1002) EXEC(DO)
SNDMSG MSG('Cannot allocate CUSTMAST') +
TOUSR(*REQUESTER)
RETURN
ENDDO
DLCOBJ OBJ((CUSTMAST *FILE *EXCLRD))
SUBMIT: SBMJOB CMD(RUNSQLSTM +
SRCSTMF('/home/LENNONS/GITHUB/5250_Subfile/+
custmast.sql') COMMIT(*NONE) ERRLVL(40)) +
JOB(SL_LOAD)
ENDPGM

26
5250_Subfile/MTNCUSTD
View File

@ -1,8 +1,8 @@
A*%%TS SD 20120202 211644 SLENNON REL-V7R1M0 5770-WDS
A*===============================================================
A* Window to display or update Customer Master
A*===============================================================
A* CRTDSPF RSTDSP(*NO)
A* CRTDSPF FILE(MTNCUSTD) SRCFILE(...) RSTDSP(*YES)
A*==============================================================
A* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_
A* -- Details Fields begin with SD_
@ -19,22 +19,17 @@
A* 91-99 Subfile Control Record
A* Note: INDARA is specified here and in the program and this
A* means that the display file indicators are in a
A* means that the display file indicators are in a
A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS.
a* Note: DSPATR HI and RI at the same time = non-display. Thus
a* when we turn on RI were turn of HI,
A*===============================================================
A* MM/DD/YYYY Proj# Developer
A* ---------- ----- -------------------------------------------
A* 10/21/2012 8399 Sam Lennon Original coding
A*
A*==============================================================
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A INDARA
A ALTHELP
A CA03
A CF04
A CA05
A CA12
@ -43,13 +38,10 @@
A*=== Screen Header: Fields begin with SH_ =====================
A*
A R SH_HDR
A*%%TS SD 20111207 212036 SLENNON REL-V7R1M0 5770-WDS
A OVERLAY
A TEXT('Screen Header')
A WDWBORDER((*COLOR PNK))
A WINDOW(*DFT 17 54)
A* CA03
A* CA12
A SH_PGM 10A O 1 1
A 1 21'Customer Master'
A 1 47DATE
@ -132,16 +124,19 @@
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 13 1'Last Change'
A N61 DSPATR(ND)
A SD_CHGTIME 23 13 13
A N61 DSPATR(ND)
A 13 37'by'
A N61 DSPATR(ND)
A SD_CHGUSER 15 13 40
A N61 DSPATR(ND)
A SD_PMT_RCD 10A H
A SD_PMT_FLD 10A H
A*===============================================================
A*=== Screen footer & function keys: Fields begin with SFT_ ====
A*
A R SFT_FKEY
A*%%TS SD 20111208 204102 SLENNON REL-V7R1M0 5770-WDS
A TEXT('Screen Footer')
A OVERLAY
A WINDOW(SH_HDR)
@ -153,7 +148,6 @@
A*=== Message Subfile: No fields ===============================
A*
A R MSGSFL SFL
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile')
A SFLMSGRCD(16)
A MSGKEY SFLMSGKEY
@ -162,7 +156,6 @@
A*=== Message Subfile Control: No fields ========================
A*
A R MSGCTL SFLCTL(MSGSFL)
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile Control')
A WINDOW(SH_HDR)
A PAGEDOWN
@ -193,3 +186,8 @@
A*%%RS+ <record-write record-format="DUMMY" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>
A*%%RS+<record-sequences>
A*%%RS+ <sequence name="Untitled">
A*%%RS+ <device type="display" width="80" height="24" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>

348
5250_Subfile/MTNCUSTR
View File

@ -7,16 +7,11 @@
// ----------
// 1 In Z4 Customer Id to, or 0 to add a new code
// 2 In CL1 Function
// C - Close Display file
// E - Edit passed record
// D - Display passed record
// A - Add a new record
// D - Display record
//
//==============================================================
// MM/DD/YYYY Proj# Developer
// ---------- ----- -------------------------------------------
// 10/21/2012 8399 Sam Lennon Original coding
//
// If no parms passed, close the display file and return.
//==============================================================
// Program is essentially without indicators. (Indicators are
// stil lneeded to control the display file, but all have names.)
@ -31,7 +26,7 @@
// carried across subroutines.
// - UPPERCASE is used for external names, i.e., files, fields, formats
// and anything else not directly coded in the program.
//
// - In the display file, this screen field naming convention is used:
// Screen Header: Fields begin with SH_
// Detail Fields begin with SD_
@ -43,26 +38,30 @@
// not the default of QRPGLESRC. Change as needed.
//=============================================================
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND')
h DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
h BndDir('UTIL_BND')
h main(Main)
//=== Display File =============================================
FMTNCUSTD CF E WorkStn INFDS(dfInfDS)
F INDDS(dfIndDS)
F USROPN
fmTNCUSTD CF E WorkStn INFDS(dfInfDS)
f INDDS(dfIndDS)
f USROPN
d Main pr extpgm('MTNCUSTR')
d pID like(CUSTID)
d pMaintain 1a
//=== Service Program Prototypes ===============================
/include DEMO,Srv_Msg_P
/include DEMO,Srv_Str_P
//=== Named hexadecimal constants for function keys ============
/include DEMO,##AIDBYTES
//=== Fields read by SQL ========================================
// NOTE: Only the fields in the SQL statement are populated!
D CUSTMAST e ds extname(CUSTMAST)
// qualified template
// FetchData ds likeds(STATES)
D
d CUSTMAST e ds extname(CUSTMAST)
//=== SQL State Constants ======================================
d SQLSuccess c '00000'
d SQLNoData c '02000'
@ -70,113 +69,95 @@
d SQLDupRecd c '23505'
d SQLRowLocked c '57033'
//=== Display File Information Data Structure ==================
// Allows us to determine which function key was pressed
D dfInfDS DS
D Key 369 369
d dfInfDS DS
d Key 369 369
//=== Display File Indicator Data Structure ====================
// This is a "private" indicator area for the display file.
D dfIndDS ds 99
d dfIndDS ds 99
//--- 01-20 are not automatically cleared after EXFMT ----------
D Protect_SD_ALL 10 10n
d Protect_SD_ALL 10 10n
//--- 21-99 are automatically cleared after EXFMT --------------
D dfIndClr 21 99 ????
D RI_SD_ACTIVE 40 40n
D PC_SD_ACTIVE 41 41n
D RI_SD_NAME 42 42n
D PC_SD_NAME 43 43n
D RI_SD_ADDR 44 44n
D PC_SD_ADDR 45 45n
D RI_SD_CITY 46 46n
D PC_SD_CITY 47 47n
D RI_SD_STATE 48 48n
D PC_SD_STATE 49 49n
D RI_SD_ZIP 50 50n
D PC_SD_ZIP 51 51n
D RI_SD_ACCTPH 52 52n
D PC_SD_ACCTPH 53 53n
D RI_SD_ACCTMGR 54 54n
D PC_SD_ACCTMGR 55 55n
D RI_SD_CORPPH 56 56n
D PC_SD_CORPPH 57 57n
//*=== Fields to control the subfile screen =====================
// SflRRN s 5 0
// RcdsInSfl s 5 0
// SflPageSize c 12
//* SC_CSR_RCD is defined in the display file and is set with a
//* RRN which determines which subfile page is displayed and on
//* which record the cursor is positioned.
d dfIndClr 21 99
d RI_SD_ACTIVE 40 40n
d PC_SD_ACTIVE 41 41n
d RI_SD_NAME 42 42n
d PC_SD_NAME 43 43n
d RI_SD_ADDR 44 44n
d PC_SD_ADDR 45 45n
d RI_SD_CITY 46 46n
d PC_SD_CITY 47 47n
d RI_SD_STATE 48 48n
d PC_SD_STATE 49 49n
d RI_SD_ZIP 50 50n
d PC_SD_ZIP 51 51n
d RI_SD_ACCTPH 52 52n
d PC_SD_ACCTPH 53 53n
d RI_SD_ACCTMGR 54 54n
d PC_SD_ACCTMGR 55 55n
d RI_SD_CORPPH 56 56n
d PC_SD_CORPPH 57 57n
d DSP_SD_STAMP 61 61n
//=== Screen Header Text =======================================
D H2TextD s like(SH_FUNCT)
D inz('Display')
D H2TextU s like(SH_FUNCT)
D inz('Add/Change')
d H2TextE s like(SH_FUNCT)
d inz('Change Customer')
d H2TextA s like(SH_FUNCT)
d inz('Add Customer')
d H2TextD s like(SH_FUNCT)
d inz('Displaying Customer')
//=== Text for function keys ===================================
D F3Text c 'F3=Exit'
//F4Text c 'F4=Prompt*'
d F3Text c 'F3=Exit'
d F4Text c 'F4=Prompt+'
d F5Text c 'F5=Refresh'
d F12Text c 'F12=Cancel'
//=== External Programs Prototypes =============================
D PmtState PR EXTPGM('PMTSTATER')
D TheState like(STATE)
d PmtState PR EXTPGM('PMTSTATER')
d TheState like(STATE)
d
//=== Global Switches ==========================================
D SflMsgSnt s n
D CowsComeHome c const('0')
D Function s 1a
D Displaying c const('D')
D Editing c const('E')
D Adding c const('A')
D Closing c const('C')
D NoErrors s n
d SflMsgSnt s n
d CowsComeHome c const('0')
d Function s 1a
d Displaying c const('D')
d Editing c const('E')
d Adding c const('A')
d NoErrors s n
// === Global Fields ===========================================
D Orig_CHGTIME s z
d Orig_CHGTIME s z
//=== Work Fields ==============================================
D wkInt s 10i 0
D wkMsgText s 256a varying
//=== Translation ==============================================
D Lower c const('abcdefghijklmnopqrstuvwxyz')
D Upper c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
D HighVals s 30 inz(*hival)
d wkInt s 10i 0
d wkMsgText s 256a varying
// === Next available customer number ==========================
// CUSTNEXT ds dtaara(CUSTNEXT)
d Cust_Next s 4p 0 dtaara(CUSTNEXT)
//=== Program Status Data Structure ============================
D ProgStatus sds
D PgmName *PROC
D CURR_USER 358 367 * Current user
D USER 254 263 * User name
d ProgStatus sds
d PgmName *PROC
d CURR_USER 358 367 * Current user
//=== Program Parameters =======================================
D pId s Like(CUSTID)
D pMaintain s 1a
// I/O/B Type Lgth Description
// ----- ---- ---- -----------------------------------------
// I P 3 Manufacturing Cust Mast
// I C 1 If Y, then maintenance is allowed.
// Otherwise, or omitted, display only.
d MainProc S 10a
//==============================================================
//==============================================================
// === Program Starts Here =====================================
//==============================================================
C *Entry plist
C parm pId
C parm pMaintain
p Main b
d Main pi
d pID like(CUSTID)
d pMaintain 1a
/FREE
//=== Set SQL Options ===============================
@ -228,7 +209,7 @@
exsr ScreenIO;
select;
when Key = F03 or Key = F12;
when Key = F12;
exsr CloseDownPgm;
return;
@ -242,21 +223,7 @@
NoErrors = *off;
when Key = F04;
// CF04 reads the screen data. We then prompt and replace
// anything in the state field, then we redisplay and
// re-edit the screen data.
select;
// --- Prompt for State Code
when SD_PMT_FLD = 'SD_STATE';
PmtState(STATE);
SD_STATE = STATE;
NoErrors = *off; // DOU Loop again
// --- Field not promptable
other;
// Use F4 only in field followed by + sign
SflMsgSnt= SndSflMsg('DEM0005');
NoErrors = *off; // DOU Loop again
endsl;
exsr F04Prompt;
when Key = Enter;
exsr EditUpdData;
@ -267,7 +234,7 @@
SflMsgSnt = SndSflMsg('DEM0000'); // Enter to update ...
exsr ScreenIO;
select;
when Key = F12 or Key = F03 or Key = F05;
when Key = F12 or Key = F05;
// Loop again
when Key = Enter;
exsr UpdateRecd;
@ -296,9 +263,6 @@
clear CUSTMAST;
//Default status to active
ACTIVE = 'Y';
//set just to make screen look better
CHGTIME = %timestamp();
CHGUSER = CURR_USER;
exsr FillScreenFields;
dou NoErrors;
@ -308,11 +272,20 @@
exsr UnProtectAll;
exsr ScreenIO;
select;
when Key = F03 or Key = F12;
when Key = F12;
exsr CloseDownPgm;
return;
when Key = F04;
exsr F04Prompt;
when Key = F05;
clear CUSTMAST;
ACTIVE = 'Y';
exsr FillScreenFields;
when Key = Enter;
exsr EditUpdData;
exsr EditAddData;
if NoErrors;
// Re-display field for confirmation
exsr ProtectAll;
@ -348,6 +321,7 @@
endsl;
enddo;
exsr CloseDownPgm; // Should never happen
return;
//============================================================
@ -355,7 +329,6 @@
//============================================================
return;
//=== ReadRecd ===============================================
begsr ReadRecd;
exec sql
@ -375,7 +348,7 @@
into :CUSTMAST
from CUSTMAST
where CUSTID = :pID
;
;
if SQLSTT <> SQLSuccess and SQLSTT <> SQLNoData;
SQLProblem('ReadRecd');
endif;
@ -394,12 +367,38 @@
SD_ACCTPH = ACCTPHONE;
SD_ACCTMGR =ACCTMGR;
SD_CORPPH = CORPPHONE;
exec sql VALUES
varchar_format(:CHGTIME, 'YYYY-Mon-DD')
concat ' at ' concat
varchar_format(:CHGTIME,'HH24:MI:SS')
into :SD_CHGTIME;
SD_CHGUSER = CHGUSER;
SD_CHGTIME = ' ';
SD_CHGUSER = ' ';
// Show Changed stamp info
if CHGUSER <> '*SYSTEM*' and CHGUSER <> ' ';
exec sql VALUES
varchar_format(:CHGTIME, 'YYYY-Mon-DD')
concat ' at ' concat
varchar_format(:CHGTIME,'HH24:MI:SS')
into :SD_CHGTIME;
SD_CHGUSER = CHGUSER;
DSP_SD_STAMP = *on;
endif;
endsr;
//=== F04Prompt ==============================================
// CF04 reads the screen data. We then prompt and replace
// anything in the state field, then we redisplay and
// re-edit the screen data.
// Always sets NoError to *off to force re-edit
begsr F04Prompt;
select;
// --- Prompt for State Code
when SD_PMT_FLD = 'SD_STATE';
PmtState(STATE);
SD_STATE = STATE;
PC_SD_STATE = *ON;
// --- Field not promptable
other;
// Use F4 only in field followed by + sign
SflMsgSnt= SndSflMsg('DEM0005');
endsl;
NoErrors = *off; // DOU Loop again
endsr;
//=== EditUpdData ============================================
@ -462,8 +461,8 @@
// Give up when the first error found.
// A valid screen field is moved to the database record.
begsr EditAddData;
NoErrors = *on;
// For this program. same data for edit and add.
exsr EditUpdData;
endsr;
//=== Edit_SD_ACTIVE==========================================
@ -577,7 +576,6 @@
PC_SD_CORPPH = *ON;
endsr;
//=== AddRecd ================================================
// Insert a record into the file.
// Returns: NoErrors = *on if the add was successful.
@ -588,7 +586,7 @@
Out Cust_Next;
CUSTID= Cust_Next;
CHGTIME = %timestamp();
CHGUSER = USER;
CHGUSER = CURR_USER;
exec sql
insert into custmast
values(:CUSTMAST)
@ -603,6 +601,7 @@
// Updates the record with the screen data.
// The SQL WHERE checks the last time stamp and if different,
// doesn't update because someone else updated the record.
// (This isn't the only way to avoid pessimistic locking.)
// SQLERRD(3) contains the actual number of records updated
// when the update is successful.
begsr UpdateRecd;
@ -619,7 +618,7 @@
ACCTPHONE = :SD_ACCTPH,
ACTIVE = :SD_ACTIVE,
CHGTIME = CURRENT TIMESTAMP,
CHGUSER = USER
CHGUSER = :CURR_USER
where CUSTID = :CUSTID
-- and compare timestamp
and CHGTIME = :Orig_CHGTIME;
@ -632,7 +631,6 @@
exsr FillScreenFields;
when SQLSTT =SQLRowLocked; // Row locked
// exec sql get diagnostics condition 1 :wkMsgText = MESSAGE_TEXT;
sflMsgSnt = SndSflMsg('DEM1001' : SQLERRMC);
NoErrors = *off;
when SQLSTT = SQLSuccess;
@ -676,7 +674,7 @@
// Clear any messages in the error subfile.
if SflMsgSnt = *on;
SflMsgSnt = ClrMsgPgmQ(PgmName);
SflMsgSnt = ClrMsgPgmQ(MainProc);
write MSGCTL;
endif;
@ -686,8 +684,7 @@
// Build the Function key text for the bottom of the screen.
begsr BldFkeyText;
SFT_KEYS=' ';
SFT_KEYS = CatB(SFT_KEYS : F3Text);
// SFT_KEYS = CatB(SFT_KEYS : F4Text);
SFT_KEYS = CatB(SFT_KEYS : F4Text);
SFT_KEYS = CatB(SFT_KEYS : F5Text);
SFT_KEYS = CatB(SFT_KEYS : F12Text);
endsr;
@ -695,9 +692,8 @@
//=== CloseDownPgm ===========================================
// Things to do before we issue a return to the caller
begsr CloseDownPgm;
// write DUMMY;
// close MTNCUSTD;
// Do not turn on *LR to maintain an SFL display in caller
// Closing the display file may cause any subfile display in
// the caller to blank out.
endsr;
//=== Init ===================================================
@ -705,31 +701,36 @@
begsr Init;
//--- Analyse parameters ---
if %parms() = 0; // Close down
if %open(MTNCUSTD);
close MTNCUSTD;
endif;
*inlr = *on;
return;
endif;
select;
when %parms() = 0; // Close down
if %open(MTNCUSTD);
close MTNCUSTD;
endif;
// *inlr = *on;
return;
when %parms() = 1;
Function = Displaying;
when %parms() = 2;
select;
when pMaintain = Closing;
when pMaintain = Adding;
Function = Adding;
when pMaintain = Editing;
Function = Editing;
other;
Function = Displaying;
function = displaying;
when %parms() >= 2;
select;
when pMaintain = Adding;
Function = Adding;
SH_FUNCT = CenterStr(H2TextA);
when pMaintain = Editing;
Function = Editing;
SH_FUNCT = CenterStr(H2TextE);
other;
Function = Displaying;
SH_FUNCT = CenterStr(H2TextD);
endsl;
other;
// Problem.
// Should never happen
endsl;
//--- Miscellaneous setup ---
MSGPGMQ = PgmName;
MainProc = %proc();
MSGPGMQ = MainProc;
SH_PGM = PgmName;
clear CUSTMAST;
clear dfIndDS;
@ -740,6 +741,9 @@
open MTNCUSTD;
endif;
endsr;
/END-FREE
p Main e
//============================================================
// S u b P r o c e d u r e s
//============================================================
@ -748,11 +752,10 @@
// Concatenates a string to another string with a blank between.
// If the target string is all blank to start with it will not
// end up with a leading blank.
/END-FREE
PCatB b
dCatB PI 79 varying
D ToStr 79 varying value
D AddStr 79 varying value
pcatB b
dcatB PI 79 varying
d ToStr 79 varying value
d AddStr 79 varying value
/FREE
if ToStr=' ';
return AddStr;
@ -760,8 +763,8 @@
return %trimr(ToStr) + ' ' + AddStr;
endif;
/END-FREE
PCatB e
P
pcatB e
p
//=== SQLProblem ===============================================
// For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by
@ -783,8 +786,6 @@
/end-free
p SQLProblem E
//--------------------------------------------------------------
// Procedure name: SndSflMsg
// Purpose: Send a message to the Error Subfile
@ -792,21 +793,20 @@
// Parameter: ErrMsgId => Msg Id to Send
// Parameter: ErrMsgData => Optional Error Message Data
// Parameter: ErrMsgFile => Optional Error Message File
// Defaults to PCAMSGF
// Defaults to CUSTMSGF
//--------------------------------------------------------------
P SndSflMsg B
D SndSflMsg PI N
D ErrMsgId 7A CONST
D ErrMsgData 80A CONST
D OPTIONS(*NOPASS:*VARSIZE)
D ErrMsgFile 10A CONST
D OPTIONS(*NOPASS)
p SndSflMsg B
d SndSflMsg PI N
d ErrMsgId 7A CONST
d ErrMsgData 80A CONST
d OPTIONS(*NOPASS:*VARSIZE)
d ErrMsgFile 10A CONST
d OPTIONS(*NOPASS)
// Local fields
D retField S N
D wkMsgId s 7a
D wkMsgFile s 10a
D wkMsgData s 80a varying
d retField S N
d wkMsgId s 7a
d wkMsgFile s 10a
d wkMsgData s 80a varying
/FREE
if %parms >2;
@ -820,7 +820,7 @@
wkMsgData = ' ';
ENDIF;
wkMsgId = ErrMsgId;
SNDMSGPGMQ(PgmName:
SNDMSGPGMQ(MainProc:
wkMsgid:
wkMsgFile:
wkMsgData);
@ -829,5 +829,5 @@
RETURN retField;
/END-FREE
P SndSflMsg E
p SndSflMsg E

33
5250_Subfile/PMTCUSTD
View File

@ -1,11 +1,11 @@
A*%%TS SD 20200723 195503 LENNONS REL-V7R4M0 5770-WDS
A*===============================================================
A* This is a full screen expanding subfile to search for and
A* select an item number.
A* ??- There are "from" and "to" positioner fields.
A* ??- There is a filter field on config.
A* ??- A message subfile is included.
A* This is a full screen expanding subfile to search for
A* a customer.
A* - There are filters limit selection.
A* - A message subfile is included.
A*===============================================================
A* CRTDSPF FILE(PMTCUSTD) SRCFILE(...) RSTDSP(*YES)
A*==============================================================
A* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_
A* -- Subfile: Fields begin with SF_
@ -27,11 +27,6 @@
A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS.
A*==============================================================
A* MM/DD/YYYY Proj# Developer
A* ---------- ----- -------------------------------------------
A* 04/14/2013 8651 Sam Lennon Original coding
A*===============================================================
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A INDARA
@ -41,14 +36,12 @@
A CA05
A CA06
A CA09
A* CF10
A CA12
A HELP
A*===============================================================
A*=== Screen Header: Fields begin with SH_ =====================
A*
A R SH_HDR
A*%%TS SD 20111207 212036 SLENNON REL-V7R1M0 5770-WDS
A OVERLAY
A TEXT('Screen Header')
A SH_PGM 10A O 1 2
@ -62,7 +55,6 @@
A*=== Subfile: Fields begin with SF_ ===========================
A*
A R SFL SFL
A*%%TS SD 20200719 214706 LENNONS REL-V7R4M0 5770-WDS
A TEXT('SubFile')
A 80 SFLNXTCHG
A SF_ACT_H 1D H
@ -82,7 +74,6 @@
A*=== Subfile Control: Fields begin with SC_ ====================
A*
A R SFLCTL SFLCTL(SFL)
A*%%TS SD 20200723 195503 LENNONS REL-V7R4M0 5770-WDS
A SFLSIZ(0013)
A SFLPAG(0012)
A TEXT('Subfile Control')
@ -95,10 +86,6 @@
A SFLDSPCTL
A 99 SFLCLR
A 97 SFLEND(*MORE)
A SC_PMT_RCD 10A H
A SC_PMT_FLD 10A H
A**** SC_CSR_RCD 4S 0H SFLRCDNBR(CURSOR *TOP)
A SC_CSR_RCD 4S 0H SFLRCDNBR(CURSOR)
A 4 2'Name starts with:'
A 4 31'City Starts with:'
A 4 60'State+'
@ -114,7 +101,7 @@
A N03 DSPATR(ND)
A 6 2'Type options, press Enter.'
A COLOR(BLU)
A SC_OPTIONS 69A O 7 2COLOR(BLU)
A SC_OPTIONS 69A 7 2COLOR(BLU)
A 8 2'Opt'
A DSPATR(HI)
A 8 6'Customer Name'
@ -129,11 +116,13 @@
A 8 74'ZIP '
A COLOR(WHT)
A DSPATR(UL)
A SC_PMT_RCD 10A H
A SC_PMT_FLD 10A H
A SC_CSR_RCD 4S 0H SFLRCDNBR(CURSOR)
A*===============================================================
A*=== Screen footer & function keys: Fields begin with SFT_ ====
A*
A R SFT_FKEY
A*%%TS SD 20111208 204102 SLENNON REL-V7R1M0 5770-WDS
A TEXT('Screen Footer')
A OVERLAY
A 22 2' Demo Cor-
@ -145,7 +134,6 @@
A*=== Message Subfile: No fields ===============================
A*
A R MSGSFL SFL
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile')
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
@ -154,7 +142,6 @@
A*=== Message Subfile Control: No fields ========================
A*
A R MSGCTL SFLCTL(MSGSFL)
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile Control')
A PAGEDOWN
A PAGEUP

218
5250_Subfile/PMTCUSTR
View File

@ -4,7 +4,7 @@
// It can be called to return a selected customer number or
// just to provide general inquiry functionality from a menu.
//
// Detailed Item information is displayed in a window by
// Detailed Item information is displayed in a window by
// call another program, MTNCUSTR.
//
// Parameters:
@ -15,11 +15,6 @@
// I - Inquiry, read only: 5=Display
// 2 Char 4 Selected customer id if parm 1 is S.
//
//
//=============================================================
// MM/DD/YYYY Proj# Developer
// ---------- ----- -----------------------------------------
// 00/00/0000 nnnnn Sam Lennon Original coding
//=============================================================
// Program uses a full screen expanding subfile to select
// a Customer Master record.
@ -60,14 +55,14 @@
// not the default of QRPGLESRC. Change as needed.
//=============================================================
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND')
h DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
h BndDir('UTIL_BND')
//=== Display File ============================================
FPMTCUSTD CF E WorkStn INFDS(dfInfDS)
F INDDS(dfIndDS)
F SFILE(SFL:SflRRN)
F USROPN
fPMTCUSTD CF E WorkStn INFDS(dfInfDS)
f INDDS(dfIndDS)
f SFILE(SFL:SflRRN)
f USROPN
// File is closed when returning with LR off. This avoids an
// annoying resdisplay of the last subfile on re-entry.
@ -80,41 +75,41 @@
//=== Display File Information Data Structure =================
// Allows us to determine which function key was pressed
D dfInfDS DS
D Key 369 369
d dfInfDS DS
d Key 369 369
//=== Display File Indicator Data Structure ===================
// This is a "private" indicator area for the display file.
D dfIndDS ds 99
d dfIndDS ds 99
//--- 01-20 are not automatically cleared after EXFMT ----------
D scIncActInc 03 03n
d scIncActInc 03 03n
//--- 21-99 automatically cleared after EXFMT ------------------
D dfIndClr 21 99
d dfIndClr 21 99
//--- Subfile indicators (prefix "sf") ---
D SC_NAME_PC 79 79n
D sfSflNxtChg 80 80n
D sfOPT_RI 81 81n
D sfOPT_PC 82 82n
D sfInAct 83 83n
d SC_NAME_PC 79 79n
d sfSflNxtChg 80 80n
d sfOPT_RI 81 81n
d sfOPT_PC 82 82n
d sfInAct 83 83n
//--- Subfile Control indicators (prefix "sc") ---
D*scNoDta 96 96n
D scSflEnd 97 97n
D scSflDsp 98 98n
D scSflClr 99 99n
d*scNoDta 96 96n
d scSflEnd 97 97n
d scSflDsp 98 98n
d scSflClr 99 99n
//=== Fields to control the subfile screen ====================
D SflRRN s 5 0
D RcdsInSfl s 5 0
D SflPageSize c 12
d SflRRN s 5 0
d RcdsInSfl s 5 0
d SflPageSize c 12
// SC_CSR_RCD is defined in the display file and is set with a
// RRN which determines which subfile page is displayed and on
// which record the cursor is positioned.
//=== Text for function keys ==================================
D F3Text c 'F3=Exit'
d F3Text c 'F3=Exit'
d F4Text c 'F4=Prompt+'
d F5Text c 'F5=Reset'
d F6Text c 'F6=Add'
@ -139,16 +134,16 @@
//=== Search Criteria Screen Fields ===========================
d SearchCriteria ds inz
D SC_NAME
D SC_CITY
D SC_STATE
d SC_NAME
d SC_CITY
d SC_STATE
//=== Last Search Criteria Fields =============================
d LastSearchCriteria...
d ds inz
D LastSC_NAME Like(SC_NAME)
D LastSC_CITY Like(SC_CITY)
D LastSC_STATE Like(SC_STATE)
d LastSC_NAME Like(SC_NAME)
d LastSC_CITY Like(SC_CITY)
d LastSC_STATE Like(SC_STATE)
//=== SQL Search Variables ====================================
d Stmt s 1024 varying Select Statement
@ -162,13 +157,13 @@
//== CUSTMAST - define fields for SQL =========================
// NOTE: Only the fields read by SQL are populated!
D CustMast e ds extname(CUSTMAST) template
d CustMast e ds extname(CUSTMAST) template
// Records from SQL cursor read into CustCursor
D CustCursor ds likeds(Custmast)
// Records from SQL CURSOR read into CustCursor
d CustCursor ds likeds(Custmast)
// Records from SQL select read into CustSelect
D CustSelect ds likeds(CustMast)
// Records from SQL SELECT read into CustSelect
d CustSelect ds likeds(CustMast)
//=== External Programs Prototypes ============================
@ -176,59 +171,52 @@
d CustID options(*nopass) like(CUSTID)
d Maintain 1a options(*nopass)
D PmtState PR EXTPGM('PMTSTATER')
D TheState like(STATE)
D
d PmtState PR EXTPGM('PMTSTATER')
d TheState like(STATE)
d
//=== Global Switches =========================================
D EofData s n
D CursorOpen s n
D NewSearchCriteria...
D s n
D SflMsgSnt s n
D Opt1_OK s n
D OptError s n
D Maint_OK s n
D CowsComeHome c const('0')
D MaxSflRecds c const(9999)
d EofData s n
d CursorOpen s n
d NewSearchCriteria...
d s n
d SflMsgSnt s n
d Opt1_OK s n
d OptError s n
d Maint_OK s n
d CowsComeHome c const('0')
d MaxSflRecds c const(9999)
//=== Work Fields =============================================
D inx s 10i 0
d inx s 10i 0
// Would prefer to defind these as like(SC_NAME)
// But SQL precompiler throws an error SQL0312, reason code 1
D wkName s 13a
D wkCity s 13a
d wkName s 13a
d wkCity s 13a
//=== Parm fields for MTNCUSTR ================================
D wkCustid s like(CUSTID)
D CustDspParm s 1a
D CustDspEdit c const('E')
D CustDspAdd c const('A')
D CustDspDsply c const('D')
D
d wkCustid s like(CUSTID)
d CustDspParm s 1a
d CustDspEdit c const('E')
d CustDspAdd c const('A')
d CustDspDsply c const('D')
d
//=== Program Status Data Structure ===========================
D ProgStatus sds
D PgmName *PROC
d ProgStatus sds
d PgmName *PROC
//=== Program Parameters ======================================
D pParmType S 1A
D pCustID s Like(CUSTID)
//PmtItemR pr
// I/O/B Type Lgth Description
// ----- ---- ---- ---------------------------------------
// O C 13 Item number of selected record is returned
// here. Blank if no selection made.
// Optional - need not be passed.
d pParmType S 1A
d pCustID s Like(CUSTID)
//=============================================================
// === Program Starts Here ====================================
//=============================================================
C *Entry plist
C parm pParmType
C parm pCustID
c *Entry plist
c parm pParmType
c parm pCustID
/FREE
//=== Set SQL Options =========================================
@ -389,7 +377,6 @@
//--- F6: Add a record. ----------------------------------
when Key = F06;
if Maint_Ok = *on;
pCustID = 0;
CustDspParm = CustDspAdd;
CustDsp(wkCustId : CustDspParm);
else;
@ -479,7 +466,7 @@
optError = *on;
// SFLNXTCHG forces this record to be read again
// even if user doesn't correct it, so we can
// (even if user doesn't correct it) so we can
// check it again for validity.
sfSflNxtChg = *on;
sfOPT_RI = *on;
@ -493,7 +480,7 @@
readc SFL;
enddo;
CustDsp(); // Close Window DSPF
CustDsp(); // Closes Window DSPF & restores our subfile
endif;
// If no positioning done, display last page, cursor on 1st recd.
@ -577,7 +564,6 @@
endif;
// Can't display more than 9,999 records.
// if SflRRN = 9999;
if SflRRN = MaxSflRecds;
EofData = *on;
SflMsgSnt= SndSflMsg('DEM0006');
@ -604,7 +590,7 @@
endif;
update SFL;
sfInAct = *off;
write DUMMY; // Helps restore SFL display
write DUMMY; // Supposed to help restore SFL display
endsr;
//=== ProcessSearchCriteria====================================
@ -796,10 +782,10 @@
// Concatenates a string to another string with a blank between.
// If the target string is all blank to start with it will not
// end up with a leading blank.
PCatB b
pCatB b
dCatB PI 79 varying
D ToStr 79 varying value
D AddStr 79 varying value
d ToStr 79 varying value
d AddStr 79 varying value
/FREE
if ToStr=' ';
return AddStr;
@ -807,7 +793,7 @@
return %trimr(ToStr) + ' ' + AddStr;
endif;
/END-FREE
PCatB e
pCatB e
//=== SQLProblem ==============================================
// For those "Never should happen" SQL errors.
@ -836,12 +822,12 @@
// *ON No more data, nothing returned
// *OFF Data returned
//------------------------------------------------------------
P FetchNextData B
D FetchNextData PI N
D TheRecd likeds(Custmast)
p FetchNextData B
d FetchNextData PI N
d TheRecd likeds(Custmast)
// Local fields
D wkEof S N
d wkEof S N
/FREE
wkEoF= *off;
exec sql fetch ItemCur into
@ -865,15 +851,15 @@
/END-FREE
P FetchNextData E
p FetchNextData E
//=== ReadByKey ===============================================
// Read the record by key into the specified data record
// using the key passed in.
P ReadByKey B
D ReadByKey PI
D TheKey like(CUSTID)
D TheRecd likeds(CustMast)
p ReadByKey B
d ReadByKey PI
d TheKey like(CUSTID)
d TheRecd likeds(CustMast)
/FREE
exec sql select
NAME,
@ -894,11 +880,11 @@
;
/END-FREE
P ReadByKey E
p ReadByKey E
//=== BuildSFLRecd ============================================
// Builds a SFL record from the specified data record
P BuildSflRecd b
p BuildSflRecd b
d BuildSflRecd PI
d CustRecd likeds(CUSTMAST)
/FREE
@ -917,13 +903,13 @@
// Save Active status in case we update subfile
SF_ACT_H = CustRecd.ACTIVE;
/END-FREE
P BuildSFLRecd E
p BuildSFLRecd E
//=== Procedure name: CloseCurssor ============================
// Closes the SQL Cursor if open
//------------------------------------------------------------
P CloseCursor B
D CloseCursor PI
p CloseCursor B
d CloseCursor PI
// Local fields
//CursorOpen s n static
/FREE
@ -936,7 +922,7 @@
endif;
RETURN;
/END-FREE
P CloseCursor E
p CloseCursor E
//=== SndSflMsg ===============================================
// Send a message to the Error Subfile
@ -946,19 +932,19 @@
// Parameter: ErrMsgFile => Optional Error Message File
// Defaults to CUSTMSGF
//------------------------------------------------------------
P SndSflMsg B
D SndSflMsg PI N
D ErrMsgId 7A CONST
D ErrMsgData 80A CONST
D OPTIONS(*NOPASS:*VARSIZE)
D ErrMsgFile 10A CONST
D OPTIONS(*NOPASS)
p SndSflMsg B
d SndSflMsg PI N
d ErrMsgId 7A CONST
d ErrMsgData 80A CONST
d OPTIONS(*NOPASS:*VARSIZE)
d ErrMsgFile 10A CONST
d OPTIONS(*NOPASS)
// Local fields
D retField S N
D wkMsgId s 7a
D wkMsgFile s 10a
D wkMsgData s 80a varying
d retField S N
d wkMsgId s 7a
d wkMsgFile s 10a
d wkMsgData s 80a varying
/FREE
if %parms >2;
@ -981,13 +967,13 @@
RETURN retField;
/END-FREE
P SndSflMsg E
p SndSflMsg E
//=== SflClear ================================================
// Clears the Subfile
//------------------------------------------------------------
P SflClear B
D SflClear PI
p SflClear B
d SflClear PI
/FREE
clear SflRRN;
clear RcdsInSfl;
@ -996,6 +982,6 @@
scSflClr = *OFF;
return;
/END-FREE
P SflClear E
p SflClear E

53
5250_Subfile/PMTSTATED
View File

@ -1,8 +1,9 @@
A*%%TS SD 20200724 153608 LENNONS REL-V7R4M0 5770-WDS
A*===============================================================
A* This is a full screen expanding subfile to search for and
A* select a Manufacturing QC Hold Disposition code
A* This is a "load all" subfile in a windown to select a
A* state code.
A*===============================================================
A* CRTDSPF FILE(PMTSTATED) SRCFILE(...) RSTDSP(*YES)
A*==============================================================
A* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_
A* -- Subfile: Fields begin with SF_
@ -23,34 +24,22 @@
A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS.
A*==============================================================
A* MM/DD/YYYY Proj# Developer
A* ---------- ----- -------------------------------------------
A* 04/14/2013 8651 Sam Lennon Original coding
A*
A*==============================================================
A*%%EC
A DSPSIZ(24 80 *DS3 -
A 27 132 *DS4)
A PRINT
A INDARA
A ALTHELP
A CA03
A CF05
A CA07
A CA12
A HELP
A*===============================================================
A*=== Screen Header: Fields begin with SH_ =====================
A*
A R SH_HDR
A*%%TS SD 20111207 212036 SLENNON REL-V7R1M0 5770-WDS
A OVERLAY
A TEXT('Screen Header')
A WINDOW(*DFT 17 40)
A WDWBORDER((*DSPATR RI))
A WINDOW(*DFT 16 40)
A WDWBORDER((*DSPATR RI) (*CHAR +
A ' '))
A WDWBORDER((*COLOR BLU))
A* CA03
A* CA12
A SH_PGM 10A O 1 1
A 1 16'USA States'
A COLOR(WHT)
@ -63,7 +52,6 @@
A*=== Subfile: Fields begin with SF_ ===========================
A*
A R SFL SFL
A*%%TS SD 20200723 210409 LENNONS REL-V7R4M0 5770-WDS
A TEXT('SubFile')
A 80 SFLNXTCHG
A SF_OPT 1A B 6 2
@ -77,15 +65,17 @@
A*=== Subfile Control: Fields begin with SC_ ====================
A*
A R SFLCTL SFLCTL(SFL)
A*%%TS SD 20200723 210409 LENNONS REL-V7R4M0 5770-WDS
A *DS3 SFLSIZ(0008)
A *DS4 SFLSIZ(0008)
A *DS3 SFLPAG(0007)
A *DS4 SFLPAG(0007)
A CF03
A CF05
A CF07
A CF12
A *DS3 SFLSIZ(9999)
A *DS4 SFLSIZ(9999)
A *DS3 SFLPAG(0006)
A *DS4 SFLPAG(0006)
A *DS3 WINDOW(SH_HDR)
A *DS4 WINDOW(SH_HDR)
A TEXT('Subfile Control')
A PAGEDOWN
A RTNCSRLOC(&SC_PMT_RCD &SC_PMT_FLD)
A BLINK
A OVERLAY
@ -104,13 +94,11 @@
A DSPATR(HI)
A DSPATR(UL)
A 5 5'Code'
A N01 COLOR(WHT)
A 01 COLOR(PNK)
A DSPATR(UL)
A 5 11'Name '
A DSPATR(UL)
A 01 COLOR(WHT)
A N01 COLOR(PNK)
A 02 COLOR(PNK)
A SC_PMT_RCD 10A H
A SC_PMT_FLD 10A H
A SC_CSR_RCD 4S 0H SFLRCDNBR(CURSOR)
@ -118,29 +106,26 @@
A*=== Screen footer & function keys: Fields begin with SFT_ ====
A*
A R SFT_FKEY
A*%%TS SD 20200724 143229 LENNONS REL-V7R4M0 5770-WDS
A *DS3 WINDOW(SH_HDR)
A *DS4 WINDOW(SH_HDR)
A TEXT('Screen Footer')
A OVERLAY
A 14 1' Demo Corp of America -
A 13 1' Demo Corp of America -
A '
A DSPATR(UL)
A SFT_KEYS 40 O 15 1
A SFT_KEYS 40 O 14 1
A*===============================================================
A*=== Message Subfile: No fields ===============================
A*
A R MSGSFL SFL
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile')
A SFLMSGRCD(16)
A SFLMSGRCD(15)
A MSGKEY SFLMSGKEY
A MSGPGMQF SFLPGMQ(10)
A*===============================================================
A*=== Message Subfile Control: No fields ========================
A*
A R MSGCTL SFLCTL(MSGSFL)
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile Control')
A WINDOW(SH_HDR)
A PAGEDOWN

315
5250_Subfile/PMTSTATER
View File

@ -1,4 +1,11 @@
/TITLE PMTSTATE Search and return a USA State Code
//==============================================================*
// This is a "load all" subfile, where the system takes care or
// paging up and down. All selected data is loaded into the
// subfile. STATES table has only 58 rows, so selecting all
// is approptiate.
// For larger numbers of rows, a "page at at time" approach
// may make more sense.
//==============================================================*
// Displays USA state names and their 2-char codes in a window.
// Can sort the display by name or code.
@ -22,7 +29,7 @@
// carried across subroutines.
// - UPPERCASE is used for external names, i.e., files, fields, formats
// and anything else not directly coded in the program.
//
// - In the display file, this field naming convention is used:
// Screen Header: Fields begin with SH_
// Subfile: Fields begin with SF_
@ -35,18 +42,18 @@
// not the default of QRPGLESRC. Change as needed.
//=============================================================
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND')
H main(Main)
h DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
h BndDir('UTIL_BND')
h main(Main)
//=== Display File ==============================================
FPMTSTATED CF E WorkStn INFDS(dfInfDS)
F INDDS(dfIndDS)
F SFILE(SFL:SflRRN)
F USROPN
fPMTSTATED CF E WorkStn INFDS(dfInfDS)
f INDDS(dfIndDS)
f SFILE(SFL:SflRRN)
f USROPN
D Main pr extpgm('PMTSTATER')
D 2A
d Main pr extpgm('PMTSTATER')
d ReturnState 2A
//=== Service Program Prototypes ================================
/include DEMO,Srv_Msg_P
@ -57,8 +64,8 @@
//=== Fields read by SQL ========================================
// NOTE: Only the fields in fetchData which are fetched by the
// SQL Cursor are populated.
D STATES e ds extname(STATES)
D qualified template
d STATES e ds extname(STATES)
d qualified template
d FetchData ds likeds(STATES)
//=== SQL State Constants =======================================
@ -70,56 +77,58 @@
//=== Display File Information Data Structure ===================
// Allows us to determine which function key was pressed
D dfInfDS DS
D Key 369 369
d dfInfDS DS
d Key 369 369
//=== Display File Indicator Data Structure =====================
// This is a "private" indicator area for the display file.
D dfIndDS ds 99
d dfIndDS ds 99
//--- 01-20 are not automatically cleared after EXFMT ----------
D scSortColor 01 01
d scCodeHi 01 01
d scNameHi 02 02
//--- 21-99 automatically cleared after EXFMT ------------------
D dfIndClr 21 99
d dfIndClr 21 99
//--- Subfile indicators (prefix "sf") -------------------------
D sfSflNxtChg 80 80n
D sfOPT_RI 81 81n
D sfOPT_PC 82 82n
d sfSflNxtChg 80 80n
d sfOPT_RI 81 81n
d sfOPT_PC 82 82n
//--- Subfile Control indicators (prefix "sc") ----------------
D scMDT 95 95n
D scNoDta 96 96n
D scSflEnd 97 97n
D scSflDsp 98 98n
D scSflClr 99 99n
d scMDT 95 95n
d scNoDta 96 96n
d scSflEnd 97 97n
d scSflDsp 98 98n
d scSflClr 99 99n
//=== Fields to control the subfile screen ======================
D SflRRN s 5 0
D RcdsInSfl s 5 0
D SflPageSize c 7
d SflRRN s 5i 0
d RcdsInSfl s 5i 0
d SflPageSize c 6
d SflMaxRecd s 5i 0 inz(9999)
// SC_CSR_RCD is defined in the display file and is set with a
// RRN which determines which subfile page is displayed and on
// which record the cursor is positioned.
//=== Program Status Data Structure =============================
D ProgStatus sds
D PgmName *PROC
d ProgStatus sds
d PgmName *PROC
D MainProc S 10a
d MainProc S 10a
//=== Text for function keys ====================================
D F3Text c 'F3=Exit'
d F3Text c 'F3=Exit'
d F5Text c 'F5=Refresh'
d F12Text c 'F12=Cancel'
D F7Text1 c 'F7=By '
D F7Text2 s 5a inz(' ')
D F7Text S 11a inz(' ')
d F7Text1 c 'F7=By '
d F7Text2 s 5a inz(' ')
d F7Text S 11a inz(' ')
//SortSeq is used in SQL Order By
D SortSeq s 4a inz(' ')
D SortbyName s 4a inz('Name')
D SortbyCode s 4a inz('Code')
//SortSeq is used in SQL Order By in a CASE construct.
d SQLSortSeq s 4a inz(' ')
d SortbyName s 4a inz('Name')
d SortbyCode s 4a inz('Code')
//=== Options Text ==============================================
@ -127,35 +136,28 @@
//=== Search Criteria Screen Fields =============================
d SearchCriteria ds inz
D SC_NAME
d SC_NAME
//=== Last Search Criteria Fields ===============================
d LastSearchCriteria...
d ds inz
D LastSC_NAME Like(SC_NAME)
d LastSC_NAME Like(SC_NAME)
//=== SQL Search Variables ======================================
D DESCLike S 12 varying
d DESCLike S 12 varying
//=== Global Switches ===========================================
D EofData s n
D CursorOpen s n
D NewSearchCriteria...
D s n
D SflMsgSnt s n
d EofData s n
d CursorOpen s n
d NewSearchCriteria...
d s n
d SflMsgSnt s n
d Opt1OK s n
D OptError s n
D CowsComeHome c const('0')
d OptError s n
d CowsComeHome c const('0')
//=== Work Fields ===============================================
D inx s 10i 0
//=== Translation ===============================================
D Lower c const('abcdefghijklmnopqrstuvwxyz')
D Upper c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
D HighVals s 30 inz(*hival)
d inx s 10i 0
//=============================================================
//== Program Starts Here ======================================
@ -164,7 +166,6 @@
d Main pi
d pState Like(FetchData.STATE)
/FREE
exsr Init;
exsr BldFkeyText;
@ -173,7 +174,7 @@
exec sql set option datfmt=*iso,
closqlcsr=*endmod;
//=== SQL Cursor Definitions ==================================
// Sort Order is controlled by field SortSeq which is
// Sort Order is controlled by field SQLSortSeq which is
// used in a CASE statement.
exec SQL
declare DataCur cursor for
@ -182,18 +183,18 @@
NAME
from STATES
where upper(NAME) like :DescLike
order by case :SortSeq
order by case :SQLSortSeq
when :SortByName then NAME
when :SortByCode then STATE
else '1'
end
optimize for 7 rows
for fetch only;
// === Initial screen display =================================
write SH_HDR;
SflClear();
exsr SflFirstPage;
exsr ProcessSearchCriteria;
exsr SflLoadAll;
//=============================================================
// === Main Program Loop ======================================
@ -206,7 +207,8 @@
// If switching display order, reload first page
if Key = F07;
exsr SflFirstPage;
exsr ProcessSearchCriteria;
exsr SflLoadAll;
endif;
// Write/Read the screen
@ -219,21 +221,12 @@
if SearchCriteria <> LastSearchCriteria
or NewSearchCriteria = *on;
SflClear();
exsr SflFirstPage;
exsr ProcessSearchCriteria;
exsr SflLoadAll;
else;
exsr ProcessOption;
endif;
iter;
endif;
//--- Page Down -------------------------------------------
if Key = PageDown;
if RcdsInSfl > 0;
exsr SflFillPage;
else;
// Key not active msg
SflMsgSnt= SndSflMsg('DEM0003');
endif;
iter;
endif;
@ -292,8 +285,8 @@
//--- F3: Exit, close down program -----------------------
when Key = F03;
*inlr = *on;
exsr CloseDownPgm;
*inlr = *on;
return;
//--- F12: Return to caller, leave program active ---------
@ -309,15 +302,17 @@
//--- F7: Toggle Sort Sequence ---------------------------
when Key = F07;
if SortSeq=SortByName;
SortSeq = SortByCode;
SC_SORTED = SortbyName;
ScSortColor=*on;
if SQLSortSeq=SortByName;
SQLSortSeq = SortByCode;
SC_SORTED = SortByCode;
scCodeHi = *on;
scNameHi = *off;
F7Text2 = SortByName;
else;
SortSeq = SortByName;
SC_SORTED = SortbyCode;
scSortColor = *off;
SQLSortSeq = SortByName;
SC_SORTED = SortByName;
scNameHi = *on;
scCodeHI = *off;
F7Text2 = SortbyCode;
endif;
F7Text = F7Text1 + F7Text2;
@ -353,9 +348,9 @@
// Return Code to caller
pSTATE = SF_CODE;
exsr CloseDownPgm;
*inlr = *on;
return;
//--- Opt is blank ----------------------------------------
when SF_OPT = ' ';
// If changed, assume clearing an error from last time
@ -372,7 +367,7 @@
// Not a valid option at this time
SflMsgSnt= SndSflMsg('DEM0004':SF_OPT);
// Leave cursor at first invalid option
exsr SetCursorPosition;
exsr SetScreenCursorPosition;
optError = *on;
// SFLNXTCHG forces this record to be read again
@ -404,92 +399,44 @@
endsr;
//=== SflFirstPage ============================================
// Processes the Search fields in the Sub file control, then
// fills the first page of the subfile.
// If any errors in the search fields then no records are
// are added to the subfile.
//=== SflLoadAll ==============================================
// Loads all selected records to the subfile.
// Returns:
// EofData = *on if there are no more data records
// *off if there is at least one more data
// record.
// NewSearchCriteria = *on Next time evaluate the
// search fields again.
// RcdsInSfl contains relative record number of last record
// written to the subfile.
begsr SflFirstPage;
exsr ProcessSearchCriteria;
if NewSearchCriteria = *off;
EofData = FetchNextData();
if EofData = *off;
exsr SflFillPage;
else;
// No records match selection criteria
SflMsgSnt= SndSflMsg('DEM0002');
NewSearchCriteria = *on;
endif;
endif;
endsr;
//=== SflFillPage =============================================
// Adds a page worth of records to the subfile.
// Assumes:
// One record is already read from the SQL cursor.
// Returns:
// EofData = *on if no more data records.
// *off if at least one data record is read
// and has not been displayed.
// EofData = *on (there are no more data records.)
// RcdsInSfl contains relative record number of last record
// written to the subfile.
// SC_CSR_RCD contains relative record number of 1st record
// on the page & positions cursor there.
begsr SflFillPage;
select;
begsr SflLoadAll;
when EofData = *on;
// do nothing
other;
// Add a subfile page. If not EOF, then one extra recd is
// read for the next time.
// Position cursor at first record on the subfile page.
SC_CSR_RCD = 0;
for inx = 1 to SflPageSize;
SC_CSR_RCD = 1;
for inx = 1 to SflMaxRecd;
EofData = FetchNextData();
if EofData = *on;
leave;
endIf;
// Build/Format the subfile record
clear SF_OPT;
SF_CODE = FetchData.STATE;
SF_NAME = FetchData.NAME;
SflRRN = inx;
RcdsinSfl = RcdsInSfl + 1;
SflRRN = RcdsInSfl;
write SFL;
// Leave curson on first SFL record
if SC_CSR_RCD = 0;
SC_CSR_RCD = SflRRN;
endif;
// Can't display more than 9,9999 records.
if SflRRN = 9999;
if SflRRN = SflMaxRecd;
EofData = *on;
SflMsgSnt= SndSflMsg('DEM0006');
leave;
endif;
EofData = FetchNextData();
if EofData = *on;
leave;
endIf;
endfor;
endsl;
endsr;
//=== ProcessSearchCriteria====================================
@ -510,7 +457,6 @@
NewSearchCriteria = *off;
// Save entered values. (Never change screen fields.)
LastSearchCriteria = SearchCriteria;
//exsr SaveSearchCriteria;
CloseCursor();
//---------------------------------------------------------------
@ -522,7 +468,7 @@
endif;
//---------------------------------------------------------------
// If no errors, open the SQL cursor
// If no errors in search criteria, open the SQL cursor
if NewSearchCriteria = *off;
exec sql open DataCur;
if SQLSTT <> SQLSuccess;
@ -536,7 +482,7 @@
//=== SetCursorPostion ========================================
// If Invalid Option, position screen cursor on first one,
// else postion cursor on the last valid option.
begsr SetCursorPosition;
begsr SetScreenCursorPosition;
if OptError = *off;
SC_CSR_RCD=SflRRN;
endif;
@ -556,15 +502,18 @@
// Things to do before we issue a return to the caller
begsr CloseDownPgm;
CloseCursor();
if %open(PMTSTATED);
close PMTSTATED;
endif;
endsr;
//=== Init ====================================================
// Must be executed each time program is entered, because F12
// and Enter key leave with LR off.
// Must be executed each time program is entered
begsr Init;
SortSeq = SortByCode;
SC_SORTED = SortbyName;
scSortColor = *off;
SQLSortSeq = SortByName;
SC_SORTED = SortByName;
scNameHi = *on; // Name highlighted
scCodeHi = *off;
F7Text2 = SortByCode;
F7Text = F7Text1 + F7Text2;
@ -578,9 +527,11 @@
MSGPGMQF = MainProc;
MSGPGMQC = MSGPGMQF;
SH_PGM = PgmName;
if not %open(PMTSTATED);
open PMTSTATED;
endif;
// Clear fields left over from previous F12.
reset LastSearchCriteria;
reset SearchCriteria;
@ -602,10 +553,10 @@
// If the target string is all blank to start with it will not
// end up with a leading blank.
/END-FREE
PCatB b
pCatB b
dCatB PI 79 varying
D ToStr 79 varying value
D AddStr 79 varying value
d ToStr 79 varying value
d AddStr 79 varying value
/FREE
if ToStr=' ';
return AddStr;
@ -613,7 +564,8 @@
return %trimr(ToStr) + ' ' + AddStr;
endif;
/END-FREE
PCatB e
pCatB e
// === SQLProblem ================================================
// For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by
@ -635,7 +587,6 @@
/end-free
p SQLProblem E
//--------------------------------------------------
// Procedure name: FetchNextData
// Purpose: Fetch the next row from the cursor
@ -643,11 +594,11 @@
// *ON No more data, nothing returned
// *OFF Data returned
//--------------------------------------------------
P FetchNextData B
D FetchNextData PI N
p FetchNextData B
d FetchNextData PI N
// Local fields
D wkEof S N
d wkEof S N
/FREE
wkEoF= *off;
exec sql fetch DataCur into
@ -666,7 +617,7 @@
RETURN wkEof;
/END-FREE
P FetchNextData E
p FetchNextData E
//--------------------------------------------------
// Procedure name: SndSflMsg
@ -677,19 +628,19 @@
// Parameter: ErrMsgFile => Optional Error Message File
// Defaults to CUSTMSGF
//--------------------------------------------------
P SndSflMsg B
D SndSflMsg PI N
D ErrMsgId 7A CONST
D ErrMsgData 80A CONST
D OPTIONS(*NOPASS:*VARSIZE)
D ErrMsgFile 10A CONST
D OPTIONS(*NOPASS)
p SndSflMsg B
d SndSflMsg PI N
d ErrMsgId 7A CONST
d ErrMsgData 80A CONST
d OPTIONS(*NOPASS:*VARSIZE)
d ErrMsgFile 10A CONST
d OPTIONS(*NOPASS)
// Local fields
D retField S N
D wkMsgId s 7a
D wkMsgFile s 10a
D wkMsgData s 80a varying
d retField S N
d wkMsgId s 7a
d wkMsgFile s 10a
d wkMsgData s 80a varying
/FREE
if %parms >2;
@ -712,14 +663,14 @@
RETURN retField;
/END-FREE
P SndSflMsg E
p SndSflMsg E
//--------------------------------------------------
// Procedure name: CloseCurssor
// Purpose: Closes the SQL Cursor
//--------------------------------------------------
P CloseCursor B
D CloseCursor PI
p CloseCursor B
d CloseCursor PI
/FREE
if CursorOpen = *on;
exec sql close DataCur;
@ -730,16 +681,15 @@
endif;
RETURN;
/END-FREE
P CloseCursor E
p CloseCursor E
//--------------------------------------------------
// Procedure name: SflClear
// Purpose: Clears the Subfile
// Returns:
//--------------------------------------------------
P SflClear B
D SflClear PI
p SflClear B
d SflClear PI
/FREE
clear SflRRN;
clear RcdsInSfl;
@ -748,7 +698,4 @@
scSflClr = *OFF;
return;
/END-FREE
P SflClear E
p SflClear E

10
5250_Subfile/README.md
View File

@ -2,7 +2,7 @@
(__Under Construction__)
This is a working application that allows display, selection and maintenance of a customer master. The screens are _similar_ to what you see in PDM. The code is modular and there are several programs that can be called from multiple places. SQL is used for all database IO. There are full screen subfiles and subfiles in a window.
This is a working application that allows display, selection and maintenance of a customer master. The screens are _similar_ to what you see in PDM. The code is modular and there are several programs that can be called from multiple places. SQL is used for all database IO. There are "page at a time" subfiles (full screen and in a window) and a "load all" subfile in a window. The windows show a couple of border styles.
### Sample Inquiry Screens
@ -21,9 +21,9 @@ This is a working application that allows display, selection and maintenance of
Some of the programs use /Include statements, which are found in the Copy_Mbrs directory. In the code these programs refer to my DEMO library, so to compile you may need to change this.
The RPG code is free form, except that the D-Specs are fixed form. This probably allows more people developers who are still on older versions of the OS, or are still using the out of date SEU, to more easily use the code. The code can be converted to totally free form using the free "JCRHFD - Rpg H,F,D to free form syntax" command available at [JCRCMDS.COM](http://www.jcrcmds.com/jcrdown2.html#JCRHFD_tag). If there is interest I may post totally free form versions.
The RPG code is free form, except that the D-Specs are fixed form. This probably allows more developers who are still on older versions of the OS, or are still using the out of date SEU, to more easily use the code. The code can be converted to totally free form using the free _*"JCRHFD - Rpg H,F,D to free form syntax"*_ command available at [JCRCMDS.COM](http://www.jcrcmds.com/jcrdown2.html#JCRHFD_tag). If there is interest I may post totally free form versions.
The genesis of these programs was code that I wrote in RPG IV for a Fortune 500 retailer circa 2000. The code was then cloned as a standard approach by another team leader. This code is a more modern version that I cleaned up in 2020.
The genesis of these programs was code that I wrote in RPG IV for a Fortune 500 retailer circa 2002-2004. The code was then cloned as a standard approach by another team leader. This code is a more modern version that I cleaned up in 2020.
The style tries to have consistent naming and I do not share field names between the RPG and the display files--I've seen too many accidental modifications in my support career.
@ -48,12 +48,16 @@ The display file uses a private set of indicators, something I started doing to
If the cursor is in a field with a + in the field name (ST+ here) you can press F4 to prompt the field.
The window has the default border, which may vary depending on which 5250 emulator you are using. The sample is using the iACS emulator from IBM.
### PMTSTATER/PMTSTATED
RPG program and window display file to prompt for a USA state code. Called when F4 is used in PMTCUSTR or MTNCUSTR. Disply can be by either state name or 2-character code, toggled by F7.
Strictly speaking, this is more of a demonstration program that may, or may not, have a lot of practical value in real life.
The window has a blue border or reverse image blanks. This will display consistently across most 5250 emulators.
#### CRTMSGF
Creates the CUSTMSGF message file used by the programs.

2
README.md
View File

@ -21,4 +21,4 @@ Batch program with SQL embedded in RPGLE. Includes error checking and handling.
## 5250 Subfile
Fully functional 5250 "green screen" Customer Master maintenance and prompting application, with full screen and window displays, modular code, service programs, message files and a sample database.
Many shops are still using 5250 "green screen" applications and these need to be maintained and/or extended. This is a fully functional modernized 5250 "green screen" Customer Master maintenance and prompting application, with full screen and window displays, modular code, service programs, message files and a sample database.