/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