2021-10-07 11:54:01 -04:00

702 lines
24 KiB
Plaintext

/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 copy_mbrs,Srv_Msg_P
//=== Named hexadecimal constants for function keys =============
/include copy_mbrs,##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