**FREE /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. //============================================================= ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt) bnddir('UTIL_BND': 'ADRVAL_BND': 'SRV_BASE36') main(Main); //=== Display File ============================================= dcl-f MTNCUSTD workstn infds(dfInfDS) indds(dfIndDS) usropn; //=== Service Program Prototypes =============================== /include ../Copy_Mbrs/SRV_MSG_P.RPGLE /include ../Copy_Mbrs/SRV_STR_P.RPGLE /include ../Copy_Mbrs/USADRVAL_P.RPGLE /include ../Copy_Mbrs/BASE36_P.RPGLE //=== Named hexadecimal constants for function keys ============ /include ../Copy_Mbrs/AIDBYTES.RPGLE //=== USAdrVal Paramter DS ====================================== /include ../Copy_Mbrs/USADRVALDS.RPGLE dcl-ds AdrIn likeds (USAdrValDS); dcl-ds AdrOut likeds (USAdrValDS); //=== Fields read by SQL ======================================== // NOTE: Only the fields in the SQL statement are populated! dcl-ds CUSTMAST extname('CUSTMAST') end-ds; //=== SQL State Constants ====================================== dcl-c SQLSUCCESS '00000'; dcl-c SQLNODATA '02000'; dcl-c SQLNOMOREDATA '02000'; dcl-c SQLDUPRECD '23505'; dcl-c SQLROWLOCKED '57033'; //=== Display File Information Data Structure ================== // Allows us to determine which function key was pressed dcl-ds dfInfDS; Key char(1) pos(369); end-ds; //=== Display File Indicator Data Structure ==================== // This is a "private" indicator area for the display file. //--- 01-20 are not automatically cleared after EXFMT ---------- dcl-ds dfIndDS len(99); //--- 21-99 are automatically cleared after EXFMT -------------- Protect_SD_ALL ind pos(10); dfIndClr char(79) pos(21); RI_SD_ACTIVE ind pos(40); PC_SD_ACTIVE ind pos(41); RI_SD_NAME ind pos(42); PC_SD_NAME ind pos(43); RI_SD_ADDR ind pos(44); PC_SD_ADDR ind pos(45); RI_SD_CITY ind pos(46); PC_SD_CITY ind pos(47); RI_SD_STATE ind pos(48); PC_SD_STATE ind pos(49); RI_SD_ZIP ind pos(50); PC_SD_ZIP ind pos(51); RI_SD_ACCTPH ind pos(52); PC_SD_ACCTPH ind pos(53); RI_SD_ACCTMGR ind pos(54); PC_SD_ACCTMGR ind pos(55); RI_SD_CORPPH ind pos(56); PC_SD_CORPPH ind pos(57); DSP_SD_STAMP ind pos(61); end-ds; //=== Screen Header Text ======================================= dcl-s H2TextE like(sh_funct) inz('Change Customer'); dcl-s H2TextA like(sh_funct) inz('Add Customer'); dcl-s H2TextD like(sh_funct) inz('Displaying Customer'); //=== Text for function keys =================================== dcl-c F3TEXT 'F3=Exit'; dcl-c F4TEXT 'F4=Prompt+'; dcl-c F5TEXT 'F5=Refresh'; dcl-c F12TEXT 'F12=Cancel'; //=== External Programs Prototypes ============================= dcl-pr PmtState extpgm('PMTSTATER'); *n like(state); // TheState end-pr; //=== Global Switches ========================================== dcl-c COWSCOMEHOME const('0'); dcl-c DISPLAYING const('D'); dcl-c EDITING const('E'); dcl-c ADDING const('A'); dcl-s SflMsgSnt ind; dcl-s Function char(1); dcl-s NoErrors ind; // === Global Fields =========================================== dcl-s Orig_CHGTIME timestamp; // === Next available customer number ========================== dcl-s Cust_Next char(4) dtaara('CUSTNEXT'); dcl-s varCust_Next varchar(4); //=== Program Status Data Structure ============================ dcl-ds ProgStatus PSDS; PgmName *PROC; CURR_USER char(10) pos(358); // * Current user end-ds; dcl-s MainProc char(10); //============================================================== //============================================================== // === Program Starts Here ===================================== //============================================================== dcl-proc Main; dcl-pi Main; pID like(custid); pMaintain char(1); end-pi; //=== 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; // Address exsr Edit_Address; 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 Address =========================================== begsr Edit_Address; clear AdrIn; AdrIn.Address2 = SD_ADDR; AdrIn.City = SD_CITY; AdrIn.State = SD_STATE; AdrIn.Zip5 = %subst(SD_ZIP :1 :5); AdrOut = USAdrVal(AdrIn); // Good address-copy from USPS data & return if (AdrOut.City <> ' '); ADDR = AdrOut.Address2; CITY = AdrOut.City; STATE = AdrOut.State; if (AdrOut.Zip4 <> ' '); ZIP = AdrOut.Zip5 + '-' + AdrOut.Zip4; else; ZIP = AdrOut.Zip5; endif; leavesr; endif; // Bad address-send USPS error message SflMsgSnt = SndSflMsg('DEM9898' : AdrOut.Description); NoErrors = *off; PC_SD_ADDR = *ON; RI_SD_ADDR = *ON; RI_SD_CITY = *ON; RI_SD_STATE= *ON; RI_SD_ZIP= *ON; 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; varCust_Next = Cust_Next; varCust_Next = BASE36ADD(varCust_Next); Cust_Next = varCust_Next; 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-proc; //============================================================ // 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. dcl-proc catB; dcl-pi catB varchar(79); ToStr varchar(79) value; AddStr varchar(79) value; end-pi; if (ToStr=' '); return AddStr; else; return %trimr(ToStr) + ' ' + AddStr; endif; end-proc; //=== 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. dcl-proc SQLProblem; dcl-pi SQLProblem; piSQLDebug varchar(1024) value; end-pi; //--- Local Variables ------------------------------------------ dcl-s wkSQLDebug varchar(1024); wkSQLDebug = 'SQLSTT ' + SQLSTT + ' << Unexpected SQL Return Code: ' + piSQLDebug; dump(a); SndEscMsg(wkSQLDebug); return; end-proc; //-------------------------------------------------------------- // 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 //-------------------------------------------------------------- dcl-proc SndSflMsg; dcl-pi SndSflMsg ind; ErrMsgId char(7) const; ErrMsgData char(512) const options(*nopass:*varsize); ErrMsgFile char(10) const options(*nopass); end-pi; // Local fields dcl-s retField ind; dcl-s wkMsgId char(7); dcl-s wkMsgFile char(10); dcl-s wkMsgData varchar(512); 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-proc;