**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.//=============================================================// 12/2023 Convert to totally **FREE// 02/2024 Change CUSTID to character for alpha-numeric keys//=============================================================ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt) bnddir('UTIL_BND':'SRV_BASE36') ;// === Program parameters ====================================dcl-pi *n; pID like(custid); pMaintain char(1);end-pi;//=== 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/BASE36_P.RPGLE//=== Named hexadecimal constants for function keys ============/INCLUDE ../Copy_Mbrs/AIDBYTES.RPGLE//=== Fields read by SQL ========================================// NOTE: Only the fields in the SQL statement are populated!dcl-ds CUSTMAST_ds 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 presseddcl-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');//=== External Programs Prototypes =============================dcl-pr PmtState extpgm('PMTSTATER'); *n like(state); // TheStateend-pr;//=== Global Switches ==========================================dcl-s SflMsgSnt ind;dcl-c COWSCOMEHOME const('0');dcl-s Function char(1);dcl-c DISPLAYING const('D');dcl-c EDITING const('E');dcl-c ADDING const('A');dcl-s NoErrors ind;// === Global Fields ===========================================dcl-s Orig_CHGTIME timestamp;//=== Work Fields ==============================================dcl-s wkInt int(10);dcl-s wkMsgText varchar(256);// === Next available customer number ==========================// CUSTNEXT ds dtaara(CUSTNEXT)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 userend-ds;dcl-s MainProc char(10);//==============================================================//==============================================================// === Program Starts Here =====================================//==============================================================//=== Set SQL Options ===============================exec sql set option datfmt=*iso, closqlcsr=*endmod, commit = *NONE;//=== 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 happenendsl;//=== Misc Initialization ====================================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; ReadRecd(); if SQLSTT = SQLNODATA; SQLProblem('Calling error 1: Function parm passed does not exist.'); endif; FillScreenFields(); // All Fields protected ProtectAll(); ScreenIO(); CloseDownPgm(); return; // ======================================================= // === Updating an existing Customer ===================== // ======================================================= when Function = EDITING; ReadRecd(); if SQLSTT = SQLNODATA; SQLProblem('Calling error 2: Function parm passed does not exist.'); endif; FillScreenFields(); // Write/read screen until all data is valid, // then re-display for confirmation to update. dou NoErrors; ScreenIO(); select; when Key = F12; CloseDownPgm(); return; when Key = F05; ReadRecd(); if SQLSTT = SQLNODATA; // Record vanished! SflMsgSnt= SndSflMsg('DEM0599'); //Delete, redo search clear CUSTMAST_ds; endif; NoErrors = *off; when Key = F04; F04Prompt(); when Key = Enter; EditUpdData(); if NoErrors; // Re-display screen fields for confirmation ProtectAll(); FillScreenFields(); SflMsgSnt = SndSflMsg('DEM0000'); // Enter to update ... ScreenIO(); select; when Key = F12 or Key = F05; // Loop again when Key = Enter; UpdateRecd(); if NoErrors; CloseDownPgm(); // Success! Exit program return; endif; other; SflMsgSnt = SndSflMsg('DEM0003'); // Key not active NoErrors = *off; endsl; endif; // If NoErrors // Open up fields for correction of errors UnProtectAll(); other; SflMsgSnt = SndSflMsg('DEM0003'); // Key not active NoErrors = *off; // Stay in dou NoErrors endsl; enddo; // DOU NoErrors // ======================================================= // === Adding a new Customer ============================= // ======================================================= when Function=ADDING; clear CUSTMAST_ds; //Default status to active ACTIVE = 'Y'; FillScreenFields(); dou NoErrors; // Write/read screen until all data is valid, // then re-display for confirmation to update. // All fields can be keyed UnProtectAll(); ScreenIO(); select; when Key = F12; CloseDownPgm(); return; when Key = F04; F04Prompt(); when Key = F05; clear CUSTMAST_ds; ACTIVE = 'Y'; FillScreenFields(); when Key = Enter; EditAddData(); if NoErrors; // Re-display field for confirmation ProtectAll(); SflMsgSnt = SndSflMsg('DEM0009'); // Enter to add ... FillScreenFields(); ScreenIO(); select; when Key=F12; FillScreenFields(); when Key = Enter; AddRecd(); if NoErrors; CloseDownPgm(); return; endif; other; SflMsgSnt = SndSflMsg('DEM0003'); // Key not active NoErrors = *off; endsl; endif; // if NoErrors other; SflMsgSnt = SndSflMsg('DEM0003'); // Key not active endsl; enddo; // DOU NoErrors other; // ======================================================= //=== Goofed - Should ever happen ======================== // ======================================================= dump(a); SflMsgSnt = SndSflMsg('DEM9999'); // Contact IT now ... return; endsl;enddo; // DOU CoswComeHomeCloseDownPgm(); // Should never happenreturn;//============================================================//=== End of Main Program Loop ===============================//============================================================return;//=== ReadRecd ===============================================Dcl-Proc ReadRecd; exec sqlselect CUSTID ,NAME ,ADDR ,CITY ,STATE ,ZIP ,CORPPHONE ,ACCTMGR ,ACCTPHONE ,ACTIVE ,CHGTIME ,CHGUSERinto :CUSTMAST_dsfrom CUSTMASTwhere CUSTID = :pID ; if SQLSTT <> SQLSUCCESS and SQLSTT <> SQLNODATA; SQLProblem('ReadRecd'); endif; Orig_CHGTIME = CHGTIME; // Save for update comparisonEnd-Proc;//=== FillScreenFields =======================================Dcl-Proc 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;End-Proc;//=== 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-editDcl-Proc 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 againEnd-Proc;//=== 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.Dcl-Proc EditUpdData; NoErrors = *on;// ACTIVE Status Edit_SD_ACTIVE(); if NoErrors = *off; return; endif;// Name Edit_SD_NAME(); if NoErrors = *off; return; endif;// Addr Edit_SD_ADDR(); if NoErrors = *off; return; endif;// City Edit_SD_CITY(); if NoErrors = *off; return; endif;// State Edit_SD_STATE(); if NoErrors = *off; return; endif;// ZIP Edit_SD_ZIP(); if NoErrors = *off; return; endif;// Account Phone Edit_SD_ACCTPH(); if NoErrors = *off; return; endif;// Account Manager Edit_SD_ACCTMGR(); if NoErrors = *off; return; endif;// Corporate Phone Edit_SD_CORPPH(); if NoErrors = *off; return; endif;End-Proc;//=== 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.Dcl-Proc EditAddData; // For this program. same data for edit and add. EditUpdData();End-Proc;//=== Edit_SD_ACTIVE==========================================Dcl-Proc Edit_SD_ACTIVE; if SD_ACTIVE = 'Y' or SD_ACTIVE = 'N'; ACTIVE = SD_ACTIVE; return; endif; SflMsgSnt = SndSflMsg('DEM0501': 'Active Status'); NoErrors = *off; RI_SD_ACTIVE = *on; PC_SD_ACTIVE = *on;End-Proc;//=== Edit_SD_NAME ===========================================Dcl-Proc Edit_SD_NAME; if SD_NAME <> ' '; NAME = SD_NAME; return; endif; SflMsgSnt = SndSflMsg('DEM0502': 'Name'); NoErrors= *off; RI_SD_NAME = *ON; PC_SD_NAME = *ON;End-Proc;//=== Edit_SD_ADDR ===========================================Dcl-Proc Edit_SD_ADDR; if SD_ADDR <> ' '; ADDR = SD_ADDR; return; endif; SflMsgSnt = SndSflMsg('DEM0502': 'Address'); NoErrors= *off; RI_SD_ADDR = *ON; PC_SD_ADDR = *ON;End-Proc;//=== Edit_SD_CITY ===========================================Dcl-Proc Edit_SD_CITY; if SD_CITY <> ' '; CITY = SD_CITY; return; endif; SflMsgSnt = SndSflMsg('DEM0502': 'City'); NoErrors= *off; RI_SD_CITY = *ON; PC_SD_CITY = *ON;End-Proc;//=== Edit_SD_STATE ==========================================Dcl-Proc Edit_SD_STATE; exec sql select STATE into :STATE from STATES where STATE = :SD_STATE; if SQLSTT = SQLSUCCESS; STATE = SD_STATE; return; endif; SflMsgSnt = SndSflMsg('DEM0503'); NoErrors= *off; RI_SD_STATE= *ON; PC_SD_STATE = *ON;End-Proc;//=== Edit_SD_ZIP ============================================Dcl-Proc Edit_SD_ZIP; if SD_ZIP <> ' '; ZIP = SD_ZIP; return; endif; SflMsgSnt = SndSflMsg('DEM0502': 'ZIP'); NoErrors= *off; RI_SD_ZIP= *ON; PC_SD_ZIP = *ON;End-Proc;//=== Edit_SD_ACCTPH =========================================Dcl-Proc Edit_SD_ACCTPH; if SD_ACCTPH <> ' '; ACCTPHONE = SD_ACCTPH; return; endif; SflMsgSnt = SndSflMsg('DEM0502': 'Account Manager Phone'); NoErrors= *off; RI_SD_ACCTPH= *ON; PC_SD_ACCTPH = *ON;End-Proc;//=== Edit_SD_ACCTMGR =========================================Dcl-Proc Edit_SD_ACCTMGR; if SD_ACCTMGR <> ' '; ACCTMGR = SD_ACCTMGR; return; endif; SflMsgSnt = SndSflMsg('DEM0502': 'Account Manager Name'); NoErrors= *off; RI_SD_ACCTMGR= *ON; PC_SD_ACCTMGR = *ON;End-Proc;//=== Edit_SD_CORPPH =========================================Dcl-Proc Edit_SD_CORPPH; if SD_CORPPH <> ' '; CORPPHONE = SD_CORPPH; return; endif; SflMsgSnt = SndSflMsg('DEM0502': 'Corporate Phone'); NoErrors= *off; RI_SD_CORPPH= *ON; PC_SD_CORPPH = *ON;End-Proc;//=== AddRecd ================================================// Insert a record into the file.// Returns: NoErrors = *on if the add was successful.Dcl-Proc 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_ds) ; // There is no good reason why insert should fail. if SQLSTT <> SQLSUCCESS; SQLProblem('Insert into CUSTMAST ...'); endif;End-Proc;//=== 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.Dcl-Proc 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; SflMsgSnt = SndSflMsg('DEM1002'); // Record changed, review. NoErrors = *off; // Show the changed data ReadRecd(); FillScreenFields(); when SQLSTT =SQLROWLOCKED; // Row locked SflMsgSnt = SndSflMsg('DEM1001' : SQLERRMC); NoErrors = *off; when SQLSTT = SQLSUCCESS; other; SQLProblem('Update CUSTMAST'); endsl;End-Proc;//=== ClearScreenData ========================================Dcl-Proc ClearScreenData; clear DETAILS;End-Proc;//=== ProtectAll =============================================Dcl-Proc ProtectAll; Protect_SD_ALL = *on;End-Proc;//=== UnProtectAll ===========================================Dcl-Proc UnProtectAll; Protect_SD_ALL = *off;End-Proc;//=== ScreenIO ===============================================// Writes and Reads the screenDcl-Proc 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;End-Proc;//=== BldFKeyText ============================================// Build the Function key text for the bottom of the screen.Dcl-Proc BldFkeyText;//=== Text for function keys =================================== dcl-c F3TEXT 'F3=Exit'; dcl-c F4TEXT 'F4=Prompt+'; dcl-c F5TEXT 'F5=Refresh'; dcl-c F12TEXT 'F12=Cancel'; SFT_KEYS=' '; SFT_KEYS = catB(SFT_KEYS : F4TEXT); SFT_KEYS = catB(SFT_KEYS : F5TEXT); SFT_KEYS = catB(SFT_KEYS : F12TEXT);End-Proc;//=== CloseDownPgm ===========================================// Things to do before we issue a return to the callerDcl-Proc CloseDownPgm;// Closing the display file may cause any subfile display in// the caller to blank out.End-Proc;//=== Init ===================================================// Every time initialization logicDcl-Proc Init;//--- Miscellaneous setup --- // MainProc = %proc(); MainProc = PgmName; MSGPGMQ = MainProc; SH_PGM = PgmName; clear CUSTMAST_ds; clear dfIndDS; BldFkeyText();//--- Open display file --- if not %open(MTNCUSTD); open MTNCUSTD; endif;end-proc;// 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(80) 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;