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

Delete those with .RPGLE suffix

Browse Source
This commit is contained in:
SJLennon
2021-10-07 12:04:01 -04:00
parent a18f8ebc0a
commit af3f48b03f
3 changed files with 0 additions and 2521 deletions
Download Patch File Download Diff File Expand all files Collapse all files
5250_Subfile/MTNCUSTR
-833
View File
@@ -1,833 +0,0 @@
/TITLE MNTCUSTR - Update/Display a Customer Master
//==============================================================
// A maintenance or display program for a Customer Master Recds
//
//
// Parameters
// ----------
// 1 In Z4 Customer Id to, or 0 to add a new code
// 2 In CL1 Function
// E - Edit passed record
// D - Display passed record
// A - Add a new record
//
// 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.)
//
// Naming Conventions
// ==================
// - Lower case is the default for opcodes.
// - TitleCase is used for program variables, subroutines and procedure
// names, e.g. MaxOrderQty, BldFkeyText, etc.
// - Temporary variables are prefixed with "wk", e.g., wkDate. Such
// variables contain valid data for only a short time and are never
// 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_
// Screen footer: Fields begin with SFT_
//==============================================================
// Compilation
// Use CRTSQLRPGI command.
// Note that /INCLUDEs expects to find code in DEMO library,
// not the default of QRPGLESRC. Change as needed.
//=============================================================
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
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)
//=== SQL State Constants ======================================
d SQLSuccess c '00000'
d SQLNoData c '02000'
d SQLNoMoreData c '02000'
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
//=== Display File Indicator Data Structure ====================
// This is a "private" indicator area for the display file.
d dfIndDS ds 99
//--- 01-20 are not automatically cleared after EXFMT ----------
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
d DSP_SD_STAMP 61 61n
//=== Screen Header Text =======================================
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'
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
//=== 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 NoErrors s n
// === Global Fields ===========================================
d Orig_CHGTIME s z
//=== Work Fields ==============================================
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 MainProc S 10a
//==============================================================
//==============================================================
// === Program Starts Here =====================================
//==============================================================
p Main b
d Main pi
d pID like(CUSTID)
d pMaintain 1a
/FREE
//=== Set SQL Options ===============================
exec sql set option datfmt=*iso,
closqlcsr=*endmod,
commit = *NONE;
//=== Initialization Logic ===================================
exsr Init;
//--- Establish window that other formats refer to ---
write SH_HDR;
//============================================================
// === Main Program Loop =====================================
//============================================================
// Loops until logic decides to exit.
dou CowsComeHome;
select;
// =======================================================
// === Displaying an existing Customer ===================
// =======================================================
when Function = Displaying;
exsr ReadRecd;
if SQLSTT = SQLNoData;
SQLProblem('Calling error 1: Code passed in does not exist.');
endif;
exsr FillScreenFields;
// All Fields protected
exsr ProtectAll;
exsr ScreenIO;
exsr CloseDownPgm;
return;
// =======================================================
// === Updating an existing Customer =====================
// =======================================================
when Function = Editing;
exsr ReadRecd;
if SQLSTT = SQLNoData;
SQLProblem('Calling error 2: Code passed in does not exist.');
endif;
exsr FillScreenFields;
// Write/read screen until all data is valid,
// then re-display for confirmation to update.
dou NoErrors;
exsr ScreenIO;
select;
when Key = F12;
exsr CloseDownPgm;
return;
when Key = F05;
exsr ReadRecd;
if SQLSTT = SQLNoData;
// Record vanished!
SflMsgSnt= SndSflMsg('DEM0599'); //Delete, redo search
clear CUSTMAST;
endif;
NoErrors = *off;
when Key = F04;
exsr F04Prompt;
when Key = Enter;
exsr EditUpdData;
if NoErrors;
// Re-display screen fields for confirmation
exsr ProtectAll;
exsr FillScreenFields;
SflMsgSnt = SndSflMsg('DEM0000'); // Enter to update ...
exsr ScreenIO;
select;
when Key = F12 or Key = F05;
// Loop again
when Key = Enter;
exsr UpdateRecd;
if NoErrors;
exsr CloseDownPgm; // Success! Exit program
return;
endif;
other;
SflMsgSnt = SndSflMsg('DEM0003'); // Key not active
NoErrors = *off;
endsl;
endif;
// Open up fields for correction of errors
exsr UnprotectAll;
other;
SflMsgSnt = SndSflMsg('DEM0003'); // Key not active
NoErrors = *off; // Stay in dou NoErrors
endsl;
enddo;
// =======================================================
// === Adding a new Customer =============================
// =======================================================
when Function=Adding;
clear CUSTMAST;
//Default status to active
ACTIVE = 'Y';
exsr FillScreenFields;
dou NoErrors;
// Write/read screen until all data is valid,
// then re-display for confirmation to update.
//All fields can be keyed
exsr UnProtectAll;
exsr ScreenIO;
select;
when Key = F12;
exsr CloseDownPgm;
return;
when Key = F04;
exsr F04Prompt;
when Key = F05;
clear CUSTMAST;
ACTIVE = 'Y';
exsr FillScreenFields;
when Key = Enter;
exsr EditAddData;
if NoErrors;
// Re-display field for confirmation
exsr ProtectAll;
SflMsgSnt = SndSflMsg('DEM0009'); // Enter to add ...
exsr FillScreenFields;
exsr ScreenIo;
select;
when Key=F12;
exsr FillScreenFields;
when Key = Enter;
exsr AddRecd;
if NoErrors;
exsr CloseDownPgm;
return;
endif;
other;
SflMsgSnt = SndSflMsg('DEM0003'); // Key not active
NoErrors = *off;
endsl;
endif;
other;
SflMsgSnt = SndSflMsg('DEM0003'); // Key not active
endsl;
enddo;
other;
// =======================================================
//=== Goofed - Should ever happen ========================
// =======================================================
dump(a);
SflMsgSnt = SndSflMsg('DEM9999'); // Contact IT now ...
return;
endsl;
enddo;
exsr CloseDownPgm; // Should never happen
return;
//============================================================
//=== End of Main Program Loop ===============================
//============================================================
return;
//=== ReadRecd ===============================================
begsr ReadRecd;
exec sql
select
CUSTID
,NAME
,ADDR
,CITY
,STATE
,ZIP
,CORPPHONE
,ACCTMGR
,ACCTPHONE
,ACTIVE
,CHGTIME
,CHGUSER
into :CUSTMAST
from CUSTMAST
where CUSTID = :pID
;
if SQLSTT <> SQLSuccess and SQLSTT <> SQLNoData;
SQLProblem('ReadRecd');
endif;
Orig_CHGTIME = CHGTIME; // Save for update comparison
endsr;
//=== FillScreenFields =======================================
begsr FillScreenFields;
SD_CUSTID = CUSTID;
SD_NAME = NAME;
SD_ADDR = ADDR;
SD_CITY = CITY;
SD_STATE = STATE;
SD_ZIP = ZIP;
SD_ACTIVE = ACTIVE;
SD_ACCTPH = ACCTPHONE;
SD_ACCTMGR =ACCTMGR;
SD_CORPPH = CORPPHONE;
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 ============================================
// Edit the screen fields that can be changed on a update.
// Give up when the first error found.
// A valid screen field is moved to the database record.
begsr EditUpdData;
NoErrors = *on;
// ACTIVE Status
exsr Edit_SD_ACTIVE;
if NoErrors = *off;
leavesr;
endif;
// Name
exsr Edit_SD_NAME;
if NoErrors = *off;
leavesr;
endif;
// Addr
exsr Edit_SD_ADDR;
if NoErrors = *off;
leavesr;
endif;
// City
exsr Edit_SD_CITY;
if NoErrors = *off;
leavesr;
endif;
// State
exsr Edit_SD_STATE;
if NoErrors = *off;
leavesr;
endif;
// ZIP
exsr Edit_SD_ZIP;
if NoErrors = *off;
leavesr;
endif;
// Account Phone
exsr Edit_SD_ACCTPH;
if NoErrors = *off;
leavesr;
endif;
// Account Manager
exsr Edit_SD_ACCTMGR;
if NoErrors = *off;
leavesr;
endif;
// Corporate Phone
exsr Edit_SD_CORPPH;
if NoErrors = *off;
leavesr;
endif;
endsr;
//=== EditAddData ============================================
// Edit the screen fields needed to add a record.
// Give up when the first error found.
// A valid screen field is moved to the database record.
begsr EditAddData;
// For this program. same data for edit and add.
exsr EditUpdData;
endsr;
//=== Edit_SD_ACTIVE==========================================
begsr Edit_SD_ACTIVE;
if SD_ACTIVE = 'Y' or SD_ACTIVE = 'N';
ACTIVE = SD_ACTIVE;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0501': 'Active Status');
NoErrors = *off;
RI_SD_ACTIVE = *on;
PC_SD_ACTIVE = *on;
endsr;
//=== Edit_SD_NAME ===========================================
begsr Edit_SD_NAME;
if SD_NAME <> ' ';
NAME = SD_NAME;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Name');
NoErrors= *off;
RI_SD_NAME = *ON;
PC_SD_NAME = *ON;
endsr;
//=== Edit_SD_ADDR ===========================================
begsr Edit_SD_ADDR;
if SD_ADDR <> ' ';
ADDR = SD_ADDR;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Address');
NoErrors= *off;
RI_SD_ADDR = *ON;
PC_SD_ADDR = *ON;
endsr;
//=== Edit_SD_CITY ===========================================
begsr Edit_SD_CITY;
if SD_CITY <> ' ';
CITY = SD_CITY;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'City');
NoErrors= *off;
RI_SD_CITY = *ON;
PC_SD_CITY = *ON;
endsr;
//=== Edit_SD_STATE ==========================================
begsr Edit_SD_STATE;
exec sql select STATE into :STATE
from STATES
where STATE = :SD_STATE;
if SQLSTT = SQLSuccess;
STATE = SD_STATE;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0503');
NoErrors= *off;
RI_SD_STATE= *ON;
PC_SD_STATE = *ON;
endsr;
//=== Edit_SD_ZIP ============================================
begsr Edit_SD_ZIP;
if SD_ZIP <> ' ';
ZIP = SD_ZIP;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'ZIP');
NoErrors= *off;
RI_SD_ZIP= *ON;
PC_SD_ZIP = *ON;
endsr;
//=== Edit_SD_ACCTPH =========================================
begsr Edit_SD_ACCTPH;
if SD_ACCTPH <> ' ';
ACCTPHONE = SD_ACCTPH;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Account Manager Phone');
NoErrors= *off;
RI_SD_ACCTPH= *ON;
PC_SD_ACCTPH = *ON;
endsr;
//=== Edit_SD_ACCTMGR =========================================
begsr Edit_SD_ACCTMGR;
if SD_ACCTMGR <> ' ';
ACCTMGR = SD_ACCTMGR;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Account Manager Name');
NoErrors= *off;
RI_SD_ACCTMGR= *ON;
PC_SD_ACCTMGR = *ON;
endsr;
//=== Edit_SD_CORPPH =========================================
begsr Edit_SD_CORPPH;
if SD_CORPPH <> ' ';
CORPPHONE = SD_CORPPH;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Corporate Phone');
NoErrors= *off;
RI_SD_CORPPH= *ON;
PC_SD_CORPPH = *ON;
endsr;
//=== AddRecd ================================================
// Insert a record into the file.
// Returns: NoErrors = *on if the add was successful.
begsr AddRecd;
NoErrors = *on;
in *LOCK Cust_Next;
Cust_Next += 1;
Out Cust_Next;
CUSTID= Cust_Next;
CHGTIME = %timestamp();
CHGUSER = CURR_USER;
exec sql
insert into custmast
values(:CUSTMAST)
;
// There is no good reason why insert should fail.
if SQLSTT <> SQLSuccess;
SQLProblem('Insert into CUSTMAST ...');
endif;
endsr;
//=== UpdateRecd =============================================
// 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;
NoErrors = *on;
exec sql
update CUSTMAST
SET NAME = :SD_NAME,
ADDR = :SD_ADDR,
CITY = :SD_CITY,
STATE = :SD_STATE,
ZIP = :SD_ZIP,
CORPPHONE = :SD_CORPPH,
ACCTMGR = :SD_ACCTMGR,
ACCTPHONE = :SD_ACCTPH,
ACTIVE = :SD_ACTIVE,
CHGTIME = CURRENT TIMESTAMP,
CHGUSER = :CURR_USER
where CUSTID = :CUSTID
-- and compare timestamp
and CHGTIME = :Orig_CHGTIME;
select;
when SQLSTT = SQLNOData; // Update Failed
SflMsgSnt = SndSflMsg('DEM1002'); // Record changed, review.
NoErrors = *off;
// Show the changed data
exsr ReadRecd;
exsr FillScreenFields;
when SQLSTT =SQLRowLocked; // Row locked
sflMsgSnt = SndSflMsg('DEM1001' : SQLERRMC);
NoErrors = *off;
when SQLSTT = SQLSuccess;
other;
SQLProblem('Update CUSTMAST');
endsl;
endsr;
//=== ClearScreenData ========================================
begsr ClearScreenData;
clear DETAILS;
endsr;
//=== ProtectAll =============================================
begsr ProtectAll;
Protect_SD_ALL = *on;
endsr;
//=== UnProtectAll ===========================================
begsr UnProtectAll;
Protect_SD_ALL = *off;
endsr;
//=== ScreenIO ===============================================
// Writes and Reads the screen
begsr ScreenIO;
write SH_HDR;
write SFT_FKEY;
// Show any messages in the error subfile.
if SflMsgSnt = *on;
write MSGCTL;
endif;
exfmt Details;
// Clear most display file indicators
clear dfIndClr;
// Clear any messages in the error subfile.
if SflMsgSnt = *on;
SflMsgSnt = ClrMsgPgmQ(MainProc);
write MSGCTL;
endif;
endsr;
//=== BldFKeyText ============================================
// Build the Function key text for the bottom of the screen.
begsr BldFkeyText;
SFT_KEYS=' ';
SFT_KEYS = CatB(SFT_KEYS : F4Text);
SFT_KEYS = CatB(SFT_KEYS : F5Text);
SFT_KEYS = CatB(SFT_KEYS : F12Text);
endsr;
//=== CloseDownPgm ===========================================
// Things to do before we issue a return to the caller
begsr CloseDownPgm;
// Closing the display file may cause any subfile display in
// the caller to blank out.
endsr;
//=== Init ===================================================
// Every time initialization logic
begsr Init;
//--- Analyse parameters ---
if %parms() = 0; // Close down
if %open(MTNCUSTD);
close MTNCUSTD;
endif;
*inlr = *on;
return;
endif;
select;
when %parms() = 1;
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;
// Should never happen
endsl;
//--- Miscellaneous setup ---
MainProc = %proc();
MSGPGMQ = MainProc;
SH_PGM = PgmName;
clear CUSTMAST;
clear dfIndDS;
exsr BldFkeyText;
//--- Open display file ---
if not %open(MTNCUSTD);
open MTNCUSTD;
endif;
endsr;
/END-FREE
p Main e
//============================================================
// S u b P r o c e d u r e s
//============================================================
//=== CatB ===================================================
// 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
dcatB PI 79 varying
d ToStr 79 varying value
d AddStr 79 varying value
/FREE
if ToStr=' ';
return AddStr;
else;
return %trimr(ToStr) + ' ' + AddStr;
endif;
/END-FREE
pcatB e
p
//=== SQLProblem ===============================================
// For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by
// sending an *ESCAPE message of the supplied debugging text.
p SQLProblem B
d SQLProblem PI
d piSQLDebug 1024 varying value
//--- Local Variables ------------------------------------------
d wkSQLDebug s 1024 varying
/free
wkSQLDebug = 'SQLSTT ' + SQLSTT
+ ' << Unexpected SQL Return Code: '
+ piSQLDebug;
dump(a);
SndEscMsg(wkSqlDebug);
return;
/end-free
p SQLProblem E
//--------------------------------------------------------------
// Procedure name: SndSflMsg
// Purpose: Send a message to the Error Subfile
// Returns: *ON
// Parameter: ErrMsgId => Msg Id to Send
// Parameter: ErrMsgData => Optional Error Message Data
// 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)
// Local fields
d retField S N
d wkMsgId s 7a
d wkMsgFile s 10a
d wkMsgData s 80a varying
/FREE
if %parms >2;
wkMsgFile = ErrMsgFile;
else;
wkMsgFile = 'CUSTMSGF';
ENDIF;
if %parms > 1;
wkMsgData = ErrMsgData;
else;
wkMsgData = ' ';
ENDIF;
wkMsgId = ErrMsgId;
SNDMSGPGMQ(MainProc:
wkMsgid:
wkMsgFile:
wkMsgData);
retField = *on;
RETURN retField;
/END-FREE
p SndSflMsg E
5250_Subfile/PMTCUSTR
-987
View File
@@ -1,987 +0,0 @@
/TITLE Demo Expanding Subfile Search using SQL for IO
//=============================================================
// This is an customer master prompt/search program.
// 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
// call another program, MTNCUSTR.
//
// Parameters:
// -----------
// 1 Char 1 Type of parameter
// S - Return Selected Customer Id: 1=Select
// M - Allow maintenance: 2=Edit, F6=Add
// I - Inquiry, read only: 5=Display
// 2 Char 4 Selected customer id if parm 1 is S.
//
//=============================================================
// Program uses a full screen expanding subfile to select
// a Customer Master record.
//
// The screen layout is similar to PDM.
//
// Instead of using native IO it uses SQL to retrieve records.
//
// It is essentially without indicators. (Indicators are still
// needed to control the display file, but they all have names.)
//
// It is possible to use F4 to prompt for the State abbreviation
// when the cursor is in the ST field.
//
// F09 is a toggle to display or not display inactive Customers.
//
//=============================================================
// Naming Conventions
// ==================
// - Lower case is the default for opcodes.
// - TitleCase is used for program variables, subroutines and procedure
// names, e.g. MaxOrderQty, BldFkeyText, etc.
// - Temporary variables are prefixed with "wk", e.g., wkDate. Such
// variables contain valid data for only a short time and are never
// 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_
// Subfile Control: Fields begin with SC_
// Screen footer: Fields begin with SFT_
//=============================================================
// Compilation
// Use CRTSQLRPGI command.
// Note that /INCLUDEs expects to find code in DEMO library,
// not the default of QRPGLESRC. Change as needed.
//=============================================================
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
// File is closed when returning with LR off. This avoids an
// annoying resdisplay of the last subfile on re-entry.
//=== Service Program Prototypes ==============================
/include DEMO,Srv_Msg_P
/include DEMO,Srv_Str_P
//=== Named hexadecimal constants for function keys ===========
/include DEMO,##AIDBYTES
//=== Display File Information Data Structure =================
// Allows us to determine which function key was pressed
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
//--- 01-20 are not automatically cleared after EXFMT ----------
d scIncActInc 03 03n
//--- 21-99 automatically cleared after EXFMT ------------------
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
//--- Subfile Control indicators (prefix "sc") ---
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
// 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 F4Text c 'F4=Prompt+'
d F5Text c 'F5=Reset'
d F6Text c 'F6=Add'
d F12Text c 'F12=Cancel'
d F9Text s 25
//=== Options Text ============================================
d Opt1Text c '1=Select'
d Opt2Text c '2=Edit'
d Opt5Text c '5=Display'
//=== Screen Header Text=======================================
d HdrInq s like(SH_FUNCT)
d inz('Inquiry')
d HdrSelect s like(SH_FUNCT)
d inz('Selection')
d HdrMaint s like(SH_FUNCT)
d inz('Maintenance')
d HdrBad s like(SH_FUNCT)
d inz('-> Bad Parm 1 <-')
d
//=== Search Criteria Screen Fields ===========================
d SearchCriteria ds inz
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)
//=== SQL Search Variables ====================================
d Stmt s 1024 varying Select Statement
//=== SQL State Constants =====================================
d SQLSuccess c '00000'
d SQLNoData c '02000'
d SQLNoMoreData c '02000'
d SQLDupRecd c '23505'
d SQLRowLocked c '57033'
//== CUSTMAST - define fields for SQL =========================
// NOTE: Only the fields read by SQL are populated!
d CustMast e ds extname(CUSTMAST) template
// Records from SQL CURSOR read into CustCursor
d CustCursor ds likeds(Custmast)
// Records from SQL SELECT read into CustSelect
d CustSelect ds likeds(CustMast)
//=== External Programs Prototypes ============================
d CustDsp pr extpgm('MTNCUSTR')
d CustID options(*nopass) like(CUSTID)
d Maintain 1a options(*nopass)
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)
//=== Work Fields =============================================
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 varying
d wkCity s 13a varying
//=== 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
//=== Program Status Data Structure ===========================
d ProgStatus sds
d PgmName *PROC
//=== Program Parameters ======================================
d pParmType S 1A
d pCustID s Like(CUSTID)
//=============================================================
// === Program Starts Here ====================================
//=============================================================
c *Entry plist
c parm pParmType
c parm pCustID
/FREE
//=== Set SQL Options =========================================
exec sql set option datfmt=*iso,
closqlcsr=*endmod;
// === Set up for the first screen IO =========================
exsr Init;
exsr BldFkeyText;
SflClear();
// Force evalualtion if enter pressed with no data
NewSearchCriteria = *on;
// If we are to return a customer number, Clear the return field
// in case nothing is selected
if Opt1_OK = *on;
clear pCustID;
endif;
// If just doing inquiry, load first subfile page
if %parms() > 0;
if pParmType = 'I' ;
exsr SflFirstPage;
endif;
endif;
//=============================================================
// === Main Program Loop ======================================
//=============================================================
dou CowsComeHome;
// Set "*More" display
scSflEnd = EofData;
// Write/Read the sreen
exsr ScreenIO;
//-- Enter Key ---------------------------------------------
If Key = Enter;
// Either new Search Criteria entered or option(s) entered.
// New Search Criteria takes precedence over option(s).
if SearchCriteria <> LastSearchCriteria
or NewSearchCriteria = *on;
SflClear();
exsr SflFirstPage;
else;
exsr ProcessOption;
endif;
iter;
endif;
//--- Page Down --------------------------------------------
if Key = PageDown;
if RcdsInSfl > 0;
exsr SflFillPage;
if SflRRN = MaxSflRecds;
SflMsgSnt= SndSflMsg('DEM0006');
iter;
endif;
else;
// Key not active msg
SflMsgSnt= SndSflMsg('DEM0003');
endif;
iter;
endif;
//--- Any other entry must be a function key ---------------
exsr ProcessFunctionKey;
enddo;
//=============================================================
//=== End of Main Program Loop ================================
//=============================================================
//=== ScreenIO ================================================
// Writes and Reads the screen
begsr ScreenIO;
write SH_HDR;
write SFT_FKEY;
// Show any messages in the error subfile.
if SflMsgSnt = *on;
write MSGCTL;
endif;
// If we have records in the subfile, display them.
if RcdsInSfl > 0;
scSflDsp = *ON;
else;
scSflDsp = *OFF;
ENDIF;
// Write/read the subfile. SC_CSR_RCD contains a RRN and
// determines which page will be on the screen and where the
// cursor will be.
exfmt SFLCTL;
// Clear most display file indicators
clear dfIndClr;
// Clear any messages in the error subfile.
if SflMsgSnt = *on;
SflMsgSnt = ClrMsgPgmQ(PgmName);
write MSGCTL;
endif;
endsr;
//=== ProcessFunctionKey ======================================
// Process whatever keyboard entry was made.
// Will not return from subroutine if F3 or F12 was pressed.
// May not return from subroutine when an option is entered.
begsr ProcessFunctionKey;
select;
//--- F3: Exit, close down program -----------------------
when Key = F03;
exsr CloseDownPgm;
*inlr = *on;
return;
//--- F12: Return to caller, leave program active ---------
when Key = F12;
exsr CloseDownPgm;
return;
//--- F4: Prompt to fill the field -----------------------
when Key = F04;
// The result of a successful F4 is as if the field
// had been keyed from the screen.
select;
// --- Prompt for State Code
when SC_PMT_FLD = 'SC_STATE';
PmtState(SC_STATE);
if SC_STATE <> LastSC_STATE;
SflClear();
NewSearchCriteria = *on;
endif;
// --- Field not promptable
other;
// Use F4 only in field followed by + sign
SflMsgSnt= SndSflMsg('DEM0005');
endsl;
//--- F5: Refresh all search fields ----------------------
when Key = F05;
clear LastSearchCriteria;
clear SearchCriteria;
SflClear();
NewSearchCriteria = *on;
scIncActInc = *off;
//--- F6: Add a record. ----------------------------------
when Key = F06;
if Maint_Ok = *on;
CustDspParm = CustDspAdd;
CustDsp(wkCustId : CustDspParm);
else;
// Function key not active
SflMsgSnt= SndSflMsg('DEM0003');
endif;
//--- F9: Toggle Include InActive ------------------------
when Key = F09;
CloseCursor();
scIncActInc = not scIncActInc;
exsr BldFkeyText;
SflClear();
NewSearchCriteria = *on;
exsr SflFirstPage;
//--- Other keys: Function key not active message ---------
other;
SflMsgSnt= SndSflMsg('DEM0003');
endsl;
endsr;
//=== ProcessOption ===========================================
// Did user enter one or more options? Loop through the
// subfile and process them all.
// May not return from this subroutine for some options.
begsr ProcessOption;
if RcdsInSfl > 0;
OptError = *off;
// Don't know yet which sfl page to display next time.
SC_CSR_RCD = 0;
// Loop through changed records in the subfile.
readc SFL;
dow not %eof;
select;
//--- 1 = Select -------------------------------------
when SF_OPT = '1'
and Opt1_OK = *on;
// Return customer number to caller
pCustID = %dec(SF_CUST_H:4:0);
exsr CloseDownPgm;
return;
//--- 2 = Edit with external program -----------------
when SF_OPT = '2' and Maint_OK = *on;
wkCustId = %dec(SF_CUST_H:4:0);
CustDspParm = CustDspEdit;
CustDsp(wkCustId : CustDspParm);
// Reset Opt and leave cursor at last valid option
SF_OPT = ' ';
exsr SetCursorPosition;
// Re-read the changed record & update subfile
ReadByKey(wkCustid : CustSelect);
BuildSflRecd(CustSelect);
exsr UpdSflRecd;
//--- 5 = Display Detail with external program -------
when SF_OPT = '5';
wkCustId = %dec(SF_CUST_H:4:0);
CustDspParm = CustDspDsply;
CustDsp(wkCustId : CustDspParm);
// Reset Opt and leave cursor at last valid option
SF_OPT = ' ';
exsr SetCursorPosition;
exsr UpdSflRecd;
//--- Opt is blank -----------------------------------
when SF_OPT = ' ';
// If changed, assume clearing an error from last time
sfOPT_PC = *off;
sfOPT_RI = *off;
exsr UpdSflRecd;
//--- Other ------------------------------------------
other;
// Send message about invalid selection.
// Position cursor and page at first error.
// Always force to be read again next time & reverse image.
// Not a valid option at this time
SflMsgSnt= SndSflMsg('DEM0004':SF_OPT);
// Leave cursor at first invalid option
exsr SetCursorPosition;
optError = *on;
// SFLNXTCHG forces this record to be read again
// (even if user doesn't correct it) so we can
// check it again for validity.
sfSflNxtChg = *on;
sfOPT_RI = *on;
exsr UpdSflRecd;
// set off indicators applying to just this recd.
sfSflNxtChg = *off;
sfOPT_RI = *off;
endsl;
readc SFL;
enddo;
CustDsp(); // Closes Window DSPF & restores our subfile
endif;
// If no positioning done, display last page, cursor on 1st recd.
// (Enter with no option takes you to the last page of subfile.)
if SC_CSR_RCD = 0;
SC_CSR_RCD =
( %int( (RcdsInSfl-1) / SflPageSize )
* SflPageSize
) + 1;
endif;
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.
// 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(CustCursor);
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
// written to the subfile.
// SC_CSR_RCD contains relative record number of 1st record
// on the page & positions cursor there.
begsr SflFillPage;
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.
SC_CSR_RCD = 0;
for inx = 1 to SflPageSize;
// Build/Format the subfile record
clear SF_OPT;
BuildSflRecd(CustCursor);
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,999 records.
if SflRRN = MaxSflRecds;
EofData = *on;
SflMsgSnt= SndSflMsg('DEM0006');
leave;
endif;
EofData = FetchNextData(CustCursor);
if EofData = *on;
leave;
endIf;
endfor;
endsl;
endsr;
//=== Update Subfile Recd =====================================
begsr UpdSflRecd;
// Set on indicator based on saved SFL fields
if SF_ACT_H = 'N';
sfInAct = *on;
endif;
update SFL;
sfInAct = *off;
write DUMMY; // Supposed to help restore SFL display
endsr;
//=== ProcessSearchCriteria====================================
// Examinethe data entered in the search fields and build an
// SQL statement.
// Success:
// NewSearchCriteria is set off
// SQL Cursor is open
//
// Failure:
// NewSearchCriteria is left on
// Error message is sent to the msg sufile
// Cursor is postioned at the field in error
begsr ProcessSearchCriteria;
// Reset switches
NewSearchCriteria = *off;
// Save entered values. (Never change screen fields.)
LastSearchCriteria = SearchCriteria;
//exsr SaveSearchCriteria;
CloseCursor();
// Build select statement
// Using parameter markers protects against
// SQL injection attacks.
clear wkNAME;
clear wkCity;
Stmt = 'select NAME +
,CITY +
,STATE +
,ZIP +
,ACTIVE +
,CUSTID +
from CUSTMAST +
where NAME LIKE ? +
and CITY like ? ';
wkName = Sanatize(%trim(SC_NAME) + '%') ;
wkCity = Sanatize(%trim(SC_CITY) + '%');
if SC_STATE <> ' ';
if %len(%trim(SC_STATE)) <> 2;
NewSearchCriteria=*on;
SflMsgSnt = ClrMsgPgmQ(PgmName);
SflMsgSnt= SndSflMsg('DEM0007');
endif;
Stmt += ' and STATE =' + Quote(SC_STATE);
endif;
If scIncActInc = *off;
Stmt += ' and ACTIVE = ' + quote('Y');
endif;
stmt += ' order by NAME, CITY';
Stmt += ' optimize for 13 rows';
Stmt += ' for fetch only';
// SndInfMsg(Stmt); // Testing...
//----------------------------------------------------------
// If stmt bulit without errors open the SQL cursor
if NewSearchCriteria = *off;
exec sql prepare mySelect from :Stmt;
if SQLSTT <> SQLSuccess;
SQLProblem('Prepare mySelect');
endif;
exec sql declare ItemCur cursor for mySelect;
exec sql open ItemCur using :wkName,:wkCity ;
if SQLSTT <> SQLSuccess;
SQLProblem('Open ItemCur');
endif;
CursorOpen = *on;
endif;
endsr;
//=== SetCursorPostion ========================================
// If Invalid Option, position screen cursor on first one,
// else postion cursor on the last valid option.
begsr SetCursorPosition;
if OptError = *off;
SC_CSR_RCD=SflRRN;
endif;
endsr;
//=== BldFKeyText =============================================
// 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 : F5Text);
if pParmType = 'M';
SFT_KEYS = CatB(SFT_KEYS : F6Text);
Maint_OK = *on;
endif;
if scIncActInc = *on;
F9Text = 'F9=Exclude Inactive';
else;
F9Text = 'F9=Include Inactive';
endif;
SFT_KEYS = CatB(SFT_KEYS : F9Text);
SFT_KEYS = CatB(SFT_KEYS : F12Text);
endsr;
//=== CloseDownPgm ============================================
// Things to do before we issue a return to the caller
begsr CloseDownPgm;
CloseCursor();
close PMTCUSTD;
CustDsp(); // Close Window display file.
endsr;
//=== Init ====================================================
// Must be executed each time program is entered, because F12
// and Enter key leave with LR off.
begsr Init;
MSGPGMQ = PgmName;
SH_PGM = PgmName;
SH_FUNCT = CenterStr(HdrBad);
if not %open(PMTCUSTD);
open PMTCUSTD;
endif;
// Clear fields left over from previous F12.
reset LastSearchCriteria;
reset SearchCriteria;
scIncActInc = *off;
Maint_OK = *off;
// Put cursor in first field if inquiry
if pParmType = 'I';
SC_NAME_PC = *ON;
SH_FUNCT = CenterStr(HdrInq);
endif;
// Build options string.
// If we have a field to return customer number and we
// are doing selection, set 1=Select option.
clear SC_OPTIONS;
Opt1_OK = *off;
If pParmType = 'S' and %parms > 1;
SC_OPTIONS = Opt1Text;
Opt1_OK = *on;
SH_FUNCT = CenterStr(HdrSelect);
endif;
if pParmType = 'M';
SC_OPTIONS = CatB(SC_OPTIONS : Opt2Text);
SH_FUNCT = CenterStr(HdrMaint);
endif;
SC_OPTIONS = CatB(SC_OPTIONS : Opt5Text);
endsr;
//=============================================================
// S u b P r o c e d u r e s
//=============================================================
// === Quote ==================================================
// Sanatize and puts quotes around a string
/END-FREE
pQuote b
dQuote pi 100 varying
dStr 100 varying value
/free
return '''' + %trim(Sanatize(str)) +'''';
/END-FREE
p e
//=============================================================
// === Sanatize ===============================================
// Sanatize an entered search string field.
// - Remove any single quotes, otherwise the built SQL prepare
// will fail, or it could allow SQL Injection.
// Double quotes are OK.
pSanatize b
dSanatize pi 100 varying
dStr 100 varying value
d wkStr s like(Str)
dQuotesTwo c ''''''
dQuotesOne c ''''
/free
wkSTR = %scanrpl(QuotesTwo:x'ff':Str);
wkStr = %scanrpl(QuotesOne:'':wkStr);
wkStr = %scanrpl(x'ff':QuotesTwo:wkStr);
return wkStr;
/END-FREE
p e
//=== CatB ====================================================
// 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
dCatB PI 79 varying
d ToStr 79 varying value
d AddStr 79 varying value
/FREE
if ToStr=' ';
return AddStr;
else;
return %trimr(ToStr) + ' ' + AddStr;
endif;
/END-FREE
pCatB e
//=== SQLProblem ==============================================
// For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by
// sending an *ESCAPE message of the supplied debugging text.
p SQLProblem B
d SQLProblem PI
d piSQLDebug 1024 varying value
//--- Local Variables ----------------------------------------
d wkSQLDebug s 1024 varying
/free
wkSQLDebug = 'SQLSTT ' + SQLSTT
+ ' << Unexpected SQL Return Code: '
+ piSQLDebug;
dump(a);
SndEscMsg(wkSqlDebug);
return;
/end-free
p SQLProblem E
//=== FetchNextData ===========================================
// Fetch the next row from the cursor
// Returns: End of data Indicator:
// *ON No more data, nothing returned
// *OFF Data returned
//------------------------------------------------------------
p FetchNextData B
d FetchNextData PI N
d TheRecd likeds(Custmast)
// Local fields
d wkEof S N
/FREE
wkEoF= *off;
exec sql fetch ItemCur into
:TheRecd.NAME,
:TheRecd.CITY,
:TheRecd.STATE,
:TheRecd.ZIP,
:TheRecd.ACTIVE,
:TheRecd.CUSTID
;
select;
when SQLSTT = SQLSuccess;
wkEof = *off;
when SQLSTT = SQLNoMoreData;
wkEof = *on;
Other;
SQLProblem('Fetch ITEMCUR');
endsl;
RETURN wkEof;
/END-FREE
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)
/FREE
exec sql select
NAME,
CITY,
STATE,
ZIP,
ACTIVE,
CUSTID
into
:TheRecd.NAME,
:TheRecd.CITY,
:TheRecd.STATE,
:TheRecd.ZIP,
:TheRecd.ACTIVE,
:TheRecd.CUSTID
from CUSTMAST
where CUSTID = :TheKey
;
/END-FREE
p ReadByKey E
//=== BuildSFLRecd ============================================
// Builds a SFL record from the specified data record
p BuildSflRecd b
d BuildSflRecd PI
d CustRecd likeds(CUSTMAST)
/FREE
SF_NAME = CustRecd.NAME;
SF_CITY = CustRecd.CITY;
SF_STATE = CustRecd.STATE;
SF_ZIP = CustRecd.ZIP;
// Save Id in case we need it for 5=Display
SF_CUST_H = %editc(CustRecd.CUSTID:'3');
// Change color if record is inactive
if CustRecd.ACTIVE = 'N';
sfInAct = *on;
else;
sfInAct= *off;
endif;
// Save Active status in case we update subfile
SF_ACT_H = CustRecd.ACTIVE;
/END-FREE
p BuildSFLRecd E
//=== Procedure name: CloseCurssor ============================
// Closes the SQL Cursor if open
//------------------------------------------------------------
p CloseCursor B
d CloseCursor PI
// Local fields
//CursorOpen s n static
/FREE
if CursorOpen = *on;
exec sql close ItemCur;
if SQLSTT <> SQLSuccess;
SQLProblem('Close ITEMCUR');
endif;
CursorOpen = *off;
endif;
RETURN;
/END-FREE
p CloseCursor E
//=== SndSflMsg ===============================================
// Send a message to the Error Subfile
// Returns: *ON
// Parameter: ErrMsgId => Msg Id to Send
// Parameter: ErrMsgData => Optional Error Message Data
// 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)
// Local fields
d retField S N
d wkMsgId s 7a
d wkMsgFile s 10a
d wkMsgData s 80a varying
/FREE
if %parms >2;
wkMsgFile = ErrMsgFile;
else;
wkMsgFile = 'CUSTMSGF';
ENDIF;
if %parms > 1;
wkMsgData = ErrMsgData;
else;
wkMsgData = ' ';
ENDIF;
wkMsgId = ErrMsgId;
SNDMSGPGMQ(PgmName:
wkMsgid:
wkMsgFile:
wkMsgData);
retField = *on;
RETURN retField;
/END-FREE
p SndSflMsg E
//=== SflClear ================================================
// Clears the Subfile
//------------------------------------------------------------
p SflClear B
d SflClear PI
/FREE
clear SflRRN;
clear RcdsInSfl;
scSflClr = *ON;
write SFLCTL;
scSflClr = *OFF;
return;
/END-FREE
p SflClear E
5250_Subfile/PMTSTATER
-701
View File
@@ -1,701 +0,0 @@
/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.
// Optionally can select and return a 2-char code.
//
// Parameters
// ----------
// Out CL2 Selected 2-Char State Code (optional)
//
//===============================================================
// Program is essentially without indicators. (Indicators are
// stil lneeded to control the display file, but all have names.)
//
// Naming Conventions
// ==================
// - Lower case is the default for opcodes.
// - TitleCase is used for program variables, subroutines and procedure
// names, e.g. MaxOrderQty, BldFkeyText, etc.
// - Temporary variables are prefixed with "wk", e.g., wkDate. Such
// variables contain valid data for only a short time and are never
// 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_
// Subfile Control: Fields begin with SC_
// Screen footer: Fields begin with SFT_
//===============================================================
// Compilation
// Use CRTSQLRPGI command.
// Note that /INCLUDEs expects to find code in DEMO library,
// not the default of QRPGLESRC. Change as needed.
//=============================================================
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
d Main pr extpgm('PMTSTATER')
d ReturnState 2A
//=== Service Program Prototypes ================================
/include DEMO,Srv_Msg_P
//=== Named hexadecimal constants for function keys =============
/include DEMO,##AIDBYTES
//=== 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 FetchData ds likeds(STATES)
//=== SQL State Constants =======================================
d SQLSuccess c '00000'
d SQLNoData c '02000'
d SQLNoMoreData c '02000'
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
//=== Display File Indicator Data Structure =====================
// This is a "private" indicator area for the display file.
d dfIndDS ds 99
//--- 01-20 are not automatically cleared after EXFMT ----------
d scCodeHi 01 01
d scNameHi 02 02
//--- 21-99 automatically cleared after EXFMT ------------------
d dfIndClr 21 99
//--- Subfile indicators (prefix "sf") -------------------------
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
//=== Fields to control the subfile screen ======================
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 MainProc S 10a
//=== Text for function keys ====================================
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(' ')
//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 ==============================================
d Opt1Text c '1=Select'
//=== Search Criteria Screen Fields =============================
d SearchCriteria ds inz
d SC_NAME
//=== Last Search Criteria Fields ===============================
d LastSearchCriteria...
d ds inz
d LastSC_NAME Like(SC_NAME)
//=== SQL Search Variables ======================================
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 Opt1OK s n
d OptError s n
d CowsComeHome c const('0')
//=== Work Fields ===============================================
d inx s 10i 0
//=============================================================
//== Program Starts Here ======================================
//=============================================================
p Main b
d Main pi
d pState Like(FetchData.STATE)
/FREE
exsr Init;
exsr BldFkeyText;
//=== Set SQL Options =========================================
exec sql set option datfmt=*iso,
closqlcsr=*endmod;
//=== SQL Cursor Definitions ==================================
// Sort Order is controlled by field SQLSortSeq which is
// used in a CASE statement.
exec SQL
declare DataCur cursor for
select
STATE,
NAME
from STATES
where upper(NAME) like :DescLike
order by case :SQLSortSeq
when :SortByName then NAME
when :SortByCode then STATE
else '1'
end
for fetch only;
// === Initial screen display =================================
write SH_HDR;
SflClear();
exsr ProcessSearchCriteria;
exsr SflLoadAll;
//=============================================================
// === Main Program Loop ======================================
//=============================================================
dou CowsComeHome;
// Put the last search criteria back on the screen.
SearchCriteria = LastSearchCriteria;
// Set "*More" display
scSflEnd = EofData;
// If switching display order, reload first page
if Key = F07;
exsr ProcessSearchCriteria;
exsr SflLoadAll;
endif;
// Write/Read the screen
exsr ScreenIO;
//-- Enter Key --------------------------------------------
If Key = Enter;
// Either new Search Criteria entered or option(s) entered.
// New Search Criteria takes precedence over option(s).
if SearchCriteria <> LastSearchCriteria
or NewSearchCriteria = *on;
SflClear();
exsr ProcessSearchCriteria;
exsr SflLoadAll;
else;
exsr ProcessOption;
endif;
iter;
endif;
//--- Any other entry must be a function key ---------------
exsr ProcessFunctionKey;
enddo;
//=============================================================
//=== End of Main Program Loop ================================
//=============================================================
//=== ScreenIO ================================================
// Writes and Reads the screen
begsr ScreenIO;
write SH_HDR;
write SFT_FKEY;
// Show any messages in the error subfile.
if SflMsgSnt = *on;
write MSGCTL;
endif;
// If we have records in the subfile, display them.
if RcdsInSfl > 0;
scSflDsp = *ON;
else;
scSflDsp = *OFF;
ENDIF;
// Write/read the subfile. SC_CSR_RCD contains a RRN and
// determines which page will be on the screen and where the
// cursor will be.
exfmt SFLCTL;
// Clear most display file indicators
clear dfIndClr;
// Clear any messages in the error subfile.
if SflMsgSnt = *on;
SflMsgSnt = ClrMsgPgmQ(MainProc);
write MSGCTL;
endif;
endsr;
//=== ProcessFunctionKey ======================================
// Process whatever keyboard entry was made.
// Will not return from subroutine if F3 or F12 was pressed.
// May not return from subroutine when an option is entered.
begsr ProcessFunctionKey;
select;
//--- F3: Exit, close down program -----------------------
when Key = F03;
exsr CloseDownPgm;
*inlr = *on;
return;
//--- F12: Return to caller, leave program active ---------
when Key = F12;
exsr CloseDownPgm;
return;
//--- F5: Refresh all search fields ----------------------
when Key = F05;
clear LastSearchCriteria;
NewSearchCriteria = *on;
SflClear();
//--- F7: Toggle Sort Sequence ---------------------------
when Key = F07;
if SQLSortSeq=SortByName;
SQLSortSeq = SortByCode;
SC_SORTED = SortByCode;
scCodeHi = *on;
scNameHi = *off;
F7Text2 = SortByName;
else;
SQLSortSeq = SortByName;
SC_SORTED = SortByName;
scNameHi = *on;
scCodeHI = *off;
F7Text2 = SortbyCode;
endif;
F7Text = F7Text1 + F7Text2;
exsr BldFkeyText;
NewSearchCriteria = *on;
SflClear();
//--- Other keys: Function key not active message ---------
other;
SflMsgSnt= SndSflMsg('DEM0003');
endsl;
endsr;
//=== ProcessOption ===========================================
// Did user enter an option? If so, process it.
// May not return from this subroutine.
begsr ProcessOption;
if RcdsInSfl > 0;
OptError = *off;
// Don't know yet which page to display next time.
SC_CSR_RCD = 0;
// Loop through changed records in the subfile.
readc SFL;
dow not %eof;
select;
//--- 1 = Select ------------------------------------------
when SF_OPT = '1' and Opt1OK;
// 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
sfOPT_PC = *off;
sfOPT_RI = *off;
update SFL;
//--- Other -----------------------------------------------
other;
// Send message about invalid selection.
// Position cursor and page at first error.
// Always force to be read again next time & reverse image.
// Not a valid option at this time
SflMsgSnt= SndSflMsg('DEM0004':SF_OPT);
// Leave cursor at first invalid option
exsr SetScreenCursorPosition;
optError = *on;
// SFLNXTCHG forces this record to be read again
// even if user doesn't correct it, so we can
// check it again for validity.
sfSflNxtChg = *on;
sfOPT_RI = *on;
update SFL;
// set off indicators applying to just this recd.
sfSflNxtChg = *off;
sfOPT_RI = *off;
endsl;
readc SFL;
enddo;
endif;
// If no positioning done, display last page, cursor on 1st recd.
// (Enter with no option takes you to the last page of subfile.)
if SC_CSR_RCD = 0;
SC_CSR_RCD =
( %int( (RcdsInSfl-1) / SflPageSize )
* SflPageSize
) + 1;
endif;
endsr;
//=== SflLoadAll ==============================================
// Loads all selected records to the subfile.
// Returns:
// 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 SflLoadAll;
// Position cursor at first record on the subfile page.
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;
write SFL;
// Can't display more than 9,9999 records.
if SflRRN = SflMaxRecd;
EofData = *on;
SflMsgSnt= SndSflMsg('DEM0006');
leave;
endif;
endfor;
endsr;
//=== ProcessSearchCriteria====================================
// Examines the data entered in the search fields and sets up
// variables used in the SQL Cursor.
//
// Success:
// NewSearchCriteria is set off
// SQL Cursor is open
//
// Failure:
// NewSearchCriteria is left on
// Error message is sent to the msg sufile
// Cursor is postioned at the field in error
begsr ProcessSearchCriteria;
// Reset switches
NewSearchCriteria = *off;
// Save entered values. (Never change screen fields.)
LastSearchCriteria = SearchCriteria;
CloseCursor();
//---------------------------------------------------------------
if SC_NAME = ' ';
// Not searching, take all
DESCLike = '%%';
else;
DESCLike = '%' + %trim(SC_NAME) + '%';
endif;
//---------------------------------------------------------------
// If no errors in search criteria, open the SQL cursor
if NewSearchCriteria = *off;
exec sql open DataCur;
if SQLSTT <> SQLSuccess;
SQLProblem('Open DataCur');
endif;
CursorOpen = *on;
endif;
endsr;
//=== SetCursorPostion ========================================
// If Invalid Option, position screen cursor on first one,
// else postion cursor on the last valid option.
begsr SetScreenCursorPosition;
if OptError = *off;
SC_CSR_RCD=SflRRN;
endif;
endsr;
//=== BldFKeyText =============================================
// 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 : F5Text);
SFT_KEYS = CatB(SFT_KEYS : F7Text);
SFT_KEYS = CatB(SFT_KEYS : F12Text);
endsr;
//=== CloseDownPgm ============================================
// 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
begsr Init;
SQLSortSeq = SortByName;
SC_SORTED = SortByName;
scNameHi = *on; // Name highlighted
scCodeHi = *off;
F7Text2 = SortByCode;
F7Text = F7Text1 + F7Text2;
//--- Analyse parameters ---
Opt1OK = *off;
if %parms() > 0;
Opt1OK = *on;
endif;
// Set up for subfile message queue
MainProc = %proc();
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;
// Build options string.
clear SC_OPTIONS;
if Opt1OK;
SC_OPTIONS = Opt1Text;
endif;
endsr;
p Main e
//=============================================================
// S u b P r o c e d u r e s
//=============================================================
//=== CatB ====================================================
// 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
/FREE
if ToStr=' ';
return AddStr;
else;
return %trimr(ToStr) + ' ' + AddStr;
endif;
/END-FREE
pCatB e
// === SQLProblem ================================================
// For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by
// sending an *ESCAPE message of the supplied debugging text.
p SQLProblem B
d SQLProblem PI
d piSQLDebug 1024 varying value
//--- Local Variables ---------------------------------
d wkSQLDebug s 1024 varying
/free
wkSQLDebug = 'SQLSTT ' + SQLSTT
+ ' << Unexpected SQL Return Code: '
+ piSQLDebug;
dump(a);
SndEscMsg(wkSqlDebug);
return;
/end-free
p SQLProblem E
//--------------------------------------------------
// Procedure name: FetchNextData
// Purpose: Fetch the next row from the cursor
// Returns: End of data Indicator:
// *ON No more data, nothing returned
// *OFF Data returned
//--------------------------------------------------
p FetchNextData B
d FetchNextData PI N
// Local fields
d wkEof S N
/FREE
wkEoF= *off;
exec sql fetch DataCur into
:FetchData.STATE,
:FetchData.NAME
;
select;
when SQLSTT = SQLSuccess;
wkEof = *off;
when SQLSTT = SQLNoMoreData;
wkEof = *on;
Other;
SQLProblem('Fetch DATACUR');
endsl;
RETURN wkEof;
/END-FREE
p FetchNextData E
//--------------------------------------------------
// Procedure name: SndSflMsg
// Purpose: Send a message to the Error Subfile
// Returns: *ON
// Parameter: ErrMsgId => Msg Id to Send
// Parameter: ErrMsgData => Optional Error Message Data
// 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)
// Local fields
d retField S N
d wkMsgId s 7a
d wkMsgFile s 10a
d wkMsgData s 80a varying
/FREE
if %parms >2;
wkMsgFile = ErrMsgFile;
else;
wkMsgFile = 'CUSTMSGF';
ENDIF;
if %parms > 1;
wkMsgData = ErrMsgData;
else;
wkMsgData = ' ';
ENDIF;
wkMsgId = ErrMsgId;
SNDMSGPGMQ(MainProc:
wkMsgid:
wkMsgFile:
wkMsgData);
retField = *on;
RETURN retField;
/END-FREE
p SndSflMsg E
//--------------------------------------------------
// Procedure name: CloseCurssor
// Purpose: Closes the SQL Cursor
//--------------------------------------------------
p CloseCursor B
d CloseCursor PI
/FREE
if CursorOpen = *on;
exec sql close DataCur;
if SQLSTT <> SQLSuccess;
SQLProblem('Close DATACUR');
endif;
CursorOpen = *off;
endif;
RETURN;
/END-FREE
p CloseCursor E
//--------------------------------------------------
// Procedure name: SflClear
// Purpose: Clears the Subfile
// Returns:
//--------------------------------------------------
p SflClear B
d SflClear PI
/FREE
clear SflRRN;
clear RcdsInSfl;
scSflClr = *ON;
write SFLCTL;
scSflClr = *OFF;
return;
/END-FREE
p SflClear E