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
Download Patch File Download Diff File Expand all files Collapse all files
5250_Subfile/Images/Inquiry_Display.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 31 KiB

After

Width:  |  Height:  |  Size: 30 KiB

5250_Subfile/Images/Maintenance_Display.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 32 KiB

After

Width:  |  Height:  |  Size: 32 KiB

5250_Subfile/Images/State_Prompt.png
BIN
View File
Binary file not shown.
Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 30 KiB

After

Width:  |  Height:  |  Size: 33 KiB

5250_Subfile/LOADCUST
+18
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
5250_Subfile/MTNCUSTD
+12 -14
View File
@@ -1,8 +1,8 @@
A*%%TS SD 20120202 211644 SLENNON REL-V7R1M0 5770-WDS
A*=============================================================== A*===============================================================
A* Window to display or update Customer Master A* Window to display or update Customer Master
A*=============================================================== 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* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_ A* -- Screen Header: Fields begin with SH_
A* -- Details Fields begin with SD_ A* -- Details Fields begin with SD_
@@ -19,22 +19,17 @@
A* 91-99 Subfile Control Record A* 91-99 Subfile Control Record
A* Note: INDARA is specified here and in the program and this 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* means that the display file indicators are in a
A* data structure separate from the program indicators. A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS. 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* Note: DSPATR HI and RI at the same time = non-display. Thus
a* when we turn on RI were turn of HI, a* when we turn on RI were turn of HI,
A*=============================================================== A*===============================================================
A* MM/DD/YYYY Proj# Developer
A* ---------- ----- -------------------------------------------
A* 10/21/2012 8399 Sam Lennon Original coding
A*
A*==============================================================
A*%%EC A*%%EC
A DSPSIZ(24 80 *DS3) A DSPSIZ(24 80 *DS3)
A PRINT A PRINT
A INDARA A INDARA
A ALTHELP A ALTHELP
A CA03
A CF04 A CF04
A CA05 A CA05
A CA12 A CA12
@@ -43,13 +38,10 @@
A*=== Screen Header: Fields begin with SH_ ===================== A*=== Screen Header: Fields begin with SH_ =====================
A* A*
A R SH_HDR A R SH_HDR
A*%%TS SD 20111207 212036 SLENNON REL-V7R1M0 5770-WDS
A OVERLAY A OVERLAY
A TEXT('Screen Header') A TEXT('Screen Header')
A WDWBORDER((*COLOR PNK)) A WDWBORDER((*COLOR PNK))
A WINDOW(*DFT 17 54) A WINDOW(*DFT 17 54)
A* CA03
A* CA12
A SH_PGM 10A O 1 1 A SH_PGM 10A O 1 1
A 1 21'Customer Master' A 1 21'Customer Master'
A 1 47DATE A 1 47DATE
@@ -132,16 +124,19 @@
A 10 DSPATR(PR) A 10 DSPATR(PR)
A N10 DSPATR(UL) A N10 DSPATR(UL)
A 13 1'Last Change' A 13 1'Last Change'
A N61 DSPATR(ND)
A SD_CHGTIME 23 13 13 A SD_CHGTIME 23 13 13
A N61 DSPATR(ND)
A 13 37'by' A 13 37'by'
A N61 DSPATR(ND)
A SD_CHGUSER 15 13 40 A SD_CHGUSER 15 13 40
A N61 DSPATR(ND)
A SD_PMT_RCD 10A H A SD_PMT_RCD 10A H
A SD_PMT_FLD 10A H A SD_PMT_FLD 10A H
A*=============================================================== A*===============================================================
A*=== Screen footer & function keys: Fields begin with SFT_ ==== A*=== Screen footer & function keys: Fields begin with SFT_ ====
A* A*
A R SFT_FKEY A R SFT_FKEY
A*%%TS SD 20111208 204102 SLENNON REL-V7R1M0 5770-WDS
A TEXT('Screen Footer') A TEXT('Screen Footer')
A OVERLAY A OVERLAY
A WINDOW(SH_HDR) A WINDOW(SH_HDR)
@@ -153,7 +148,6 @@
A*=== Message Subfile: No fields =============================== A*=== Message Subfile: No fields ===============================
A* A*
A R MSGSFL SFL A R MSGSFL SFL
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile') A TEXT('Message Subfile')
A SFLMSGRCD(16) A SFLMSGRCD(16)
A MSGKEY SFLMSGKEY A MSGKEY SFLMSGKEY
@@ -162,7 +156,6 @@
A*=== Message Subfile Control: No fields ======================== A*=== Message Subfile Control: No fields ========================
A* A*
A R MSGCTL SFLCTL(MSGSFL) A R MSGCTL SFLCTL(MSGSFL)
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile Control') A TEXT('Message Subfile Control')
A WINDOW(SH_HDR) A WINDOW(SH_HDR)
A PAGEDOWN A PAGEDOWN
@@ -193,3 +186,8 @@
A*%%RS+ <record-write record-format="DUMMY" /> A*%%RS+ <record-write record-format="DUMMY" />
A*%%RS+ </sequence> A*%%RS+ </sequence>
A*%%RS </record-sequences> 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>
5250_Subfile/MTNCUSTR
+174 -174
View File
@@ -7,16 +7,11 @@
// ---------- // ----------
// 1 In Z4 Customer Id to, or 0 to add a new code // 1 In Z4 Customer Id to, or 0 to add a new code
// 2 In CL1 Function // 2 In CL1 Function
// C - Close Display file
// E - Edit passed record // E - Edit passed record
// D - Display passed record
// A - Add a new 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 // Program is essentially without indicators. (Indicators are
// stil lneeded to control the display file, but all have names.) // stil lneeded to control the display file, but all have names.)
@@ -31,7 +26,7 @@
// carried across subroutines. // carried across subroutines.
// - UPPERCASE is used for external names, i.e., files, fields, formats // - UPPERCASE is used for external names, i.e., files, fields, formats
// and anything else not directly coded in the program. // and anything else not directly coded in the program.
//
// - In the display file, this screen field naming convention is used: // - In the display file, this screen field naming convention is used:
// Screen Header: Fields begin with SH_ // Screen Header: Fields begin with SH_
// Detail Fields begin with SD_ // Detail Fields begin with SD_
@@ -43,26 +38,30 @@
// not the default of QRPGLESRC. Change as needed. // not the default of QRPGLESRC. Change as needed.
//============================================================= //=============================================================
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt) h DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND') h BndDir('UTIL_BND')
h main(Main)
//=== Display File ============================================= //=== Display File =============================================
FMTNCUSTD CF E WorkStn INFDS(dfInfDS) fmTNCUSTD CF E WorkStn INFDS(dfInfDS)
F INDDS(dfIndDS) f INDDS(dfIndDS)
F USROPN f USROPN
d Main pr extpgm('MTNCUSTR')
d pID like(CUSTID)
d pMaintain 1a
//=== Service Program Prototypes =============================== //=== Service Program Prototypes ===============================
/include DEMO,Srv_Msg_P /include DEMO,Srv_Msg_P
/include DEMO,Srv_Str_P
//=== Named hexadecimal constants for function keys ============ //=== Named hexadecimal constants for function keys ============
/include DEMO,##AIDBYTES /include DEMO,##AIDBYTES
//=== Fields read by SQL ======================================== //=== Fields read by SQL ========================================
// NOTE: Only the fields in the SQL statement are populated! // NOTE: Only the fields in the SQL statement are populated!
D CUSTMAST e ds extname(CUSTMAST) d CUSTMAST e ds extname(CUSTMAST)
// qualified template
// FetchData ds likeds(STATES)
D
//=== SQL State Constants ====================================== //=== SQL State Constants ======================================
d SQLSuccess c '00000' d SQLSuccess c '00000'
d SQLNoData c '02000' d SQLNoData c '02000'
@@ -70,113 +69,95 @@
d SQLDupRecd c '23505' d SQLDupRecd c '23505'
d SQLRowLocked c '57033' d SQLRowLocked c '57033'
//=== Display File Information Data Structure ================== //=== Display File Information Data Structure ==================
// Allows us to determine which function key was pressed // Allows us to determine which function key was pressed
D dfInfDS DS d dfInfDS DS
D Key 369 369 d Key 369 369
//=== Display File Indicator Data Structure ==================== //=== Display File Indicator Data Structure ====================
// This is a "private" indicator area for the display file. // 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 ---------- //--- 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 -------------- //--- 21-99 are automatically cleared after EXFMT --------------
D dfIndClr 21 99 ???? d dfIndClr 21 99
D RI_SD_ACTIVE 40 40n d RI_SD_ACTIVE 40 40n
D PC_SD_ACTIVE 41 41n d PC_SD_ACTIVE 41 41n
D RI_SD_NAME 42 42n d RI_SD_NAME 42 42n
D PC_SD_NAME 43 43n d PC_SD_NAME 43 43n
D RI_SD_ADDR 44 44n d RI_SD_ADDR 44 44n
D PC_SD_ADDR 45 45n d PC_SD_ADDR 45 45n
D RI_SD_CITY 46 46n d RI_SD_CITY 46 46n
D PC_SD_CITY 47 47n d PC_SD_CITY 47 47n
D RI_SD_STATE 48 48n d RI_SD_STATE 48 48n
D PC_SD_STATE 49 49n d PC_SD_STATE 49 49n
D RI_SD_ZIP 50 50n d RI_SD_ZIP 50 50n
D PC_SD_ZIP 51 51n d PC_SD_ZIP 51 51n
D RI_SD_ACCTPH 52 52n d RI_SD_ACCTPH 52 52n
D PC_SD_ACCTPH 53 53n d PC_SD_ACCTPH 53 53n
D RI_SD_ACCTMGR 54 54n d RI_SD_ACCTMGR 54 54n
D PC_SD_ACCTMGR 55 55n d PC_SD_ACCTMGR 55 55n
D RI_SD_CORPPH 56 56n d RI_SD_CORPPH 56 56n
D PC_SD_CORPPH 57 57n d PC_SD_CORPPH 57 57n
d DSP_SD_STAMP 61 61n
//*=== 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.
//=== Screen Header Text ======================================= //=== Screen Header Text =======================================
D H2TextD s like(SH_FUNCT) d H2TextE s like(SH_FUNCT)
D inz('Display') d inz('Change Customer')
D H2TextU s like(SH_FUNCT) d H2TextA s like(SH_FUNCT)
D inz('Add/Change') d inz('Add Customer')
d H2TextD s like(SH_FUNCT)
d inz('Displaying Customer')
//=== Text for function keys =================================== //=== Text for function keys ===================================
D F3Text c 'F3=Exit' d F3Text c 'F3=Exit'
//F4Text c 'F4=Prompt*' d F4Text c 'F4=Prompt+'
d F5Text c 'F5=Refresh' d F5Text c 'F5=Refresh'
d F12Text c 'F12=Cancel' d F12Text c 'F12=Cancel'
//=== External Programs Prototypes ============================= //=== External Programs Prototypes =============================
D PmtState PR EXTPGM('PMTSTATER') d PmtState PR EXTPGM('PMTSTATER')
D TheState like(STATE) d TheState like(STATE)
d d
//=== Global Switches ========================================== //=== Global Switches ==========================================
D SflMsgSnt s n d SflMsgSnt s n
D CowsComeHome c const('0') d CowsComeHome c const('0')
D Function s 1a d Function s 1a
D Displaying c const('D') d Displaying c const('D')
D Editing c const('E') d Editing c const('E')
D Adding c const('A') d Adding c const('A')
D Closing c const('C') d NoErrors s n
D NoErrors s n
// === Global Fields =========================================== // === Global Fields ===========================================
D Orig_CHGTIME s z d Orig_CHGTIME s z
//=== Work Fields ============================================== //=== Work Fields ==============================================
D wkInt s 10i 0 d wkInt s 10i 0
D wkMsgText s 256a varying d wkMsgText s 256a varying
//=== Translation ==============================================
D Lower c const('abcdefghijklmnopqrstuvwxyz')
D Upper c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
D HighVals s 30 inz(*hival)
// === Next available customer number ========================== // === Next available customer number ==========================
// CUSTNEXT ds dtaara(CUSTNEXT) // CUSTNEXT ds dtaara(CUSTNEXT)
d Cust_Next s 4p 0 dtaara(CUSTNEXT) d Cust_Next s 4p 0 dtaara(CUSTNEXT)
//=== Program Status Data Structure ============================ //=== Program Status Data Structure ============================
D ProgStatus sds d ProgStatus sds
D PgmName *PROC d PgmName *PROC
D CURR_USER 358 367 * Current user d CURR_USER 358 367 * Current user
D USER 254 263 * User name
//=== Program Parameters ======================================= d MainProc S 10a
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.
//==============================================================
//============================================================== //==============================================================
// === Program Starts Here ===================================== // === Program Starts Here =====================================
//============================================================== //==============================================================
C *Entry plist
C parm pId p Main b
C parm pMaintain d Main pi
d pID like(CUSTID)
d pMaintain 1a
/FREE /FREE
//=== Set SQL Options =============================== //=== Set SQL Options ===============================
@@ -228,7 +209,7 @@
exsr ScreenIO; exsr ScreenIO;
select; select;
when Key = F03 or Key = F12; when Key = F12;
exsr CloseDownPgm; exsr CloseDownPgm;
return; return;
@@ -242,21 +223,7 @@
NoErrors = *off; NoErrors = *off;
when Key = F04; when Key = F04;
// CF04 reads the screen data. We then prompt and replace exsr F04Prompt;
// 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;
when Key = Enter; when Key = Enter;
exsr EditUpdData; exsr EditUpdData;
@@ -267,7 +234,7 @@
SflMsgSnt = SndSflMsg('DEM0000'); // Enter to update ... SflMsgSnt = SndSflMsg('DEM0000'); // Enter to update ...
exsr ScreenIO; exsr ScreenIO;
select; select;
when Key = F12 or Key = F03 or Key = F05; when Key = F12 or Key = F05;
// Loop again // Loop again
when Key = Enter; when Key = Enter;
exsr UpdateRecd; exsr UpdateRecd;
@@ -296,9 +263,6 @@
clear CUSTMAST; clear CUSTMAST;
//Default status to active //Default status to active
ACTIVE = 'Y'; ACTIVE = 'Y';
//set just to make screen look better
CHGTIME = %timestamp();
CHGUSER = CURR_USER;
exsr FillScreenFields; exsr FillScreenFields;
dou NoErrors; dou NoErrors;
@@ -308,11 +272,20 @@
exsr UnProtectAll; exsr UnProtectAll;
exsr ScreenIO; exsr ScreenIO;
select; select;
when Key = F03 or Key = F12; when Key = F12;
exsr CloseDownPgm; exsr CloseDownPgm;
return; return;
when Key = F04;
exsr F04Prompt;
when Key = F05;
clear CUSTMAST;
ACTIVE = 'Y';
exsr FillScreenFields;
when Key = Enter; when Key = Enter;
exsr EditUpdData; exsr EditAddData;
if NoErrors; if NoErrors;
// Re-display field for confirmation // Re-display field for confirmation
exsr ProtectAll; exsr ProtectAll;
@@ -348,6 +321,7 @@
endsl; endsl;
enddo; enddo;
exsr CloseDownPgm; // Should never happen
return; return;
//============================================================ //============================================================
@@ -355,7 +329,6 @@
//============================================================ //============================================================
return; return;
//=== ReadRecd =============================================== //=== ReadRecd ===============================================
begsr ReadRecd; begsr ReadRecd;
exec sql exec sql
@@ -375,7 +348,7 @@
into :CUSTMAST into :CUSTMAST
from CUSTMAST from CUSTMAST
where CUSTID = :pID where CUSTID = :pID
; ;
if SQLSTT <> SQLSuccess and SQLSTT <> SQLNoData; if SQLSTT <> SQLSuccess and SQLSTT <> SQLNoData;
SQLProblem('ReadRecd'); SQLProblem('ReadRecd');
endif; endif;
@@ -394,12 +367,38 @@
SD_ACCTPH = ACCTPHONE; SD_ACCTPH = ACCTPHONE;
SD_ACCTMGR =ACCTMGR; SD_ACCTMGR =ACCTMGR;
SD_CORPPH = CORPPHONE; SD_CORPPH = CORPPHONE;
exec sql VALUES SD_CHGTIME = ' ';
varchar_format(:CHGTIME, 'YYYY-Mon-DD') SD_CHGUSER = ' ';
concat ' at ' concat // Show Changed stamp info
varchar_format(:CHGTIME,'HH24:MI:SS') if CHGUSER <> '*SYSTEM*' and CHGUSER <> ' ';
into :SD_CHGTIME; exec sql VALUES
SD_CHGUSER = CHGUSER; 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; endsr;
//=== EditUpdData ============================================ //=== EditUpdData ============================================
@@ -462,8 +461,8 @@
// Give up when the first error found. // Give up when the first error found.
// A valid screen field is moved to the database record. // A valid screen field is moved to the database record.
begsr EditAddData; begsr EditAddData;
NoErrors = *on; // For this program. same data for edit and add.
exsr EditUpdData;
endsr; endsr;
//=== Edit_SD_ACTIVE========================================== //=== Edit_SD_ACTIVE==========================================
@@ -577,7 +576,6 @@
PC_SD_CORPPH = *ON; PC_SD_CORPPH = *ON;
endsr; endsr;
//=== AddRecd ================================================ //=== AddRecd ================================================
// Insert a record into the file. // Insert a record into the file.
// Returns: NoErrors = *on if the add was successful. // Returns: NoErrors = *on if the add was successful.
@@ -588,7 +586,7 @@
Out Cust_Next; Out Cust_Next;
CUSTID= Cust_Next; CUSTID= Cust_Next;
CHGTIME = %timestamp(); CHGTIME = %timestamp();
CHGUSER = USER; CHGUSER = CURR_USER;
exec sql exec sql
insert into custmast insert into custmast
values(:CUSTMAST) values(:CUSTMAST)
@@ -603,6 +601,7 @@
// Updates the record with the screen data. // Updates the record with the screen data.
// The SQL WHERE checks the last time stamp and if different, // The SQL WHERE checks the last time stamp and if different,
// doesn't update because someone else updated the record. // 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 // SQLERRD(3) contains the actual number of records updated
// when the update is successful. // when the update is successful.
begsr UpdateRecd; begsr UpdateRecd;
@@ -619,7 +618,7 @@
ACCTPHONE = :SD_ACCTPH, ACCTPHONE = :SD_ACCTPH,
ACTIVE = :SD_ACTIVE, ACTIVE = :SD_ACTIVE,
CHGTIME = CURRENT TIMESTAMP, CHGTIME = CURRENT TIMESTAMP,
CHGUSER = USER CHGUSER = :CURR_USER
where CUSTID = :CUSTID where CUSTID = :CUSTID
-- and compare timestamp -- and compare timestamp
and CHGTIME = :Orig_CHGTIME; and CHGTIME = :Orig_CHGTIME;
@@ -632,7 +631,6 @@
exsr FillScreenFields; exsr FillScreenFields;
when SQLSTT =SQLRowLocked; // Row locked when SQLSTT =SQLRowLocked; // Row locked
// exec sql get diagnostics condition 1 :wkMsgText = MESSAGE_TEXT;
sflMsgSnt = SndSflMsg('DEM1001' : SQLERRMC); sflMsgSnt = SndSflMsg('DEM1001' : SQLERRMC);
NoErrors = *off; NoErrors = *off;
when SQLSTT = SQLSuccess; when SQLSTT = SQLSuccess;
@@ -676,7 +674,7 @@
// Clear any messages in the error subfile. // Clear any messages in the error subfile.
if SflMsgSnt = *on; if SflMsgSnt = *on;
SflMsgSnt = ClrMsgPgmQ(PgmName); SflMsgSnt = ClrMsgPgmQ(MainProc);
write MSGCTL; write MSGCTL;
endif; endif;
@@ -686,8 +684,7 @@
// Build the Function key text for the bottom of the screen. // Build the Function key text for the bottom of the screen.
begsr BldFkeyText; begsr BldFkeyText;
SFT_KEYS=' '; 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 : F5Text);
SFT_KEYS = CatB(SFT_KEYS : F12Text); SFT_KEYS = CatB(SFT_KEYS : F12Text);
endsr; endsr;
@@ -695,9 +692,8 @@
//=== CloseDownPgm =========================================== //=== CloseDownPgm ===========================================
// Things to do before we issue a return to the caller // Things to do before we issue a return to the caller
begsr CloseDownPgm; begsr CloseDownPgm;
// write DUMMY; // Closing the display file may cause any subfile display in
// close MTNCUSTD; // the caller to blank out.
// Do not turn on *LR to maintain an SFL display in caller
endsr; endsr;
//=== Init =================================================== //=== Init ===================================================
@@ -705,31 +701,36 @@
begsr Init; begsr Init;
//--- Analyse parameters --- //--- Analyse parameters ---
if %parms() = 0; // Close down
if %open(MTNCUSTD);
close MTNCUSTD;
endif;
*inlr = *on;
return;
endif;
select; select;
when %parms() = 0; // Close down
if %open(MTNCUSTD);
close MTNCUSTD;
endif;
// *inlr = *on;
return;
when %parms() = 1; when %parms() = 1;
Function = Displaying; function = displaying;
when %parms() = 2; when %parms() >= 2;
select; select;
when pMaintain = Closing; when pMaintain = Adding;
when pMaintain = Adding; Function = Adding;
Function = Adding; SH_FUNCT = CenterStr(H2TextA);
when pMaintain = Editing; when pMaintain = Editing;
Function = Editing; Function = Editing;
other; SH_FUNCT = CenterStr(H2TextE);
Function = Displaying; other;
Function = Displaying;
SH_FUNCT = CenterStr(H2TextD);
endsl; endsl;
other; other;
// Problem. // Should never happen
endsl; endsl;
//--- Miscellaneous setup --- //--- Miscellaneous setup ---
MSGPGMQ = PgmName; MainProc = %proc();
MSGPGMQ = MainProc;
SH_PGM = PgmName; SH_PGM = PgmName;
clear CUSTMAST; clear CUSTMAST;
clear dfIndDS; clear dfIndDS;
@@ -740,6 +741,9 @@
open MTNCUSTD; open MTNCUSTD;
endif; endif;
endsr; endsr;
/END-FREE
p Main e
//============================================================ //============================================================
// S u b P r o c e d u r e s // 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. // Concatenates a string to another string with a blank between.
// If the target string is all blank to start with it will not // If the target string is all blank to start with it will not
// end up with a leading blank. // end up with a leading blank.
/END-FREE pcatB b
PCatB b dcatB PI 79 varying
dCatB PI 79 varying d ToStr 79 varying value
D ToStr 79 varying value d AddStr 79 varying value
D AddStr 79 varying value
/FREE /FREE
if ToStr=' '; if ToStr=' ';
return AddStr; return AddStr;
@@ -760,8 +763,8 @@
return %trimr(ToStr) + ' ' + AddStr; return %trimr(ToStr) + ' ' + AddStr;
endif; endif;
/END-FREE /END-FREE
PCatB e pcatB e
P p
//=== SQLProblem =============================================== //=== SQLProblem ===============================================
// For those "Never should happen" SQL errors. // For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by // Issues DUMP(A) to dump memory, then ends program by
@@ -783,8 +786,6 @@
/end-free /end-free
p SQLProblem E p SQLProblem E
//-------------------------------------------------------------- //--------------------------------------------------------------
// Procedure name: SndSflMsg // Procedure name: SndSflMsg
// Purpose: Send a message to the Error Subfile // Purpose: Send a message to the Error Subfile
@@ -792,21 +793,20 @@
// Parameter: ErrMsgId => Msg Id to Send // Parameter: ErrMsgId => Msg Id to Send
// Parameter: ErrMsgData => Optional Error Message Data // Parameter: ErrMsgData => Optional Error Message Data
// Parameter: ErrMsgFile => Optional Error Message File // Parameter: ErrMsgFile => Optional Error Message File
// Defaults to PCAMSGF // Defaults to CUSTMSGF
//-------------------------------------------------------------- //--------------------------------------------------------------
P SndSflMsg B p SndSflMsg B
D SndSflMsg PI N d SndSflMsg PI N
D ErrMsgId 7A CONST d ErrMsgId 7A CONST
D ErrMsgData 80A CONST d ErrMsgData 80A CONST
D OPTIONS(*NOPASS:*VARSIZE) d OPTIONS(*NOPASS:*VARSIZE)
D ErrMsgFile 10A CONST d ErrMsgFile 10A CONST
D OPTIONS(*NOPASS) d OPTIONS(*NOPASS)
// Local fields // Local fields
D retField S N d retField S N
D wkMsgId s 7a d wkMsgId s 7a
D wkMsgFile s 10a d wkMsgFile s 10a
D wkMsgData s 80a varying d wkMsgData s 80a varying
/FREE /FREE
if %parms >2; if %parms >2;
@@ -820,7 +820,7 @@
wkMsgData = ' '; wkMsgData = ' ';
ENDIF; ENDIF;
wkMsgId = ErrMsgId; wkMsgId = ErrMsgId;
SNDMSGPGMQ(PgmName: SNDMSGPGMQ(MainProc:
wkMsgid: wkMsgid:
wkMsgFile: wkMsgFile:
wkMsgData); wkMsgData);
@@ -829,5 +829,5 @@
RETURN retField; RETURN retField;
/END-FREE /END-FREE
P SndSflMsg E p SndSflMsg E
5250_Subfile/PMTCUSTD
+10 -23
View File
@@ -1,11 +1,11 @@
A*%%TS SD 20200723 195503 LENNONS REL-V7R4M0 5770-WDS
A*=============================================================== A*===============================================================
A* This is a full screen expanding subfile to search for and A* This is a full screen expanding subfile to search for
A* select an item number. A* a customer.
A* ??- There are "from" and "to" positioner fields. A* - There are filters limit selection.
A* ??- There is a filter field on config. A* - A message subfile is included.
A* ??- A message subfile is included.
A*=============================================================== A*===============================================================
A* CRTDSPF FILE(PMTCUSTD) SRCFILE(...) RSTDSP(*YES)
A*==============================================================
A* There is a naming convention for the fields in each record. A* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_ A* -- Screen Header: Fields begin with SH_
A* -- Subfile: Fields begin with SF_ A* -- Subfile: Fields begin with SF_
@@ -27,11 +27,6 @@
A* data structure separate from the program indicators. A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS. A* This makes it easy to name the indicators in the DS.
A*============================================================== 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 DSPSIZ(24 80 *DS3)
A PRINT A PRINT
A INDARA A INDARA
@@ -41,14 +36,12 @@
A CA05 A CA05
A CA06 A CA06
A CA09 A CA09
A* CF10
A CA12 A CA12
A HELP A HELP
A*=============================================================== A*===============================================================
A*=== Screen Header: Fields begin with SH_ ===================== A*=== Screen Header: Fields begin with SH_ =====================
A* A*
A R SH_HDR A R SH_HDR
A*%%TS SD 20111207 212036 SLENNON REL-V7R1M0 5770-WDS
A OVERLAY A OVERLAY
A TEXT('Screen Header') A TEXT('Screen Header')
A SH_PGM 10A O 1 2 A SH_PGM 10A O 1 2
@@ -62,7 +55,6 @@
A*=== Subfile: Fields begin with SF_ =========================== A*=== Subfile: Fields begin with SF_ ===========================
A* A*
A R SFL SFL A R SFL SFL
A*%%TS SD 20200719 214706 LENNONS REL-V7R4M0 5770-WDS
A TEXT('SubFile') A TEXT('SubFile')
A 80 SFLNXTCHG A 80 SFLNXTCHG
A SF_ACT_H 1D H A SF_ACT_H 1D H
@@ -82,7 +74,6 @@
A*=== Subfile Control: Fields begin with SC_ ==================== A*=== Subfile Control: Fields begin with SC_ ====================
A* A*
A R SFLCTL SFLCTL(SFL) A R SFLCTL SFLCTL(SFL)
A*%%TS SD 20200723 195503 LENNONS REL-V7R4M0 5770-WDS
A SFLSIZ(0013) A SFLSIZ(0013)
A SFLPAG(0012) A SFLPAG(0012)
A TEXT('Subfile Control') A TEXT('Subfile Control')
@@ -95,10 +86,6 @@
A SFLDSPCTL A SFLDSPCTL
A 99 SFLCLR A 99 SFLCLR
A 97 SFLEND(*MORE) 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 2'Name starts with:'
A 4 31'City Starts with:' A 4 31'City Starts with:'
A 4 60'State+' A 4 60'State+'
@@ -114,7 +101,7 @@
A N03 DSPATR(ND) A N03 DSPATR(ND)
A 6 2'Type options, press Enter.' A 6 2'Type options, press Enter.'
A COLOR(BLU) A COLOR(BLU)
A SC_OPTIONS 69A O 7 2COLOR(BLU) A SC_OPTIONS 69A 7 2COLOR(BLU)
A 8 2'Opt' A 8 2'Opt'
A DSPATR(HI) A DSPATR(HI)
A 8 6'Customer Name' A 8 6'Customer Name'
@@ -129,11 +116,13 @@
A 8 74'ZIP ' A 8 74'ZIP '
A COLOR(WHT) A COLOR(WHT)
A DSPATR(UL) 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*===============================================================
A*=== Screen footer & function keys: Fields begin with SFT_ ==== A*=== Screen footer & function keys: Fields begin with SFT_ ====
A* A*
A R SFT_FKEY A R SFT_FKEY
A*%%TS SD 20111208 204102 SLENNON REL-V7R1M0 5770-WDS
A TEXT('Screen Footer') A TEXT('Screen Footer')
A OVERLAY A OVERLAY
A 22 2' Demo Cor- A 22 2' Demo Cor-
@@ -145,7 +134,6 @@
A*=== Message Subfile: No fields =============================== A*=== Message Subfile: No fields ===============================
A* A*
A R MSGSFL SFL A R MSGSFL SFL
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile') A TEXT('Message Subfile')
A SFLMSGRCD(24) A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY A MSGKEY SFLMSGKEY
@@ -154,7 +142,6 @@
A*=== Message Subfile Control: No fields ======================== A*=== Message Subfile Control: No fields ========================
A* A*
A R MSGCTL SFLCTL(MSGSFL) A R MSGCTL SFLCTL(MSGSFL)
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile Control') A TEXT('Message Subfile Control')
A PAGEDOWN A PAGEDOWN
A PAGEUP A PAGEUP
5250_Subfile/PMTCUSTR
+102 -116
View File
@@ -4,7 +4,7 @@
// It can be called to return a selected customer number or // It can be called to return a selected customer number or
// just to provide general inquiry functionality from a menu. // 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. // call another program, MTNCUSTR.
// //
// Parameters: // Parameters:
@@ -15,11 +15,6 @@
// I - Inquiry, read only: 5=Display // I - Inquiry, read only: 5=Display
// 2 Char 4 Selected customer id if parm 1 is S. // 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 // Program uses a full screen expanding subfile to select
// a Customer Master record. // a Customer Master record.
@@ -60,14 +55,14 @@
// not the default of QRPGLESRC. Change as needed. // not the default of QRPGLESRC. Change as needed.
//============================================================= //=============================================================
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt) h DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND') h BndDir('UTIL_BND')
//=== Display File ============================================ //=== Display File ============================================
FPMTCUSTD CF E WorkStn INFDS(dfInfDS) fPMTCUSTD CF E WorkStn INFDS(dfInfDS)
F INDDS(dfIndDS) f INDDS(dfIndDS)
F SFILE(SFL:SflRRN) f SFILE(SFL:SflRRN)
F USROPN f USROPN
// File is closed when returning with LR off. This avoids an // File is closed when returning with LR off. This avoids an
// annoying resdisplay of the last subfile on re-entry. // annoying resdisplay of the last subfile on re-entry.
@@ -80,41 +75,41 @@
//=== Display File Information Data Structure ================= //=== Display File Information Data Structure =================
// Allows us to determine which function key was pressed // Allows us to determine which function key was pressed
D dfInfDS DS d dfInfDS DS
D Key 369 369 d Key 369 369
//=== Display File Indicator Data Structure =================== //=== Display File Indicator Data Structure ===================
// This is a "private" indicator area for the display file. // 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 ---------- //--- 01-20 are not automatically cleared after EXFMT ----------
D scIncActInc 03 03n d scIncActInc 03 03n
//--- 21-99 automatically cleared after EXFMT ------------------ //--- 21-99 automatically cleared after EXFMT ------------------
D dfIndClr 21 99 d dfIndClr 21 99
//--- Subfile indicators (prefix "sf") --- //--- Subfile indicators (prefix "sf") ---
D SC_NAME_PC 79 79n d SC_NAME_PC 79 79n
D sfSflNxtChg 80 80n d sfSflNxtChg 80 80n
D sfOPT_RI 81 81n d sfOPT_RI 81 81n
D sfOPT_PC 82 82n d sfOPT_PC 82 82n
D sfInAct 83 83n d sfInAct 83 83n
//--- Subfile Control indicators (prefix "sc") --- //--- Subfile Control indicators (prefix "sc") ---
D*scNoDta 96 96n d*scNoDta 96 96n
D scSflEnd 97 97n d scSflEnd 97 97n
D scSflDsp 98 98n d scSflDsp 98 98n
D scSflClr 99 99n d scSflClr 99 99n
//=== Fields to control the subfile screen ==================== //=== Fields to control the subfile screen ====================
D SflRRN s 5 0 d SflRRN s 5 0
D RcdsInSfl s 5 0 d RcdsInSfl s 5 0
D SflPageSize c 12 d SflPageSize c 12
// SC_CSR_RCD is defined in the display file and is set with a // SC_CSR_RCD is defined in the display file and is set with a
// RRN which determines which subfile page is displayed and on // RRN which determines which subfile page is displayed and on
// which record the cursor is positioned. // which record the cursor is positioned.
//=== Text for function keys ================================== //=== Text for function keys ==================================
D F3Text c 'F3=Exit' d F3Text c 'F3=Exit'
d F4Text c 'F4=Prompt+' d F4Text c 'F4=Prompt+'
d F5Text c 'F5=Reset' d F5Text c 'F5=Reset'
d F6Text c 'F6=Add' d F6Text c 'F6=Add'
@@ -139,16 +134,16 @@
//=== Search Criteria Screen Fields =========================== //=== Search Criteria Screen Fields ===========================
d SearchCriteria ds inz d SearchCriteria ds inz
D SC_NAME d SC_NAME
D SC_CITY d SC_CITY
D SC_STATE d SC_STATE
//=== Last Search Criteria Fields ============================= //=== Last Search Criteria Fields =============================
d LastSearchCriteria... d LastSearchCriteria...
d ds inz d ds inz
D LastSC_NAME Like(SC_NAME) d LastSC_NAME Like(SC_NAME)
D LastSC_CITY Like(SC_CITY) d LastSC_CITY Like(SC_CITY)
D LastSC_STATE Like(SC_STATE) d LastSC_STATE Like(SC_STATE)
//=== SQL Search Variables ==================================== //=== SQL Search Variables ====================================
d Stmt s 1024 varying Select Statement d Stmt s 1024 varying Select Statement
@@ -162,13 +157,13 @@
//== CUSTMAST - define fields for SQL ========================= //== CUSTMAST - define fields for SQL =========================
// NOTE: Only the fields read by SQL are populated! // 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 // Records from SQL CURSOR read into CustCursor
D CustCursor ds likeds(Custmast) d CustCursor ds likeds(Custmast)
// Records from SQL select read into CustSelect // Records from SQL SELECT read into CustSelect
D CustSelect ds likeds(CustMast) d CustSelect ds likeds(CustMast)
//=== External Programs Prototypes ============================ //=== External Programs Prototypes ============================
@@ -176,59 +171,52 @@
d CustID options(*nopass) like(CUSTID) d CustID options(*nopass) like(CUSTID)
d Maintain 1a options(*nopass) d Maintain 1a options(*nopass)
D PmtState PR EXTPGM('PMTSTATER') d PmtState PR EXTPGM('PMTSTATER')
D TheState like(STATE) d TheState like(STATE)
D d
//=== Global Switches ========================================= //=== Global Switches =========================================
D EofData s n d EofData s n
D CursorOpen s n d CursorOpen s n
D NewSearchCriteria... d NewSearchCriteria...
D s n d s n
D SflMsgSnt s n d SflMsgSnt s n
D Opt1_OK s n d Opt1_OK s n
D OptError s n d OptError s n
D Maint_OK s n d Maint_OK s n
D CowsComeHome c const('0') d CowsComeHome c const('0')
D MaxSflRecds c const(9999) d MaxSflRecds c const(9999)
//=== Work Fields ============================================= //=== Work Fields =============================================
D inx s 10i 0 d inx s 10i 0
// Would prefer to defind these as like(SC_NAME) // Would prefer to defind these as like(SC_NAME)
// But SQL precompiler throws an error SQL0312, reason code 1 // But SQL precompiler throws an error SQL0312, reason code 1
D wkName s 13a d wkName s 13a
D wkCity s 13a d wkCity s 13a
//=== Parm fields for MTNCUSTR ================================ //=== Parm fields for MTNCUSTR ================================
D wkCustid s like(CUSTID) d wkCustid s like(CUSTID)
D CustDspParm s 1a d CustDspParm s 1a
D CustDspEdit c const('E') d CustDspEdit c const('E')
D CustDspAdd c const('A') d CustDspAdd c const('A')
D CustDspDsply c const('D') d CustDspDsply c const('D')
D d
//=== Program Status Data Structure =========================== //=== Program Status Data Structure ===========================
D ProgStatus sds d ProgStatus sds
D PgmName *PROC d PgmName *PROC
//=== Program Parameters ====================================== //=== Program Parameters ======================================
D pParmType S 1A d pParmType S 1A
D pCustID s Like(CUSTID) 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.
//============================================================= //=============================================================
// === Program Starts Here ==================================== // === Program Starts Here ====================================
//============================================================= //=============================================================
C *Entry plist c *Entry plist
C parm pParmType c parm pParmType
C parm pCustID c parm pCustID
/FREE /FREE
//=== Set SQL Options ========================================= //=== Set SQL Options =========================================
@@ -389,7 +377,6 @@
//--- F6: Add a record. ---------------------------------- //--- F6: Add a record. ----------------------------------
when Key = F06; when Key = F06;
if Maint_Ok = *on; if Maint_Ok = *on;
pCustID = 0;
CustDspParm = CustDspAdd; CustDspParm = CustDspAdd;
CustDsp(wkCustId : CustDspParm); CustDsp(wkCustId : CustDspParm);
else; else;
@@ -479,7 +466,7 @@
optError = *on; optError = *on;
// SFLNXTCHG forces this record to be read again // 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. // check it again for validity.
sfSflNxtChg = *on; sfSflNxtChg = *on;
sfOPT_RI = *on; sfOPT_RI = *on;
@@ -493,7 +480,7 @@
readc SFL; readc SFL;
enddo; enddo;
CustDsp(); // Close Window DSPF CustDsp(); // Closes Window DSPF & restores our subfile
endif; endif;
// If no positioning done, display last page, cursor on 1st recd. // If no positioning done, display last page, cursor on 1st recd.
@@ -577,7 +564,6 @@
endif; endif;
// Can't display more than 9,999 records. // Can't display more than 9,999 records.
// if SflRRN = 9999;
if SflRRN = MaxSflRecds; if SflRRN = MaxSflRecds;
EofData = *on; EofData = *on;
SflMsgSnt= SndSflMsg('DEM0006'); SflMsgSnt= SndSflMsg('DEM0006');
@@ -604,7 +590,7 @@
endif; endif;
update SFL; update SFL;
sfInAct = *off; sfInAct = *off;
write DUMMY; // Helps restore SFL display write DUMMY; // Supposed to help restore SFL display
endsr; endsr;
//=== ProcessSearchCriteria==================================== //=== ProcessSearchCriteria====================================
@@ -796,10 +782,10 @@
// Concatenates a string to another string with a blank between. // Concatenates a string to another string with a blank between.
// If the target string is all blank to start with it will not // If the target string is all blank to start with it will not
// end up with a leading blank. // end up with a leading blank.
PCatB b pCatB b
dCatB PI 79 varying dCatB PI 79 varying
D ToStr 79 varying value d ToStr 79 varying value
D AddStr 79 varying value d AddStr 79 varying value
/FREE /FREE
if ToStr=' '; if ToStr=' ';
return AddStr; return AddStr;
@@ -807,7 +793,7 @@
return %trimr(ToStr) + ' ' + AddStr; return %trimr(ToStr) + ' ' + AddStr;
endif; endif;
/END-FREE /END-FREE
PCatB e pCatB e
//=== SQLProblem ============================================== //=== SQLProblem ==============================================
// For those "Never should happen" SQL errors. // For those "Never should happen" SQL errors.
@@ -836,12 +822,12 @@
// *ON No more data, nothing returned // *ON No more data, nothing returned
// *OFF Data returned // *OFF Data returned
//------------------------------------------------------------ //------------------------------------------------------------
P FetchNextData B p FetchNextData B
D FetchNextData PI N d FetchNextData PI N
D TheRecd likeds(Custmast) d TheRecd likeds(Custmast)
// Local fields // Local fields
D wkEof S N d wkEof S N
/FREE /FREE
wkEoF= *off; wkEoF= *off;
exec sql fetch ItemCur into exec sql fetch ItemCur into
@@ -865,15 +851,15 @@
/END-FREE /END-FREE
P FetchNextData E p FetchNextData E
//=== ReadByKey =============================================== //=== ReadByKey ===============================================
// Read the record by key into the specified data record // Read the record by key into the specified data record
// using the key passed in. // using the key passed in.
P ReadByKey B p ReadByKey B
D ReadByKey PI d ReadByKey PI
D TheKey like(CUSTID) d TheKey like(CUSTID)
D TheRecd likeds(CustMast) d TheRecd likeds(CustMast)
/FREE /FREE
exec sql select exec sql select
NAME, NAME,
@@ -894,11 +880,11 @@
; ;
/END-FREE /END-FREE
P ReadByKey E p ReadByKey E
//=== BuildSFLRecd ============================================ //=== BuildSFLRecd ============================================
// Builds a SFL record from the specified data record // Builds a SFL record from the specified data record
P BuildSflRecd b p BuildSflRecd b
d BuildSflRecd PI d BuildSflRecd PI
d CustRecd likeds(CUSTMAST) d CustRecd likeds(CUSTMAST)
/FREE /FREE
@@ -917,13 +903,13 @@
// Save Active status in case we update subfile // Save Active status in case we update subfile
SF_ACT_H = CustRecd.ACTIVE; SF_ACT_H = CustRecd.ACTIVE;
/END-FREE /END-FREE
P BuildSFLRecd E p BuildSFLRecd E
//=== Procedure name: CloseCurssor ============================ //=== Procedure name: CloseCurssor ============================
// Closes the SQL Cursor if open // Closes the SQL Cursor if open
//------------------------------------------------------------ //------------------------------------------------------------
P CloseCursor B p CloseCursor B
D CloseCursor PI d CloseCursor PI
// Local fields // Local fields
//CursorOpen s n static //CursorOpen s n static
/FREE /FREE
@@ -936,7 +922,7 @@
endif; endif;
RETURN; RETURN;
/END-FREE /END-FREE
P CloseCursor E p CloseCursor E
//=== SndSflMsg =============================================== //=== SndSflMsg ===============================================
// Send a message to the Error Subfile // Send a message to the Error Subfile
@@ -946,19 +932,19 @@
// Parameter: ErrMsgFile => Optional Error Message File // Parameter: ErrMsgFile => Optional Error Message File
// Defaults to CUSTMSGF // Defaults to CUSTMSGF
//------------------------------------------------------------ //------------------------------------------------------------
P SndSflMsg B p SndSflMsg B
D SndSflMsg PI N d SndSflMsg PI N
D ErrMsgId 7A CONST d ErrMsgId 7A CONST
D ErrMsgData 80A CONST d ErrMsgData 80A CONST
D OPTIONS(*NOPASS:*VARSIZE) d OPTIONS(*NOPASS:*VARSIZE)
D ErrMsgFile 10A CONST d ErrMsgFile 10A CONST
D OPTIONS(*NOPASS) d OPTIONS(*NOPASS)
// Local fields // Local fields
D retField S N d retField S N
D wkMsgId s 7a d wkMsgId s 7a
D wkMsgFile s 10a d wkMsgFile s 10a
D wkMsgData s 80a varying d wkMsgData s 80a varying
/FREE /FREE
if %parms >2; if %parms >2;
@@ -981,13 +967,13 @@
RETURN retField; RETURN retField;
/END-FREE /END-FREE
P SndSflMsg E p SndSflMsg E
//=== SflClear ================================================ //=== SflClear ================================================
// Clears the Subfile // Clears the Subfile
//------------------------------------------------------------ //------------------------------------------------------------
P SflClear B p SflClear B
D SflClear PI d SflClear PI
/FREE /FREE
clear SflRRN; clear SflRRN;
clear RcdsInSfl; clear RcdsInSfl;
@@ -996,6 +982,6 @@
scSflClr = *OFF; scSflClr = *OFF;
return; return;
/END-FREE /END-FREE
P SflClear E p SflClear E
5250_Subfile/PMTSTATED
+19 -34
View File
@@ -1,8 +1,9 @@
A*%%TS SD 20200724 153608 LENNONS REL-V7R4M0 5770-WDS
A*=============================================================== A*===============================================================
A* This is a full screen expanding subfile to search for and A* This is a "load all" subfile in a windown to select a
A* select a Manufacturing QC Hold Disposition code A* state code.
A*=============================================================== A*===============================================================
A* CRTDSPF FILE(PMTSTATED) SRCFILE(...) RSTDSP(*YES)
A*==============================================================
A* There is a naming convention for the fields in each record. A* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_ A* -- Screen Header: Fields begin with SH_
A* -- Subfile: Fields begin with SF_ A* -- Subfile: Fields begin with SF_
@@ -23,34 +24,22 @@
A* data structure separate from the program indicators. A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS. A* This makes it easy to name the indicators in the DS.
A*============================================================== 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 DSPSIZ(24 80 *DS3 -
A 27 132 *DS4) A 27 132 *DS4)
A PRINT A PRINT
A INDARA A INDARA
A ALTHELP A ALTHELP
A CA03
A CF05
A CA07
A CA12
A HELP A HELP
A*=============================================================== A*===============================================================
A*=== Screen Header: Fields begin with SH_ ===================== A*=== Screen Header: Fields begin with SH_ =====================
A* A*
A R SH_HDR A R SH_HDR
A*%%TS SD 20111207 212036 SLENNON REL-V7R1M0 5770-WDS
A OVERLAY A OVERLAY
A TEXT('Screen Header') A TEXT('Screen Header')
A WINDOW(*DFT 17 40) A WINDOW(*DFT 16 40)
A WDWBORDER((*DSPATR RI)) A WDWBORDER((*DSPATR RI) (*CHAR +
A ' '))
A WDWBORDER((*COLOR BLU)) A WDWBORDER((*COLOR BLU))
A* CA03
A* CA12
A SH_PGM 10A O 1 1 A SH_PGM 10A O 1 1
A 1 16'USA States' A 1 16'USA States'
A COLOR(WHT) A COLOR(WHT)
@@ -63,7 +52,6 @@
A*=== Subfile: Fields begin with SF_ =========================== A*=== Subfile: Fields begin with SF_ ===========================
A* A*
A R SFL SFL A R SFL SFL
A*%%TS SD 20200723 210409 LENNONS REL-V7R4M0 5770-WDS
A TEXT('SubFile') A TEXT('SubFile')
A 80 SFLNXTCHG A 80 SFLNXTCHG
A SF_OPT 1A B 6 2 A SF_OPT 1A B 6 2
@@ -77,15 +65,17 @@
A*=== Subfile Control: Fields begin with SC_ ==================== A*=== Subfile Control: Fields begin with SC_ ====================
A* A*
A R SFLCTL SFLCTL(SFL) A R SFLCTL SFLCTL(SFL)
A*%%TS SD 20200723 210409 LENNONS REL-V7R4M0 5770-WDS A CF03
A *DS3 SFLSIZ(0008) A CF05
A *DS4 SFLSIZ(0008) A CF07
A *DS3 SFLPAG(0007) A CF12
A *DS4 SFLPAG(0007) A *DS3 SFLSIZ(9999)
A *DS4 SFLSIZ(9999)
A *DS3 SFLPAG(0006)
A *DS4 SFLPAG(0006)
A *DS3 WINDOW(SH_HDR) A *DS3 WINDOW(SH_HDR)
A *DS4 WINDOW(SH_HDR) A *DS4 WINDOW(SH_HDR)
A TEXT('Subfile Control') A TEXT('Subfile Control')
A PAGEDOWN
A RTNCSRLOC(&SC_PMT_RCD &SC_PMT_FLD) A RTNCSRLOC(&SC_PMT_RCD &SC_PMT_FLD)
A BLINK A BLINK
A OVERLAY A OVERLAY
@@ -104,13 +94,11 @@
A DSPATR(HI) A DSPATR(HI)
A DSPATR(UL) A DSPATR(UL)
A 5 5'Code' A 5 5'Code'
A N01 COLOR(WHT)
A 01 COLOR(PNK) A 01 COLOR(PNK)
A DSPATR(UL) A DSPATR(UL)
A 5 11'Name ' A 5 11'Name '
A DSPATR(UL) A DSPATR(UL)
A 01 COLOR(WHT) A 02 COLOR(PNK)
A N01 COLOR(PNK)
A SC_PMT_RCD 10A H A SC_PMT_RCD 10A H
A SC_PMT_FLD 10A H A SC_PMT_FLD 10A H
A SC_CSR_RCD 4S 0H SFLRCDNBR(CURSOR) A SC_CSR_RCD 4S 0H SFLRCDNBR(CURSOR)
@@ -118,29 +106,26 @@
A*=== Screen footer & function keys: Fields begin with SFT_ ==== A*=== Screen footer & function keys: Fields begin with SFT_ ====
A* A*
A R SFT_FKEY A R SFT_FKEY
A*%%TS SD 20200724 143229 LENNONS REL-V7R4M0 5770-WDS
A *DS3 WINDOW(SH_HDR) A *DS3 WINDOW(SH_HDR)
A *DS4 WINDOW(SH_HDR) A *DS4 WINDOW(SH_HDR)
A TEXT('Screen Footer') A TEXT('Screen Footer')
A OVERLAY A OVERLAY
A 14 1' Demo Corp of America - A 13 1' Demo Corp of America -
A ' A '
A DSPATR(UL) A DSPATR(UL)
A SFT_KEYS 40 O 15 1 A SFT_KEYS 40 O 14 1
A*=============================================================== A*===============================================================
A*=== Message Subfile: No fields =============================== A*=== Message Subfile: No fields ===============================
A* A*
A R MSGSFL SFL A R MSGSFL SFL
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile') A TEXT('Message Subfile')
A SFLMSGRCD(16) A SFLMSGRCD(15)
A MSGKEY SFLMSGKEY A MSGKEY SFLMSGKEY
A MSGPGMQF SFLPGMQ(10) A MSGPGMQF SFLPGMQ(10)
A*=============================================================== A*===============================================================
A*=== Message Subfile Control: No fields ======================== A*=== Message Subfile Control: No fields ========================
A* A*
A R MSGCTL SFLCTL(MSGSFL) A R MSGCTL SFLCTL(MSGSFL)
A*%%TS SD 19990831 134515 LENNON$S REL-V4R2M0 5769-PW1
A TEXT('Message Subfile Control') A TEXT('Message Subfile Control')
A WINDOW(SH_HDR) A WINDOW(SH_HDR)
A PAGEDOWN A PAGEDOWN
5250_Subfile/PMTSTATER
+131 -184
View File
@@ -1,4 +1,11 @@
/TITLE PMTSTATE Search and return a USA State Code /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. // Displays USA state names and their 2-char codes in a window.
// Can sort the display by name or code. // Can sort the display by name or code.
@@ -22,7 +29,7 @@
// carried across subroutines. // carried across subroutines.
// - UPPERCASE is used for external names, i.e., files, fields, formats // - UPPERCASE is used for external names, i.e., files, fields, formats
// and anything else not directly coded in the program. // and anything else not directly coded in the program.
//
// - In the display file, this field naming convention is used: // - In the display file, this field naming convention is used:
// Screen Header: Fields begin with SH_ // Screen Header: Fields begin with SH_
// Subfile: Fields begin with SF_ // Subfile: Fields begin with SF_
@@ -35,18 +42,18 @@
// not the default of QRPGLESRC. Change as needed. // not the default of QRPGLESRC. Change as needed.
//============================================================= //=============================================================
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt) h DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND') h BndDir('UTIL_BND')
H main(Main) h main(Main)
//=== Display File ============================================== //=== Display File ==============================================
FPMTSTATED CF E WorkStn INFDS(dfInfDS) fPMTSTATED CF E WorkStn INFDS(dfInfDS)
F INDDS(dfIndDS) f INDDS(dfIndDS)
F SFILE(SFL:SflRRN) f SFILE(SFL:SflRRN)
F USROPN f USROPN
D Main pr extpgm('PMTSTATER') d Main pr extpgm('PMTSTATER')
D 2A d ReturnState 2A
//=== Service Program Prototypes ================================ //=== Service Program Prototypes ================================
/include DEMO,Srv_Msg_P /include DEMO,Srv_Msg_P
@@ -57,8 +64,8 @@
//=== Fields read by SQL ======================================== //=== Fields read by SQL ========================================
// NOTE: Only the fields in fetchData which are fetched by the // NOTE: Only the fields in fetchData which are fetched by the
// SQL Cursor are populated. // SQL Cursor are populated.
D STATES e ds extname(STATES) d STATES e ds extname(STATES)
D qualified template d qualified template
d FetchData ds likeds(STATES) d FetchData ds likeds(STATES)
//=== SQL State Constants ======================================= //=== SQL State Constants =======================================
@@ -70,56 +77,58 @@
//=== Display File Information Data Structure =================== //=== Display File Information Data Structure ===================
// Allows us to determine which function key was pressed // Allows us to determine which function key was pressed
D dfInfDS DS d dfInfDS DS
D Key 369 369 d Key 369 369
//=== Display File Indicator Data Structure ===================== //=== Display File Indicator Data Structure =====================
// This is a "private" indicator area for the display file. // 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 ---------- //--- 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 ------------------ //--- 21-99 automatically cleared after EXFMT ------------------
D dfIndClr 21 99 d dfIndClr 21 99
//--- Subfile indicators (prefix "sf") ------------------------- //--- Subfile indicators (prefix "sf") -------------------------
D sfSflNxtChg 80 80n d sfSflNxtChg 80 80n
D sfOPT_RI 81 81n d sfOPT_RI 81 81n
D sfOPT_PC 82 82n d sfOPT_PC 82 82n
//--- Subfile Control indicators (prefix "sc") ---------------- //--- Subfile Control indicators (prefix "sc") ----------------
D scMDT 95 95n d scMDT 95 95n
D scNoDta 96 96n d scNoDta 96 96n
D scSflEnd 97 97n d scSflEnd 97 97n
D scSflDsp 98 98n d scSflDsp 98 98n
D scSflClr 99 99n d scSflClr 99 99n
//=== Fields to control the subfile screen ====================== //=== Fields to control the subfile screen ======================
D SflRRN s 5 0 d SflRRN s 5i 0
D RcdsInSfl s 5 0 d RcdsInSfl s 5i 0
D SflPageSize c 7 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 // SC_CSR_RCD is defined in the display file and is set with a
// RRN which determines which subfile page is displayed and on // RRN which determines which subfile page is displayed and on
// which record the cursor is positioned. // which record the cursor is positioned.
//=== Program Status Data Structure ============================= //=== Program Status Data Structure =============================
D ProgStatus sds d ProgStatus sds
D PgmName *PROC d PgmName *PROC
D MainProc S 10a d MainProc S 10a
//=== Text for function keys ==================================== //=== Text for function keys ====================================
D F3Text c 'F3=Exit' d F3Text c 'F3=Exit'
d F5Text c 'F5=Refresh' d F5Text c 'F5=Refresh'
d F12Text c 'F12=Cancel' d F12Text c 'F12=Cancel'
D F7Text1 c 'F7=By ' d F7Text1 c 'F7=By '
D F7Text2 s 5a inz(' ') d F7Text2 s 5a inz(' ')
D F7Text S 11a inz(' ') d F7Text S 11a inz(' ')
//SortSeq is used in SQL Order By //SortSeq is used in SQL Order By in a CASE construct.
D SortSeq s 4a inz(' ') d SQLSortSeq s 4a inz(' ')
D SortbyName s 4a inz('Name') d SortbyName s 4a inz('Name')
D SortbyCode s 4a inz('Code') d SortbyCode s 4a inz('Code')
//=== Options Text ============================================== //=== Options Text ==============================================
@@ -127,35 +136,28 @@
//=== Search Criteria Screen Fields ============================= //=== Search Criteria Screen Fields =============================
d SearchCriteria ds inz d SearchCriteria ds inz
D SC_NAME d SC_NAME
//=== Last Search Criteria Fields =============================== //=== Last Search Criteria Fields ===============================
d LastSearchCriteria... d LastSearchCriteria...
d ds inz d ds inz
D LastSC_NAME Like(SC_NAME) d LastSC_NAME Like(SC_NAME)
//=== SQL Search Variables ====================================== //=== SQL Search Variables ======================================
D DESCLike S 12 varying d DESCLike S 12 varying
//=== Global Switches =========================================== //=== Global Switches ===========================================
D EofData s n d EofData s n
D CursorOpen s n d CursorOpen s n
D NewSearchCriteria... d NewSearchCriteria...
D s n d s n
D SflMsgSnt s n d SflMsgSnt s n
d Opt1OK s n d Opt1OK s n
D OptError s n d OptError s n
D CowsComeHome c const('0') d CowsComeHome c const('0')
//=== Work Fields =============================================== //=== Work Fields ===============================================
D inx s 10i 0 d inx s 10i 0
//=== Translation ===============================================
D Lower c const('abcdefghijklmnopqrstuvwxyz')
D Upper c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
D HighVals s 30 inz(*hival)
//============================================================= //=============================================================
//== Program Starts Here ====================================== //== Program Starts Here ======================================
@@ -164,7 +166,6 @@
d Main pi d Main pi
d pState Like(FetchData.STATE) d pState Like(FetchData.STATE)
/FREE /FREE
exsr Init; exsr Init;
exsr BldFkeyText; exsr BldFkeyText;
@@ -173,7 +174,7 @@
exec sql set option datfmt=*iso, exec sql set option datfmt=*iso,
closqlcsr=*endmod; closqlcsr=*endmod;
//=== SQL Cursor Definitions ================================== //=== 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. // used in a CASE statement.
exec SQL exec SQL
declare DataCur cursor for declare DataCur cursor for
@@ -182,18 +183,18 @@
NAME NAME
from STATES from STATES
where upper(NAME) like :DescLike where upper(NAME) like :DescLike
order by case :SortSeq order by case :SQLSortSeq
when :SortByName then NAME when :SortByName then NAME
when :SortByCode then STATE when :SortByCode then STATE
else '1' else '1'
end end
optimize for 7 rows
for fetch only; for fetch only;
// === Initial screen display ================================= // === Initial screen display =================================
write SH_HDR; write SH_HDR;
SflClear(); SflClear();
exsr SflFirstPage; exsr ProcessSearchCriteria;
exsr SflLoadAll;
//============================================================= //=============================================================
// === Main Program Loop ====================================== // === Main Program Loop ======================================
@@ -206,7 +207,8 @@
// If switching display order, reload first page // If switching display order, reload first page
if Key = F07; if Key = F07;
exsr SflFirstPage; exsr ProcessSearchCriteria;
exsr SflLoadAll;
endif; endif;
// Write/Read the screen // Write/Read the screen
@@ -219,21 +221,12 @@
if SearchCriteria <> LastSearchCriteria if SearchCriteria <> LastSearchCriteria
or NewSearchCriteria = *on; or NewSearchCriteria = *on;
SflClear(); SflClear();
exsr SflFirstPage; exsr ProcessSearchCriteria;
exsr SflLoadAll;
else; else;
exsr ProcessOption; exsr ProcessOption;
endif; endif;
iter;
endif;
//--- Page Down -------------------------------------------
if Key = PageDown;
if RcdsInSfl > 0;
exsr SflFillPage;
else;
// Key not active msg
SflMsgSnt= SndSflMsg('DEM0003');
endif;
iter; iter;
endif; endif;
@@ -292,8 +285,8 @@
//--- F3: Exit, close down program ----------------------- //--- F3: Exit, close down program -----------------------
when Key = F03; when Key = F03;
*inlr = *on;
exsr CloseDownPgm; exsr CloseDownPgm;
*inlr = *on;
return; return;
//--- F12: Return to caller, leave program active --------- //--- F12: Return to caller, leave program active ---------
@@ -309,15 +302,17 @@
//--- F7: Toggle Sort Sequence --------------------------- //--- F7: Toggle Sort Sequence ---------------------------
when Key = F07; when Key = F07;
if SortSeq=SortByName; if SQLSortSeq=SortByName;
SortSeq = SortByCode; SQLSortSeq = SortByCode;
SC_SORTED = SortbyName; SC_SORTED = SortByCode;
ScSortColor=*on; scCodeHi = *on;
scNameHi = *off;
F7Text2 = SortByName; F7Text2 = SortByName;
else; else;
SortSeq = SortByName; SQLSortSeq = SortByName;
SC_SORTED = SortbyCode; SC_SORTED = SortByName;
scSortColor = *off; scNameHi = *on;
scCodeHI = *off;
F7Text2 = SortbyCode; F7Text2 = SortbyCode;
endif; endif;
F7Text = F7Text1 + F7Text2; F7Text = F7Text1 + F7Text2;
@@ -353,9 +348,9 @@
// Return Code to caller // Return Code to caller
pSTATE = SF_CODE; pSTATE = SF_CODE;
exsr CloseDownPgm; exsr CloseDownPgm;
*inlr = *on;
return; return;
//--- Opt is blank ---------------------------------------- //--- Opt is blank ----------------------------------------
when SF_OPT = ' '; when SF_OPT = ' ';
// If changed, assume clearing an error from last time // If changed, assume clearing an error from last time
@@ -372,7 +367,7 @@
// Not a valid option at this time // Not a valid option at this time
SflMsgSnt= SndSflMsg('DEM0004':SF_OPT); SflMsgSnt= SndSflMsg('DEM0004':SF_OPT);
// Leave cursor at first invalid option // Leave cursor at first invalid option
exsr SetCursorPosition; exsr SetScreenCursorPosition;
optError = *on; optError = *on;
// SFLNXTCHG forces this record to be read again // SFLNXTCHG forces this record to be read again
@@ -404,92 +399,44 @@
endsr; endsr;
//=== SflFirstPage ============================================ //=== SflLoadAll ==============================================
// Processes the Search fields in the Sub file control, then // Loads all selected records to the subfile.
// fills the first page of the subfile.
// If any errors in the search fields then no records are
// are added to the subfile.
// Returns: // Returns:
// EofData = *on if there are no more data records // EofData = *on (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.
// RcdsInSfl contains relative record number of last record // RcdsInSfl contains relative record number of last record
// written to the subfile. // written to the subfile.
// SC_CSR_RCD contains relative record number of 1st record // SC_CSR_RCD contains relative record number of 1st record
// on the page & positions cursor there. // on the page & positions cursor there.
begsr SflFillPage; begsr SflLoadAll;
select;
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. // Position cursor at first record on the subfile page.
SC_CSR_RCD = 0; SC_CSR_RCD = 1;
for inx = 1 to SflPageSize;
for inx = 1 to SflMaxRecd;
EofData = FetchNextData();
if EofData = *on;
leave;
endIf;
// Build/Format the subfile record // Build/Format the subfile record
clear SF_OPT; clear SF_OPT;
SF_CODE = FetchData.STATE; SF_CODE = FetchData.STATE;
SF_NAME = FetchData.NAME; SF_NAME = FetchData.NAME;
SflRRN = inx;
RcdsinSfl = RcdsInSfl + 1; RcdsinSfl = RcdsInSfl + 1;
SflRRN = RcdsInSfl;
write SFL; 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. // Can't display more than 9,9999 records.
if SflRRN = 9999; if SflRRN = SflMaxRecd;
EofData = *on; EofData = *on;
SflMsgSnt= SndSflMsg('DEM0006'); SflMsgSnt= SndSflMsg('DEM0006');
leave; leave;
endif; endif;
EofData = FetchNextData();
if EofData = *on;
leave;
endIf;
endfor; endfor;
endsl;
endsr; endsr;
//=== ProcessSearchCriteria==================================== //=== ProcessSearchCriteria====================================
@@ -510,7 +457,6 @@
NewSearchCriteria = *off; NewSearchCriteria = *off;
// Save entered values. (Never change screen fields.) // Save entered values. (Never change screen fields.)
LastSearchCriteria = SearchCriteria; LastSearchCriteria = SearchCriteria;
//exsr SaveSearchCriteria;
CloseCursor(); CloseCursor();
//--------------------------------------------------------------- //---------------------------------------------------------------
@@ -522,7 +468,7 @@
endif; endif;
//--------------------------------------------------------------- //---------------------------------------------------------------
// If no errors, open the SQL cursor // If no errors in search criteria, open the SQL cursor
if NewSearchCriteria = *off; if NewSearchCriteria = *off;
exec sql open DataCur; exec sql open DataCur;
if SQLSTT <> SQLSuccess; if SQLSTT <> SQLSuccess;
@@ -536,7 +482,7 @@
//=== SetCursorPostion ======================================== //=== SetCursorPostion ========================================
// If Invalid Option, position screen cursor on first one, // If Invalid Option, position screen cursor on first one,
// else postion cursor on the last valid option. // else postion cursor on the last valid option.
begsr SetCursorPosition; begsr SetScreenCursorPosition;
if OptError = *off; if OptError = *off;
SC_CSR_RCD=SflRRN; SC_CSR_RCD=SflRRN;
endif; endif;
@@ -556,15 +502,18 @@
// Things to do before we issue a return to the caller // Things to do before we issue a return to the caller
begsr CloseDownPgm; begsr CloseDownPgm;
CloseCursor(); CloseCursor();
if %open(PMTSTATED);
close PMTSTATED;
endif;
endsr; endsr;
//=== Init ==================================================== //=== Init ====================================================
// Must be executed each time program is entered, because F12 // Must be executed each time program is entered
// and Enter key leave with LR off.
begsr Init; begsr Init;
SortSeq = SortByCode; SQLSortSeq = SortByName;
SC_SORTED = SortbyName; SC_SORTED = SortByName;
scSortColor = *off; scNameHi = *on; // Name highlighted
scCodeHi = *off;
F7Text2 = SortByCode; F7Text2 = SortByCode;
F7Text = F7Text1 + F7Text2; F7Text = F7Text1 + F7Text2;
@@ -578,9 +527,11 @@
MSGPGMQF = MainProc; MSGPGMQF = MainProc;
MSGPGMQC = MSGPGMQF; MSGPGMQC = MSGPGMQF;
SH_PGM = PgmName; SH_PGM = PgmName;
if not %open(PMTSTATED); if not %open(PMTSTATED);
open PMTSTATED; open PMTSTATED;
endif; endif;
// Clear fields left over from previous F12. // Clear fields left over from previous F12.
reset LastSearchCriteria; reset LastSearchCriteria;
reset SearchCriteria; reset SearchCriteria;
@@ -602,10 +553,10 @@
// If the target string is all blank to start with it will not // If the target string is all blank to start with it will not
// end up with a leading blank. // end up with a leading blank.
/END-FREE /END-FREE
PCatB b pCatB b
dCatB PI 79 varying dCatB PI 79 varying
D ToStr 79 varying value d ToStr 79 varying value
D AddStr 79 varying value d AddStr 79 varying value
/FREE /FREE
if ToStr=' '; if ToStr=' ';
return AddStr; return AddStr;
@@ -613,7 +564,8 @@
return %trimr(ToStr) + ' ' + AddStr; return %trimr(ToStr) + ' ' + AddStr;
endif; endif;
/END-FREE /END-FREE
PCatB e pCatB e
// === SQLProblem ================================================ // === SQLProblem ================================================
// For those "Never should happen" SQL errors. // For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by // Issues DUMP(A) to dump memory, then ends program by
@@ -635,7 +587,6 @@
/end-free /end-free
p SQLProblem E p SQLProblem E
//-------------------------------------------------- //--------------------------------------------------
// Procedure name: FetchNextData // Procedure name: FetchNextData
// Purpose: Fetch the next row from the cursor // Purpose: Fetch the next row from the cursor
@@ -643,11 +594,11 @@
// *ON No more data, nothing returned // *ON No more data, nothing returned
// *OFF Data returned // *OFF Data returned
//-------------------------------------------------- //--------------------------------------------------
P FetchNextData B p FetchNextData B
D FetchNextData PI N d FetchNextData PI N
// Local fields // Local fields
D wkEof S N d wkEof S N
/FREE /FREE
wkEoF= *off; wkEoF= *off;
exec sql fetch DataCur into exec sql fetch DataCur into
@@ -666,7 +617,7 @@
RETURN wkEof; RETURN wkEof;
/END-FREE /END-FREE
P FetchNextData E p FetchNextData E
//-------------------------------------------------- //--------------------------------------------------
// Procedure name: SndSflMsg // Procedure name: SndSflMsg
@@ -677,19 +628,19 @@
// Parameter: ErrMsgFile => Optional Error Message File // Parameter: ErrMsgFile => Optional Error Message File
// Defaults to CUSTMSGF // Defaults to CUSTMSGF
//-------------------------------------------------- //--------------------------------------------------
P SndSflMsg B p SndSflMsg B
D SndSflMsg PI N d SndSflMsg PI N
D ErrMsgId 7A CONST d ErrMsgId 7A CONST
D ErrMsgData 80A CONST d ErrMsgData 80A CONST
D OPTIONS(*NOPASS:*VARSIZE) d OPTIONS(*NOPASS:*VARSIZE)
D ErrMsgFile 10A CONST d ErrMsgFile 10A CONST
D OPTIONS(*NOPASS) d OPTIONS(*NOPASS)
// Local fields // Local fields
D retField S N d retField S N
D wkMsgId s 7a d wkMsgId s 7a
D wkMsgFile s 10a d wkMsgFile s 10a
D wkMsgData s 80a varying d wkMsgData s 80a varying
/FREE /FREE
if %parms >2; if %parms >2;
@@ -712,14 +663,14 @@
RETURN retField; RETURN retField;
/END-FREE /END-FREE
P SndSflMsg E p SndSflMsg E
//-------------------------------------------------- //--------------------------------------------------
// Procedure name: CloseCurssor // Procedure name: CloseCurssor
// Purpose: Closes the SQL Cursor // Purpose: Closes the SQL Cursor
//-------------------------------------------------- //--------------------------------------------------
P CloseCursor B p CloseCursor B
D CloseCursor PI d CloseCursor PI
/FREE /FREE
if CursorOpen = *on; if CursorOpen = *on;
exec sql close DataCur; exec sql close DataCur;
@@ -730,16 +681,15 @@
endif; endif;
RETURN; RETURN;
/END-FREE /END-FREE
P CloseCursor E p CloseCursor E
//-------------------------------------------------- //--------------------------------------------------
// Procedure name: SflClear // Procedure name: SflClear
// Purpose: Clears the Subfile // Purpose: Clears the Subfile
// Returns: // Returns:
//-------------------------------------------------- //--------------------------------------------------
P SflClear B p SflClear B
D SflClear PI d SflClear PI
/FREE /FREE
clear SflRRN; clear SflRRN;
clear RcdsInSfl; clear RcdsInSfl;
@@ -748,7 +698,4 @@
scSflClr = *OFF; scSflClr = *OFF;
return; return;
/END-FREE /END-FREE
P SflClear E p SflClear E
5250_Subfile/README.md
+7 -3
View File
@@ -2,7 +2,7 @@
(__Under Construction__) (__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 ### 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. 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. 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. 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 ### 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. 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. 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 #### CRTMSGF
Creates the CUSTMSGF message file used by the programs. Creates the CUSTMSGF message file used by the programs.
README.md
+1 -1
View File
@@ -21,4 +21,4 @@ Batch program with SQL embedded in RPGLE. Includes error checking and handling.
## 5250 Subfile ## 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.