Source on IFS & Local Development

5250_Subfile/CRTDTAARA.clle

@@ -0,0 +1,9 @@
+/* Convenience pgm that creates CUSTNEXT data area in *CUURLIB */
+/* This is a really high number that I don't expect in test data */
+/* Strictly it should be set to CUSTMAST COUNT(*) + 1            */
+             PGM
+             DLTDTAARA  DTAARA(CUSTNEXT) 
+             MONMSG     MSGID(CPF0000)
+             CRTDTAARA  DTAARA(CUSTNEXT) TYPE(*CHAR) LEN(4) +
+                          VALUE('EEEE') TEXT('Next alpha-numeric customer number')
+             ENDPGM

5250_Subfile/CRTMSGF.CLLE

@@ -1,8 +1,13 @@
              PGM
-             DLTMSGF    MSGF(LENNONS1/CUSTMSGF)
+             /* === Set your target library here ================ */
+             DCL VAR(&TGT_LIB) TYPE(*CHAR) LEN(10) + 
+                 VALUE('LENNONS1')              
+             /* ================================================= */
+            
+             DLTMSGF    MSGF(&TGT_LIB/CUSTMSGF)
              MONMSG     MSGID(CPF0000)
 
-             CRTMSGF    MSGF(LENNONS1/CUSTMSGF) TEXT('Customer +
+             CRTMSGF    MSGF(&TGT_LIB/CUSTMSGF) TEXT('Customer +
                           Related Messages')
              ADDMSGD    MSGID(DEM0000) MSGF(CUSTMSGF) MSG('Press Enter to +
                           update. F12 to Cancel.')

5250_Subfile/Custmast.sql

@@ -1,23 +1,29 @@
+ -- Create CUSTMAST & Indexs and load 300 records -----------
+ -- Program LOADCUST submits this to batch.
 
- set schema lennons1;
+ -- 02/2024 Change CustID to char to allow alpha/numeric keys
+
+ set schema lennons1;  -- <<<<< Change to your library <<<<<<
  DROP TABLE custmast;
 
+-- 02/2024 Change CUSTID to char to allow alpha-numeric key
+
 CREATE TABLE custmast (
-  CustID numeric(4,0) not NULL,
+    CustID CHAR(4) NOT NULL
-  Name char(40) not null,
+    ,Name CHAR(40) NOT NULL
-  Addr char(40) not NULL,
+    ,Addr CHAR(40) NOT NULL
-  City char(20) not null,
+    ,City CHAR(20) NOT NULL
-  State char(2) not NULL,
+    ,State CHAR(2) NOT NULL
-  Zip char(10) not NULL,
+    ,Zip CHAR(10) NOT NULL
-  CorpPhone char (20) default ' ',
+    ,CorpPhone CHAR(20) DEFAULT ' '
-  AcctMgr char(40) default ' ',
+    ,AcctMgr CHAR(40) DEFAULT ' '
-  AcctPhone char(20) default ' ',
+    ,AcctPhone CHAR(20) DEFAULT ' '
-  Active char(1) default 'Y',
+    ,Active CHAR(1) DEFAULT 'Y'
-  PRIMARY KEY (Custid) 
+,PRIMARY KEY (Custid)
 )
 RCDFMT CUSTMASTF;
 
-
+-- Insert some data --
 INSERT INTO custmast (CustID, Name, Addr, City, State, Zip, CorpPhone, AcctMgr, AcctPhone, Active) VALUES (1, 'Aliquet Nec Imperdiet Limited', 'Ap #766-3317 Penatibus St.', 'Des Moines', 'IA', '90911-1234', '(925)276-2778', 'Simon,  Gannon D.', '(118)850-9146', 'N');
 INSERT INTO custmast (CustID, Name, Addr, City, State, Zip, CorpPhone, AcctMgr, AcctPhone, Active) VALUES (2, 'Nam Porttitor LLP', '802-7392 Elit,  Rd.', 'Rockville', 'MD', '60342-2222', '(734)960-9274', 'Kirk,  Hamish U.', '(435)357-0265', 'N');
 INSERT INTO custmast (CustID, Name, Addr, City, State, Zip, CorpPhone, AcctMgr, AcctPhone, Active) VALUES (3, 'Nibh Dolor Company', 'P.O. Box 103,  9218 Vivamus Avenue', 'Auburn', 'ME', '15762-0001', '(714)825-5082', 'Norman,  Abbot R.', '(757)158-0941', 'Y');
@@ -330,3 +336,11 @@ ADD COLUMN ChgTime TIMESTAMP not null DEFAULT CURRENT_TIMESTAMP
 ADD column ChgUser varchar(18) not null DEFAULT USER;
 
 update custmast set chguser = '*SYSTEM*';
+
+-- Indexes --
+drop index if exists custmast_name;
+create index custmast_name on custmast(name);
+drop index if exists custmast_city;
+create index custmast_city on custmast(city);
+drop index if exists custmast_state;
+create index custmast_state on custmast(state);

5250_Subfile/Custmast2.sql

@@ -0,0 +1,31 @@
+ -- Creates CUSTMAST and Indexes -------------------------------
+ -- Can then  "CALL LOADCUST2 nnn" to load nnn random records.
+
+ -- 02/2024 Change CustID to char to allow alpha/numeric keys
+ 
+ set schema lennons1;  -- <<<<< Change to your library <<<<<<
+ DROP TABLE custmast;
+
+CREATE TABLE custmast (
+    CustID CHAR(4) NOT NULL
+    ,Name CHAR(40) NOT NULL
+    ,Addr CHAR(40) NOT NULL
+    ,City CHAR(20) NOT NULL
+    ,State CHAR(2) NOT NULL
+    ,Zip CHAR(10) NOT NULL
+    ,CorpPhone CHAR(20) DEFAULT ' '
+    ,AcctMgr CHAR(40) DEFAULT ' '
+    ,AcctPhone CHAR(20) DEFAULT ' '
+    ,Active CHAR(1) DEFAULT 'Y'
+    ,ChgTime TIMESTAMP not null DEFAULT CURRENT_TIMESTAMP
+    ,ChgUser varchar(18) not null DEFAULT USER
+,PRIMARY KEY (Custid)
+)
+RCDFMT CUSTMASTF;
+-- Indexes --
+drop index if exists custmast_name;
+create index custmast_name on custmast(name);
+drop index if exists custmast_city;
+create index custmast_city on custmast(city);
+drop index if exists custmast_state;
+create index custmast_state on custmast(state);

5250_Subfile/LOADCUST.CLLE

@@ -0,0 +1,20 @@
+             /*=== Creates CUSTMAST & Indexes and 300 records ===*/
+             PGM
+             CHKOBJ     OBJ(CUSTMAST) OBJTYPE(*FILE)
+             MONMSG     MSGID(CPF9801) EXEC(GOTO CMDLBL(SUBMIT))
+
+             ALCOBJ     OBJ((CUSTMAST *FILE *EXCLRD)) WAIT(5) +
+                          CONFLICT(*RQSRLS)
+             MONMSG     MSGID(CPF1002) EXEC(DO)
+             SNDMSG     MSG('Cannot allocate CUSTMAST') +
+                          TOUSR(*REQUESTER)
+             RETURN
+             ENDDO
+
+             DLCOBJ     OBJ((CUSTMAST *FILE *EXCLRD))
+ SUBMIT:     SBMJOB     CMD(RUNSQLSTM +
+                          SRCSTMF('/home/LENNONS/IBMi_IFS_DEV/5250_Subfile/+
+                          custmast.sql')  + 
+                          COMMIT(*NONE) ERRLVL(40) DECMPT(*PERIOD)) +
+                          JOB(LOADCUST)
+             ENDPGM

5250_Subfile/LOADCUST2.CLLE

@@ -0,0 +1,19 @@
+/* === Loads CUSTMAST with as many random records as specified === */
+/*     Submits job to batch  */
+
+             PGM        PARM(&NUM)
+             DCL        VAR(&NUM) TYPE(*DEC)  LEN(15 5)
+             CHKOBJ     OBJ(CUSTMAST) OBJTYPE(*FILE)
+             MONMSG     MSGID(CPF9801) EXEC(GOTO CMDLBL(SUBMIT))
+
+             ALCOBJ     OBJ((CUSTMAST *FILE *EXCLRD)) WAIT(5) +
+                          CONFLICT(*RQSRLS)
+             MONMSG     MSGID(CPF1002) EXEC(DO)
+             SNDMSG     MSG('Cannot allocate CUSTMAST') +
+                          TOUSR(*REQUESTER)
+             RETURN
+             ENDDO
+
+             DLCOBJ     OBJ((CUSTMAST *FILE *EXCLRD))
+ SUBMIT:     SBMJOB     CMD(CALL PGM(LOADCUSTR) PARM((&NUM))) JOB(LOADCUST2)
+             ENDPGM

5250_Subfile/LOADCUSTR.SQLRPGLE

@@ -0,0 +1,256 @@
+**free
+// === Program to create "n" records of test data in CUSTMAST =====
+// ===  Assumes CUSTMAST is exists and will clear it first.
+// === City name, state and zip are generated from USPS data, 
+//      file CSZ, created from upload from USPS.COM with iACS.
+//      See https://www.unitedstateszipcodes.org/zip-code-database/
+//      Rest of the data i randomly generated.
+// This was an experimental program to use randomn number and
+// variable sized arrays.  But it was fun to write...
+
+ctl-opt DftActGrp(*no) ActGrp('QILE') BndDir('UTIL_BND':'SQL_BND':'SRV_BASE36');
+ctl-opt Option(*nounref: *nodebugio: *srcstmt);
+ctl-opt ExprOpts(*ResDecPos) ExtBinInt( *Yes );
+ctl-opt Debug(*constants : *retval);
+ctl-opt Indent('| ');
+/COPY ../Copy_Mbrs/SRV_SQL_P.RPGLE
+/COPY ../Copy_Mbrs/SRV_RAND_P.RPGLE
+/COPY ../Copy_Mbrs/BASE36_P.RPGLE
+
+// === Program Parameter =======================================
+dcl-pi *n;
+  parm_recds packed(15 : 5); // Number of records to create
+end-pi;
+dcl-s p_recds int(10);
+
+dcl-ds Fld ExtName('CUSTMAST') Qualified;
+end-ds;
+// === SQL State Constants =====================================
+dcl-c SQLSUCCESS      '00000';
+dcl-c SQLNODATA       '02000';
+dcl-c SQLNOMOREDATA   '02000';
+dcl-c SQLNOTJOURNALED '01567';
+
+dcl-s companyType varchar(10) dim(*auto : 30);
+dcl-s streetType varchar(10) dim(*auto : 30);
+dcl-s varCUSTID varchar(4);
+// === City/state/zip record ===
+dcl-ds csz qualified;                        
+  zip int(10);
+  ziptype char(10);
+  city char(20);
+  st char(2);
+end-ds;
+
+// === Arrary of City, State and Zip records ===
+dcl-ds csz_a likeds(csz) dim(*auto : 50000) ;
+
+dcl-s cszCount int(10);
+dcl-s MaxL int(10);
+dcl-s csz_I int(10);
+dcl-s j int(10);
+// dcl-s t int(10);
+DCL-S adrX int(10);
+dcl-s nRecds int(10);
+dcl-s wk10 char(10);
+dcl-s wkStr varchar(50);
+
+// === Build array of Company types ===
+companyType(1) = 'INC';
+companyType(*next) = 'LLC';
+companyType(*next) = 'LLP';
+companyType(*next) = 'COMPANY';
+companyType(*next) = '& SONS';
+companyType(*next) = 'ET FILS';
+companyType(*next) = 'PLC';
+companyType(*next) = 'CORP';
+companyType(*next) = 'LTD';
+companyType(*next) = 'SOLE';
+companyType(*next) = 'PARTNERS';
+companyType(*next) = 'ASSOC';
+
+// === Build array of street types ===
+streetType(1) = 'STREET';
+streetType(*next) = 'ST';
+streetType(*next) = 'ROAD';
+streetType(*next) = 'RD';
+streetType(*next) = 'AVENUE';
+streetType(*next) = 'AVE';
+streetType(*next) = 'PLACE';
+streetType(*next) = 'CIRCLE';
+streetType(*next) = 'SQUARE';
+streetType(*next) = 'HWY';
+streetType(*next) = 'VISTA';
+streetType(*next) = 'CALLE';
+streetType(*next) = 'RANCH';
+streetType(*next) = 'CRESCENT';
+streetType(*next) = 'COURT';
+streetType(*next) = 'WAY';
+
+exec sql set  option datfmt=*iso,
+              commit=*none,
+              closqlcsr=*endmod;
+              
+// === Clear Custmast file ===              
+exec sql truncate  lennons1.custmast;
+if (SQLSTT <> SQLSUCCESS and SQLSTT <> SQLNODATA);
+  SQLProblem('truncate custmast');
+endif;
+
+// === Size the City/State/Zip array ===
+exec sql select count(*) into :cszCount
+  from lennons1.csz
+  where length(trim(city)) <= 20;
+if (SQLSTT <> SQLSUCCESS);
+  SQLProblem('select count(*)');
+endif;
+%elem(csz_a : *alloc) = cszCount + 1;
+
+// === Populate csz_a ===
+exec sql declare csz_cur cursor for
+  select zip, type, upper(city), trim(state)
+  from lennons1.csz
+  where length(trim(city)) <= 20;
+exec sql open csz_cur;
+if (SQLSTT <> SQLSUCCESS );
+  SQLProblem('Open csz_cur');
+endif;
+j=1;
+dow (1=1);
+  exec sql fetch from csz_cur into :csz; 
+  if SQLSTT = SQLNOMOREDATA;
+    leave;
+  endif;
+  if SQLSTT <> SQLSUCCESS;
+    SQLProblem('fetch fron csz_cur');
+  endif;
+  csz_a(j) = csz;
+  j += 1;
+enddo;
+
+// === Build CUSTMAST records =================================
+p_recds = parm_recds;
+varCUSTID = '1001';
+for nRecds = 1 to p_recds;
+  clear Fld;
+  Fld.CUSTID = varCUSTID;
+  varCUSTID = BASE36ADD(varCUSTID); // Alpha-numeric key
+  Fld.ACTIVE = 'Y';
+  if (%rem(nRecds : 7) = 0);
+    Fld.ACTIVE = 'N';
+  endif;
+
+  // === City/State Zip ===
+  csz_I = Rand_Int(1:%elem(csz_a));
+  Fld.STATE = csz_a(csz_I).st;
+  Fld.CITY = csz_a(csz_I).city;
+  wk10 = %editc(csz_a(csz_I).zip:'X');
+  Fld.ZIP = %subst(wk10 :6 :5);
+
+  // === Company Name ===
+  clear wkStr; 
+  // Specify a random name length leaving space for 
+  // a company6y type suffix.
+  MaxL = Rand_Int(5 : %len(Fld.Name) - 12);
+  wkStr = wkStr + genWord(5:11) + ' ';
+  dow %len(wkStr) <= MaxL;
+    wkStr = wkStr + genWord(5:11) + ' ';
+  enddo;
+
+  // Add  company "types" to some records
+  j = Rand_Int(1:(%elem(companyType) * 1.8));
+  if j <= %elem(companyType);
+    wkStr = %trim(wkStr) + ' ' + companyType(j);
+  endif;
+  Fld.NAME = wkStr;
+
+  // === Address ===
+  clear wkStr;
+  adrX = %rem(nRecds :4);
+  MaxL = Rand_Int(5 : %len(Fld.ADDR) - 12);
+  if adrX <> 0; //Add street number to most
+    wkStr = %trim(%editc(Rand_Int(1:5000) : '3')) + ' ';
+  endif;
+  wkStr = wkStr + genWord(5:11) + ' ';
+  dow %len(wkStr) <= MaxL;
+    wkStr = wkStr + genWord(5:11) + ' ';
+  enddo;
+  // Add street "types" to some records
+  j = Rand_Int(1:(%elem(streetType) * 1.75));
+  if j <= %elem(streetType);
+    wkStr = %trim(wkStr) + ' ' + streetType(j);
+  endif;
+  Fld.ADDR = wkStr;
+
+  // === Phone numbers ===
+  Fld.CORPPHONE = genPhone();
+  Fld.ACCTPHONE = genPhone();
+
+  // === Account Manager ===
+  if %rem(nRecds :3) = 0;
+    wkStr = genWord(1:1) + ' ';
+    wkStr += genWord(1:1) + ' ';
+    wkStr += genWord(4:10);
+  else;
+    wkStr = genWord(3:6) + ' ';
+    wkStr += genWord(5:9);
+  endif;
+  Fld.ACCTMGR = wkStr;
+
+  Fld.CHGUSER = '*SYSTEM*';
+
+  // === Write out a record ======================================
+  exec sql insert into lennons1.custmast values(:Fld);
+  if (SQLSTT <> SQLSUCCESS);
+    SQLProblem('Insert into custmast');
+  endif;
+endfor;
+
+// === All finished ============================================
+*inlr = *on;
+return;
+
+// === Generate a word =========================================
+dcl-proc genWord;
+  dcl-pi genWord varchar(30);
+    MinL int(10) const;
+    MaxL int(10) const;
+  end-pi;
+  // Straight alphabetic
+  dcl-s Alpha varchar(50)
+  inz('ABCDEFGHIIJKLMNOPQRSTUVWXYZZ');
+  // Biased towards vowels
+  dcl-s vAlpha varchar(50)
+  inz('AAAAABCDEEEEEFGHIIIIIJKLMNOOOOOPQRSTUUUVWXYZZ');
+
+  dcl-s wk30 varchar(30) inz;
+  dcl-s TgtL int(10);
+  dcl-s j int(10);
+
+  wk30 = %subst(Alpha : Rand_Int(1 : %len(Alpha)) : 1);
+  if (MinL<> 1 and MaxL <> 1);
+    wk30 += %subst(vAlpha : Rand_Int(1 : %len(vAlpha)) : 1);
+  endif;
+  TgtL = Rand_Int(MinL:MaxL) - 2;    
+  for j=1 by 2 to TgtL;     
+    wk30 += %subst(Alpha : Rand_Int(1 : %len(Alpha)) : 1);
+    wk30 += %subst(vAlpha : Rand_Int(1 : %len(vAlpha)) : 1);
+  endfor;
+  return wk30;
+end-proc;
+
+// === Generate a phone like (800) 231-1876 ====================
+dcl-proc genPhone;
+  dcl-pi genPhone varchar(20);
+  end-pi;
+  dcl-s wkret varchar(20);
+  dcl-s wk3 char(3);
+  dcl-s wk4 char(4);
+  wk3 = %editc(%dec(Rand_Int(100:900):3 :0) : 'X');
+  wkret = '(' + wk3 + ') ';
+  wk3 = %editc(%dec(Rand_Int(1:998) :3 :0) : 'X');
+  wkret += wk3 + '-';
+  wk4 = (%editc(%dec(Rand_Int(1:9900) :4 :0) : 'X'));
+  wkret += wk4;
+  return wkret;
+end-proc;

5250_Subfile/MTNCUSTD.DSPF

@@ -0,0 +1,193 @@
+     A*===============================================================
+     A* Window to display or update Customer Master
+     A*===============================================================
+     A*  CRTDSPF FILE(MTNCUSTD) SRCFILE(...) RSTDSP(*YES)
+     A*==============================================================
+     A* There is a naming convention for the fields in each record.
+     A*  -- Screen Header:   Fields begin with SH_
+     A*  -- Details          Fields begin with SD_
+     A*  -- Screen footer:   Fields begin with SFT_
+     A*===============================================================
+     A* Indicator usage:
+     A*   01-20 Are not routinely cleared after an EXFMT.  Some
+     A*         of these are used in subfile & subfile control for
+     A*         highlighting, etc., which does not change unless
+     A*         explicitly requested.
+     A*   21-99 Are routinely cleared after an EXFMT.
+     A*         80-89 Subfile record
+     A*         90    Nessage Subfile end
+     A*         91-99 Subfile Control Record
+     A* Note: INDARA is specified here and in the program and this
+     A*       means that the display file indicators are in a
+     A*       means that the display file indicators are in a
+     A*       data structure separate from the program indicators.
+     A*       This makes it easy to name the indicators in the DS.
+     a* Note: DSPATR HI and RI at the same time = non-display. Thus
+     a*       when we turn on RI were turn of HI,
+     A*===============================================================
+     A*%%EC
+     A                                      DSPSIZ(24 80 *DS3)
+     A                                      PRINT
+     A                                      INDARA
+     A                                      ALTHELP
+     A                                      CF04
+     A                                      CA05
+     A                                      CA12
+     A                                      HELP
+     A*===============================================================
+     A*=== Screen Header:  Fields begin with SH_ =====================
+     A*
+     A          R SH_HDR
+     A                                      OVERLAY
+     A                                      TEXT('Screen Header')
+     A                                      WDWBORDER((*COLOR PNK))
+     A                                      WINDOW(*DFT 17 54)
+     A            SH_PGM        10A  O  1  1
+     A                                  1 21'Customer Master'
+     A                                  1 47DATE
+     A                                      EDTCDE(Y)
+     A                                  2  1USER
+     A            SH_FUNCT      25A  O  2 16DSPATR(HI)
+     A                                  2 47TIME
+     A*===============================================================
+     A*=== Data Details - Fields begin with SD_ ======================
+     A          R DETAILS
+     A                                      OVERLAY
+     A                                      WINDOW(SH_HDR)
+     A                                      CHGINPDFT
+     A                                      RTNCSRLOC(&SD_PMT_RCD &SD_PMT_FLD)
+     A*---------------------------------------------------------------
+     A                                  5  1'Customer Id'
+     A            SD_CUSTID      4      5 14DSPATR(HI)
+     A                                  5 20'Active Status'
+     A            SD_ACTIVE      1   B  5 35
+     A N40                                  DSPATR(HI)
+     A  40                                  DSPATR(RI)
+     A  41                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                  6  1'Name'
+     A            SD_NAME       40   B  6  9
+     A N42                                  DSPATR(HI)
+     A  42                                  DSPATR(RI)
+     A  43                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                  7  1'Address'
+     A            SD_ADDR       40   B  7  9
+     A N44                                  DSPATR(HI)
+     A  44                                  DSPATR(RI)
+     A  45                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                  8  1'City'
+     A            SD_CITY       20   B  8  9
+     A N46                                  DSPATR(HI)
+     A  46                                  DSPATR(RI)
+     A  47                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                  8 32'ST+'
+     A            SD_STATE       2   B  8 36
+     A N48                                  DSPATR(HI)
+     A  48                                  DSPATR(RI)
+     A  49                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                  8 39'ZIP'
+     A            SD_ZIP        10   B  8 43
+     A N50                                  DSPATR(HI)
+     A  50                                  DSPATR(RI)
+     A  51                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                  9  1'Account Manager'
+     A                                 10  5'Phone'
+     A            SD_ACCTPH     20   B 10 15
+     A N52                                  DSPATR(HI)
+     A  52                                  DSPATR(RI)
+     A  53                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                 11  5'Name'
+     A            SD_ACCTMGR    40   B 11 15
+     A N54                                  DSPATR(HI)
+     A  54                                  DSPATR(RI)
+     A  55                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                 12  1'Corporate Phone'
+     A            SD_CORPPH     20   B 12 17
+     A N56                                  DSPATR(HI)
+     A  56                                  DSPATR(RI)
+     A  57                                  DSPATR(PC)
+     A  10                                  DSPATR(PR)
+     A N10                                  DSPATR(UL)
+     A                                 13  1'Last Change'
+     A N61                                  DSPATR(ND)
+     A            SD_CHGTIME    23     13 13
+     A N61                                  DSPATR(ND)
+     A                                 13 37'by'
+     A N61                                  DSPATR(ND)
+     A            SD_CHGUSER    15     13 40
+     A N61                                  DSPATR(ND)
+     A            SD_PMT_RCD    10A  H
+     A            SD_PMT_FLD    10A  H
+     A*===============================================================
+     A*=== Screen footer & function keys:  Fields begin with SFT_ ====
+     A*
+     A          R SFT_FKEY
+     A                                      TEXT('Screen Footer')
+     A                                      OVERLAY
+     A                                      WINDOW(SH_HDR)
+     A                                 14  1'             Demo Corp of America -
+     A                                                          '
+     A                                      DSPATR(UL)
+     A            SFT_KEYS      53A  O 15  1COLOR(BLU)
+     A*===============================================================
+     A*=== Message Subfile:  No fields ===============================
+     A*
+     A          R MSGSFL                    SFL
+     A                                      TEXT('Message Subfile')
+     A                                      SFLMSGRCD(16)
+     A            MSGKEY                    SFLMSGKEY
+     A            MSGPGMQ                   SFLPGMQ(10)
+     A*===============================================================
+     A*=== Message Subfile Control: No fields ========================
+     A*
+     A          R MSGCTL                    SFLCTL(MSGSFL)
+     A                                      TEXT('Message Subfile Control')
+     A                                      WINDOW(SH_HDR)
+     A                                      PAGEDOWN
+     A                                      PAGEUP
+     A                                      OVERLAY
+     A                                      SFLDSP
+     A                                      SFLDSPCTL
+     A                                      SFLINZ
+     A N90                                  SFLEND
+     A                                      SFLSIZ(0002)
+     A                                      SFLPAG(0001)
+     A            MSGPGMQ                   SFLPGMQ(10)
+     A*===============================================================
+     A*=== Dummy Record - Assume =====================================
+     A*
+     A          R DUMMY
+     A                                      ASSUME
+     A                                      KEEP
+     A                                  1  2'*'
+     A*%%RS+<record-sequences>
+     A*%%RS+ <sequence name="SCREEN1">
+     A*%%RS+  <device type="display" width="80" height="24" />
+     A*%%RS+  <record-write record-format="SH_HDR" />
+     A*%%RS+  <record-write record-format="DETAILS" />
+     A*%%RS+  <record-write record-format="SFT_FKEY" />
+     A*%%RS+  <record-write record-format="MSGSFL" />
+     A*%%RS+  <record-write record-format="MSGCTL" />
+     A*%%RS+  <record-write record-format="DUMMY" />
+     A*%%RS+ </sequence>
+     A*%%RS </record-sequences>
+     A*%%RS+<record-sequences>
+     A*%%RS+ <sequence name="Untitled">
+     A*%%RS+  <device type="display" width="80" height="24" />
+     A*%%RS+ </sequence>
+     A*%%RS </record-sequences>

5250_Subfile/PMTCUSTD.DSPF

@@ -0,0 +1,171 @@
+     A*===============================================================
+     A* This is a full screen expanding subfile to search for
+     A* a customer.
+     A*   - There are filters limit selection.
+     A*   - A message subfile is included.
+     A*===============================================================
+     A*  CRTDSPF FILE(PMTCUSTD) SRCFILE(...) RSTDSP(*YES)
+     A*==============================================================
+     A* There is a naming convention for the fields in each record.
+     A*  -- Screen Header:   Fields begin with SH_
+     A*  -- Subfile:         Fields begin with SF_
+     A*  -- Subfile Control: Fields begin with SC_
+     A*  -- Screen footer:   Fields begin with SFT_
+     A*===============================================================
+     A* Indicator usage:
+     A*   01-20 Are not routinely cleared after an EXFMT.  Some
+     A*         of these are used in subfile & subfile control for
+     A*         highlighting, etc., which does not change unless
+     A*         explicitly requested.
+     A*   21-99 Are routinely cleared after an EXFMT.
+     a*         79    SC_NAME Position Cursor
+     A*         80-89 Subfile record
+     A*         90    Nessage Subfile end
+     A*         91-99 Subfile Control Record
+     A* Note: INDARA is specified here and in the program and this
+     A*       means that the display file indicators are in a
+     A*       data structure separate from the program indicators.
+     A*       This makes it easy to name the indicators in the DS.
+     A*==============================================================
+     A                                      DSPSIZ(24 80 *DS3)
+     A                                      PRINT
+     A                                      INDARA
+     A                                      ALTHELP
+     A                                      CA03
+     A                                      CF04
+     A                                      CA05
+     A                                      CA06
+     A                                      CA09
+     A                                      CA42
+     A                                      HELP
+     A*===============================================================
+     A*=== Screen Header:  Fields begin with SH_ =====================
+     A*
+     A          R SH_HDR
+     A                                      OVERLAY
+     A                                      TEXT('Screen Header')
+     A            SH_PGM        10A  O  1  2
+     A                                  1 33'Customer Master'
+     A                                  1 72DATE
+     A                                      EDTCDE(Y)
+     A            SH_FUNCT      50A  O  2 16DSPATR(HI)
+     A                                  2 72TIME
+     A                                  2  2USER
+     A*===============================================================
+     A*=== Subfile:  Fields begin with SF_ ===========================
+     A*
+     A          R SFL                       SFL
+     A                                      TEXT('SubFile')
+     A  80                                  SFLNXTCHG
+     A            SF_ACT_H       1D  H
+     A            SF_CUST_H      4D  H
+     A            SF_OPT         1A  B  9  3
+     A  81                                  DSPATR(RI)
+     A  82                                  DSPATR(PC)
+     A            SF_NAME       40A  O  9  6
+     A  83                                  COLOR(RED)
+     A            SF_CITY       20A  O  9 47
+     A  83                                  COLOR(RED)
+     A            SF_STATE       2A  O  9 69
+     A  83                                  COLOR(RED)
+     A            SF_ZIP         5A  O  9 74
+     A  83                                  COLOR(RED)
+     A*===============================================================
+     A*=== Subfile Control: Fields begin with SC_ ====================
+     A*
+     A          R SFLCTL                    SFLCTL(SFL)
+     A                                      SFLSIZ(0013)
+     A                                      SFLPAG(0012)
+     A                                      TEXT('Subfile Control')
+     A                                      PAGEDOWN
+     A                                      RTNCSRLOC(&SC_PMT_RCD &SC_PMT_FLD)
+     A                                      BLINK
+     A                                      OVERLAY
+     A N98                                  ERASE(SFL)
+     A  98                                  SFLDSP
+     A                                      SFLDSPCTL
+     A  99                                  SFLCLR
+     A  97                                  SFLEND(*MORE)
+     A                                  4  2'Name starts with:'
+     A                                  4 31'City Starts with:'
+     A                                  4 60'State+'
+     A                                  4 71'Including'
+     A                                      COLOR(RED)
+     A N03                                  DSPATR(ND)
+     A            SC_NAME       13A  B  5  6
+     A  79                                  DSPATR(PC)
+     A            SC_CITY       13A  B  5 35
+     A            SC_STATE       2A  B  5 62
+     A                                  5 71'Inctives'
+     A                                      COLOR(RED)
+     A N03                                  DSPATR(ND)
+     A                                  6  2'Type options, press Enter.'
+     A                                      COLOR(BLU)
+     A            SC_OPTIONS    69A     7  2COLOR(BLU)
+     A                                  8  2'Opt'
+     A                                      DSPATR(HI)
+     A                                  8  6'Customer Name'
+     A                                      DSPATR(UL)
+     A                                      COLOR(WHT)
+     A                                  8 47'City               '
+     A                                      DSPATR(UL)
+     A                                      COLOR(WHT)
+     A                                  8 69'St'
+     A                                      DSPATR(UL)
+     A                                      COLOR(WHT)
+     A                                  8 74'ZIP  '
+     A                                      COLOR(WHT)
+     A                                      DSPATR(UL)
+     A            SC_PMT_RCD    10A  H
+     A            SC_PMT_FLD    10A  H
+     A            SC_CSR_RCD     4S 0H      SFLRCDNBR(CURSOR)
+     A*===============================================================
+     A*=== Screen footer & function keys:  Fields begin with SFT_ ====
+     A*
+     A          R SFT_FKEY
+     A                                      TEXT('Screen Footer')
+     A                                      OVERLAY
+     A                                 22  2'                          Demo Cor-
+     A                                      p of America                       -
+     A                                               '
+     A                                      DSPATR(UL)
+     A            SFT_KEYS      78A  O 23  2COLOR(BLU)
+     A*===============================================================
+     A*=== Message Subfile:  No fields ===============================
+     A*
+     A          R MSGSFL                    SFL
+     A                                      TEXT('Message Subfile')
+     A                                      SFLMSGRCD(24)
+     A            MSGKEY                    SFLMSGKEY
+     A            MSGPGMQ                   SFLPGMQ(10)
+     A*===============================================================
+     A*=== Message Subfile Control: No fields ========================
+     A*
+     A          R MSGCTL                    SFLCTL(MSGSFL)
+     A                                      TEXT('Message Subfile Control')
+     A                                      PAGEDOWN
+     A                                      PAGEUP
+     A                                      OVERLAY
+     A                                      SFLDSP
+     A                                      SFLDSPCTL
+     A                                      SFLINZ
+     A N90                                  SFLEND
+     A                                      SFLSIZ(0002)
+     A                                      SFLPAG(0001)
+     A            MSGPGMQ                   SFLPGMQ(10)
+     A*===============================================================
+     A*=== Dummy Record ==============================================
+     A*
+     A          R DUMMY
+     A                                 24 79'*'
+     A*%%RS+<record-sequences>
+     A*%%RS+ <sequence name="TOP">
+     A*%%RS+  <device type="display" width="80" height="24" />
+     A*%%RS+  <record-write record-format="SH_HDR" />
+     A*%%RS+  <record-write record-format="SFT_FKEY" />
+     A*%%RS+  <record-write record-format="SFL" />
+     A*%%RS+  <record-write record-format="SFLCTL" />
+     A*%%RS+  <record-write record-format="MSGSFL" />
+     A*%%RS+  <record-write record-format="MSGCTL" />
+     A*%%RS+ </sequence>
+     A*%%RS </record-sequences>

5250_Subfile/PMTSTATED.DSPF

@@ -0,0 +1,170 @@
+     A*===============================================================
+     A* This is a "load all" subfile in a windown to select a
+     A* state code.
+     A*===============================================================
+     A*  CRTDSPF FILE(PMTSTATED) SRCFILE(...) RSTDSP(*YES)
+     A*==============================================================
+     A* There is a naming convention for the fields in each record.
+     A*  -- Screen Header:   Fields begin with SH_
+     A*  -- Subfile:         Fields begin with SF_
+     A*  -- Subfile Control: Fields begin with SC_
+     A*  -- Screen footer:   Fields begin with SFT_
+     A*===============================================================
+     A* Indicator usage:
+     A*   01-20 Are not routinely cleared after an EXFMT.  Some
+     A*         of these are used in subfile & subfile control for
+     A*         highlighting, etc., which does not change unless
+     A*         explicitly requested.
+     A*   21-99 Are routinely cleared after and EXFMT.
+     A*         80-89 Subfile record
+     A*         90    Nessage Subfile end
+     A*         91-99 Subfile Control Record
+     A* Note: INDARA is specified here and in the program and this
+     A*       means that the display file indicators are in a
+     A*       data structure separate from the program indicators.
+     A*       This makes it easy to name the indicators in the DS.
+     A*==============================================================
+     A                                      DSPSIZ(24 80 *DS3                  -
+     A                                             27 132 *DS4)
+     A                                      PRINT
+     A                                      INDARA
+     A                                      ALTHELP
+     A                                      HELP
+     A*===============================================================
+     A*=== Screen Header:  Fields begin with SH_ =====================
+     A*
+     A          R SH_HDR
+     A                                      OVERLAY
+     A                                      TEXT('Screen Header')
+     A                                      WINDOW(*DFT 16 40)
+     A                                      WDWBORDER((*DSPATR RI) (*CHAR +
+     A                                      '        '))
+     A                                      WDWBORDER((*COLOR BLU))
+     A            SH_PGM        10A  O  1  1
+     A                                  1 16'USA States'
+     A                                      COLOR(WHT)
+     A                                  1 33DATE
+     A                                      EDTCDE(Y)
+     A            SH_FUNCT      17A  O  2 13DSPATR(HI)
+     A                                  2 33TIME
+     A                                  2  1USER
+     A*===============================================================
+     A*=== Subfile:  Fields begin with SF_ ===========================
+     A*
+     A          R SFL                       SFL
+     A                                      TEXT('SubFile')
+     A  80                                  SFLNXTCHG
+     A            SF_OPT         1A  B  6  2
+     A  81                                  DSPATR(RI)
+     A  82                                  DSPATR(PC)
+     A            SF_CODE        2A     6  6
+     A  22                                  COLOR(RED)
+     A            SF_NAME       30A  O  6 11
+     A  22                                  COLOR(RED)
+     A*===============================================================
+     A*=== Subfile Control: Fields begin with SC_ ====================
+     A*
+     A          R SFLCTL                    SFLCTL(SFL)
+     A                                      CF03
+     A                                      CF05
+     A                                      CF07
+     A                                      CF12
+     A  *DS3                                SFLSIZ(9999)
+     A  *DS4                                SFLSIZ(9999)
+     A  *DS3                                SFLPAG(0006)
+     A  *DS4                                SFLPAG(0006)
+     A  *DS3                                WINDOW(SH_HDR)
+     A  *DS4                                WINDOW(SH_HDR)
+     A                                      TEXT('Subfile Control')
+     A                                      RTNCSRLOC(&SC_PMT_RCD &SC_PMT_FLD)
+     A                                      BLINK
+     A                                      OVERLAY
+     A N98                                  ERASE(SFL)
+     A  98                                  SFLDSP
+     A                                      SFLDSPCTL
+     A  99                                  SFLCLR
+     A  97                                  SFLEND(*MORE)
+     A                                  3  1'Name Contains'
+     A            SC_NAME       10A  B  3 16
+     A  95                                  DSPATR(MDT)
+     A            SC_OPTIONS    20A     4  1COLOR(BLU)
+     A                                  4 26'Sorted by:'
+     A            SC_SORTED      4      4 37
+     A                                  5  1'Opt'
+     A                                      DSPATR(HI)
+     A                                      DSPATR(UL)
+     A                                  5  5'Code'
+     A  01                                  COLOR(PNK)
+     A                                      DSPATR(UL)
+     A                                  5 11'Name                          '
+     A                                      DSPATR(UL)
+     A  02                                  COLOR(PNK)
+     A            SC_PMT_RCD    10A  H
+     A            SC_PMT_FLD    10A  H
+     A            SC_CSR_RCD     4S 0H      SFLRCDNBR(CURSOR)
+     A*===============================================================
+     A*=== Screen footer & function keys:  Fields begin with SFT_ ====
+     A*
+     A          R SFT_FKEY
+     A  *DS3                                WINDOW(SH_HDR)
+     A  *DS4                                WINDOW(SH_HDR)
+     A                                      TEXT('Screen Footer')
+     A                                      OVERLAY
+     A                                 13  1'          Demo Corp of America    -
+     A                                            '
+     A                                      DSPATR(UL)
+     A            SFT_KEYS      40   O 14  1
+     A*===============================================================
+     A*=== Message Subfile:  No fields ===============================
+     A*
+     A          R MSGSFL                    SFL
+     A                                      TEXT('Message Subfile')
+     A                                      SFLMSGRCD(15)
+     A            MSGKEY                    SFLMSGKEY
+     A            MSGPGMQF                  SFLPGMQ(10)
+     A*===============================================================
+     A*=== Message Subfile Control: No fields ========================
+     A*
+     A          R MSGCTL                    SFLCTL(MSGSFL)
+     A                                      TEXT('Message Subfile Control')
+     A                                      WINDOW(SH_HDR)
+     A                                      PAGEDOWN
+     A                                      PAGEUP
+     A                                      OVERLAY
+     A                                      SFLDSP
+     A                                      SFLDSPCTL
+     A                                      SFLINZ
+     A N90                                  SFLEND
+     A                                      SFLSIZ(0002)
+     A                                      SFLPAG(0001)
+     A            MSGPGMQC                  SFLPGMQ(10)
+     A*===============================================================
+     A*=== Dummy Record - Assume =====================================
+     A*
+     A          R DUMMY
+     A                                      ASSUME
+     A                                  1  2' '
+     A*%%RS+<record-sequences>
+     A*%%RS+ <sequence name="SCREEN1">
+     A*%%RS+  <device type="display" width="80" height="24" />
+     A*%%RS+  <record-write record-format="SH_HDR" />
+     A*%%RS+  <record-write record-format="SFL" />
+     A*%%RS+  <record-write record-format="SFLCTL" />
+     A*%%RS+  <record-write record-format="SFT_FKEY" />
+     A*%%RS+ </sequence>
+     A*%%RS </record-sequences>
+     A*%%RS+<record-sequences>
+     A*%%RS+ <sequence name="Untitled">
+     A*%%RS+  <device type="display" width="132" height="27" />
+     A*%%RS+ </sequence>
+     A*%%RS </record-sequences>
+     A*%%RS+<record-sequences>
+     A*%%RS+ <sequence name="Untitled">
+     A*%%RS+  <device type="display" width="80" height="24" />
+     A*%%RS+ </sequence>
+     A*%%RS </record-sequences>
+     A*%%RS+<record-sequences>
+     A*%%RS+ <sequence name="Untitled">
+     A*%%RS+  <device type="display" width="80" height="24" />
+     A*%%RS+ </sequence>
+     A*%%RS </record-sequences>

5250_Subfile/PMTSTATER.SQLRPGLE

@@ -1,3 +1,4 @@
+**free
 /TITLE PMTSTATE Search and return a USA State Code
 //==============================================================*
 // This is a "load all" subfile, where the system takes care or
@@ -38,138 +39,108 @@
 //===============================================================
 // Compilation
 //    Use CRTSQLRPGI command.
-       //    Note that /INCLUDEs expects to find code in DEMO library,
+//    Note that /INCLUDEs expects to find code in Copy_Mbrs file,
 //    not the default of QRPGLESRC. Change as needed.
 //=============================================================
+// 12/2023 Converted to totally **FREE
+//         Use SQLPROBLEM service program
+//=============================================================
+ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
+bnddir('UTIL_BND': 'SQL_BND');
 
-     h DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
+// === Program parameters =======================================
-     h BndDir('UTIL_BND')
+dcl-pi *n;
-     h main(Main)
+  pState like(FetchData.state);
+end-pi;
 
 //=== Display File ==============================================
-     fPMTSTATED CF   E             WorkStn INFDS(dfInfDS)
+dcl-f PMTSTATED workstn infds(dfInfDS) indds(dfIndDS) sfile(SFL:SflRRN)
-     f                                     INDDS(dfIndDS)
+usropn;
-     f                                     SFILE(SFL:SflRRN)
-     f                                     USROPN
-
-     d Main            pr                  extpgm('PMTSTATER')
-     d ReturnState                    2A
-
 //=== Service Program Prototypes ================================
-      /include copy_mbrs,Srv_Msg_P
+/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE
-
+/INCLUDE ../Copy_Mbrs/SRV_SQL_P.RPGLE
 //=== Named hexadecimal constants for function keys =============
-      /include copy_mbrs,##AIDBYTES
+/INCLUDE ../Copy_Mbrs/AIDBYTES.RPGLE
-
 //=== 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)
+dcl-ds STATESds extname('STATES') qualified template end-ds;
-     d                                     qualified template
+dcl-ds FetchData likeds(STATESds);
-     d FetchData       ds                  likeds(STATES)
-
 //=== SQL State Constants =======================================
-     d SQLSuccess      c                   '00000'
+dcl-c SQLSUCCESS '00000';
-     d SQLNoData       c                   '02000'
+dcl-c SQLNODATA '02000';
-     d SQLNoMoreData   c                   '02000'
+dcl-c SQLNOMOREDATA '02000';
-     d SQLDupRecd      c                   '23505'
+dcl-c SQLDUPRECD '23505';
-     d SQLRowLocked    c                   '57033'
+dcl-c SQLROWLOCKED '57033';
-
 //=== Display File Information Data Structure ===================
 //    Allows us to determine which function key was pressed
-     d dfInfDS         DS
+dcl-ds dfInfDS;
-     d Key                   369    369
+  Key char(1) pos(369);
+end-ds;
 //=== 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
+dcl-ds dfIndDS len(99);
-     d scNameHi               02     02
+  scCodeHi char(1) pos(1);
-
 //--- 21-99 automatically cleared after EXFMT ------------------
-     d dfIndClr               21     99
+  scNameHi char(1) pos(2);
-
 //--- Subfile indicators (prefix "sf") -------------------------
-     d sfSflNxtChg            80     80n
+  dfIndClr char(79) pos(21);
-     d sfOPT_RI               81     81n
+  sfSflNxtChg ind pos(80);
-     d sfOPT_PC               82     82n
+  sfOPT_RI ind pos(81);
-
 //--- Subfile Control indicators (prefix "sc") ----------------
-     d scMDT                  95     95n
+  sfOPT_PC ind pos(82);
-     d scNoDta                96     96n
+  scMDT ind pos(95);
-     d scSflEnd               97     97n
+  scNoDta ind pos(96);
-     d scSflDsp               98     98n
+  scSflEnd ind pos(97);
-     d scSflClr               99     99n
+  scSflDsp ind pos(98);
-
+  scSflClr ind pos(99);
+end-ds;
 //=== Fields to control the subfile screen ======================
-     d  SflRRN         s              5i 0
+dcl-s SflRRN int(5);
-     d  RcdsInSfl      s              5i 0
+dcl-s RcdsInSfl int(5);
-     d  SflPageSize    c                    6
+dcl-c SFLPAGESIZE 6;
-     d  SflMaxRecd     s              5i 0  inz(9999)
+dcl-s SflMaxRecd int(5) 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
+dcl-ds ProgStatus PSDS;
-     d PgmName           *PROC
+  PgmName *PROC;
-
+end-ds;
-     d MainProc        S             10a
+dcl-s MainProc char(10);
-
 //=== Text for function keys ====================================
-     d F3Text          c                   'F3=Exit'
+dcl-c F3TEXT 'F3=Exit';
-     d F5Text          c                   'F5=Refresh'
+dcl-c F5TEXT 'F5=Refresh';
-     d F12Text         c                   'F12=Cancel'
+dcl-c F12TEXT 'F12=Cancel';
-     d F7Text1         c                   'F7=By '
+dcl-c F7TEXT1 'F7=By ';
-     d F7Text2         s              5a   inz(' ')
+dcl-s F7Text2 char(5) inz(' ');
-     d F7Text          S             11a   inz(' ')
+dcl-s F7Text char(11) inz(' ');
-
 //SortSeq is used in SQL Order By in a CASE construct.
-     d SQLSortSeq      s              4a   inz(' ')
+dcl-s SQLSortSeq char(4) inz(' ');
-     d SortbyName      s              4a   inz('Name')
+dcl-s SortbyName char(4) inz('Name');
-     d SortbyCode      s              4a   inz('Code')
+dcl-s SortbyCode char(4) inz('Code');
-
 //=== Options Text ==============================================
-
+dcl-c OPT1TEXT '1=Select';
-     d Opt1Text        c                   '1=Select'
-
 //=== Search Criteria Screen Fields =============================
-     d SearchCriteria  ds                  inz
+dcl-ds SearchCriteria inz;
-     d SC_NAME
+  SC_NAME;
-
+end-ds;
 //=== Last Search Criteria Fields ===============================
-     d LastSearchCriteria...
+dcl-ds LastSearchCriteria inz;
-     d                 ds                  inz
+  LastSC_NAME like(sc_name);
-     d LastSC_NAME                         Like(SC_NAME)
+end-ds;
-
 //=== SQL Search Variables ======================================
-     d DESCLike        S             12    varying
+dcl-s DESCLike varchar(12);
-
 //=== Global Switches ===========================================
-     d EofData         s               n
+dcl-s EofData ind;
-     d CursorOpen      s               n
+dcl-s CursorOpen ind;
-     d NewSearchCriteria...
+dcl-s NewSearchCriteria ind;
-     d                 s               n
+dcl-s SflMsgSnt ind;
-     d SflMsgSnt       s               n
+dcl-s Opt1OK ind;
-     d Opt1OK          s               n
+dcl-s OptError ind;
-     d OptError        s               n
-     d CowsComeHome    c                   const('0')
-
 //=== Work Fields ===============================================
-     d inx             s             10i 0
+dcl-s inx int(10);
-
-       //=============================================================
-       //== 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;
@@ -182,38 +153,45 @@
           STATE,
           NAME
  from     STATES
-        where    upper(NAME) like :DescLike
+ where    upper(NAME) like :DESCLike
  order by case :SQLSortSeq
-                      when :SortByName then NAME
+               when :SortbyName then NAME
-                      when :SortByCode then STATE
+               when :SortbyCode then STATE
                else '1'
           end
  for fetch only;
-
+//=============================================================
+//== Program Starts Here ======================================
+//=============================================================
+//--- Analyse parameters ---
+Opt1OK = *off;
+if %parms() > 0;
+  Opt1OK = *on;
+endif;
+Init();
+BldFkeyText();
 // === Initial screen display =================================
 write SH_HDR;
 SflClear();
-       exsr ProcessSearchCriteria;
+ProcessSearchCriteria();
-       exsr SflLoadAll;
+SflLoadAll();
-
 //=============================================================
 // === Main Program Loop ======================================
 //=============================================================
-       dou CowsComeHome;
+dow *INLR = *OFF;
+  // To exit this program, some procedures tuen on *INLR
+
   // 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;
+    ProcessSearchCriteria();
-           exsr SflLoadAll;
+    SflLoadAll();
   endif;
-
   // Write/Read the screen
-         exsr ScreenIO;
+  ScreenIO();
-
   //-- Enter Key --------------------------------------------
   If Key = Enter;
     // Either new Search Criteria entered or option(s) entered.
@@ -221,199 +199,159 @@
     if SearchCriteria <> LastSearchCriteria
       or NewSearchCriteria = *on;
       SflClear();
-             exsr ProcessSearchCriteria;
+      ProcessSearchCriteria();
-             exsr SflLoadAll;
+      SflLoadAll();
     else;
-             exsr ProcessOption;
+      ProcessOption();
     endif;
-
     iter;
   endif;
-
   //--- Any other entry must be a function key ---------------
-         exsr ProcessFunctionKey;
+  ProcessFunctionKey();
-
 enddo;
-
+return; // to Caller
 //=============================================================
 //=== End of Main Program Loop ================================
 //=============================================================
 
 //=== ScreenIO ================================================
 // Writes and Reads the screen
-       begsr ScreenIO;
+Dcl-Proc 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;
-
+End-Proc;
-       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.
-
+Dcl-Proc ProcessFunctionKey;
-       begsr ProcessFunctionKey;
-
   select;
-
+    //--- F3 or F12: Exit, close down program -----------------------
-           //--- F3: Exit, close down program -----------------------
+    when (Key = F03 or Key = F12);
-         when Key = F03;
+      CloseDownPgm();
-           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;
+      if SQLSortSeq=SortbyName;
-             SQLSortSeq = SortByCode;
+        SQLSortSeq = SortbyCode;
-             SC_SORTED = SortByCode;
+        SC_SORTED = SortbyCode;
         scCodeHi = *on;
         scNameHi = *off;
-             F7Text2 = SortByName;
+        F7Text2 = SortbyName;
       else;
-             SQLSortSeq = SortByName;
+        SQLSortSeq = SortbyName;
-             SC_SORTED = SortByName;
+        SC_SORTED = SortbyName;
         scNameHi = *on;
         scCodeHI = *off;
         F7Text2 = SortbyCode;
       endif;
-           F7Text = F7Text1 + F7Text2;
+      F7Text = F7TEXT1 + F7Text2;
-           exsr BldFkeyText;
+      BldFkeyText();
       NewSearchCriteria = *on;
       SflClear();
-
     //--- Other keys: Function key not active message ---------
     other;
       SflMsgSnt= SndSflMsg('DEM0003');
   endsl;
-
+End-Proc;
-       endsr;
 
 //=== ProcessOption ===========================================
 // Did user enter an option?  If so, process it.
 //   May not return from this subroutine.
-
+Dcl-Proc ProcessOption;
-       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;
+          pState = SF_CODE;
-                 exsr CloseDownPgm;
+          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;
+          SetScreenCursorPosition();
-                 optError = *on;
+          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 )
+        ( %int( (RcdsInSfl-1) / SFLPAGESIZE )
-               * SflPageSize
+        * SFLPAGESIZE
         ) + 1;
   endif;
-
+End-Proc;
-       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.
-
+Dcl-Proc SflLoadAll;
-       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;
@@ -423,21 +361,17 @@
     clear SF_OPT;
     SF_CODE = FetchData.STATE;
     SF_NAME = FetchData.NAME;
-
     SflRRN = inx;
-             RcdsinSfl = RcdsInSfl + 1;
+    RcdsInSfl = RcdsInSfl + 1;
     write SFL;
-
       // Can't display more than 9,9999 records.
     if SflRRN = SflMaxRecd;
       EofData = *on;
       SflMsgSnt= SndSflMsg('DEM0006');
       leave;
     endif;
-
   endfor;
-
+End-Proc;
-       endsr;
 
 //=== ProcessSearchCriteria====================================
 // Examines the data entered in the search fields and sets up
@@ -451,14 +385,12 @@
 //    NewSearchCriteria is left on
 //    Error message is sent to the msg sufile
 //    Cursor is postioned at the field in error
-
+Dcl-Proc ProcessSearchCriteria;
-       begsr ProcessSearchCriteria;
   // Reset switches
   NewSearchCriteria = *off;
   // Save entered values.  (Never change screen fields.)
   LastSearchCriteria = SearchCriteria;
   CloseCursor();
-
   //---------------------------------------------------------------
   if SC_NAME = ' ';
     // Not searching, take all
@@ -467,125 +399,104 @@
     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;
+    if SQLSTT  <> SQLSUCCESS;
       SQLProblem('Open DataCur');
     endif;
     CursorOpen = *on;
   endif;
+End-Proc;
 
-       endsr;
+//=== SetScreenCursorPostion ===================================
-
-       //=== SetCursorPostion ========================================
 // If Invalid Option, position screen cursor on first one,
 // else postion cursor on the last valid option.
-       begsr SetScreenCursorPosition;
+Dcl-Proc SetScreenCursorPosition;
   if OptError = *off;
     SC_CSR_RCD=SflRRN;
   endif;
-       endsr;
+End-Proc;
 
 //=== BldFKeyText =============================================
 // Build the Function key text for the bottom of the screen.
-       begsr BldFkeyText;
+Dcl-Proc BldFkeyText;
   SFT_KEYS=' ';
-         SFT_KEYS = CatB(SFT_KEYS : F3Text);
+  SFT_KEYS = CatB(SFT_KEYS : F3TEXT);
-         SFT_KEYS = CatB(SFT_KEYS : F5Text);
+  SFT_KEYS = CatB(SFT_KEYS : F5TEXT);
   SFT_KEYS = CatB(SFT_KEYS : F7Text);
-         SFT_KEYS = CatB(SFT_KEYS : F12Text);
+  SFT_KEYS = CatB(SFT_KEYS : F12TEXT);
-       endsr;
+End-Proc;
 
 //=== CloseDownPgm ============================================
 // Things to do before we issue a return to the caller
-       begsr CloseDownPgm;
+Dcl-Proc CloseDownPgm;
   CloseCursor();
   if %open(PMTSTATED);
     close PMTSTATED;
   endif;
-       endsr;
+End-Proc;
 
 //=== Init ====================================================
 // Must be executed each time program is entered
-       begsr Init;
+Dcl-Proc Init;
-         SQLSortSeq = SortByName;
+  SQLSortSeq = SortbyName;
-         SC_SORTED = SortByName;
+  SC_SORTED = SortbyName;
   scNameHi = *on;       // Name highlighted
   scCodeHi = *off;
-         F7Text2 = SortByCode;
+  F7Text2 = SortbyCode;
-         F7Text = F7Text1 + F7Text2;
+  F7Text = F7TEXT1 + F7Text2;
-
-       //--- Analyse parameters ---
-         Opt1OK = *off;
-         if %parms() > 0;
-           Opt1OK = *on;
-         endif;
   // Set up for subfile message queue
-         MainProc = %proc();
+  MainProc = PgmName;
   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;
+    SC_OPTIONS = OPT1TEXT;
   endif;
-         endsr;
+End-Proc;
-     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
+dcl-proc CatB;
-     pCatB             b
+  dcl-pi CatB varchar(79);
-     dCatB             PI            79    varying
+    ToStr varchar(79) value;
-     d ToStr                         79    varying value
+    AddStr varchar(79) value;
-     d AddStr                        79    varying value
+  end-pi;
-      /FREE
   if ToStr=' ';
     return AddStr;
   else;
     return %trimr(ToStr) + ' ' + AddStr;
   endif;
-      /END-FREE
+end-proc;
-     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
+// dcl-proc SQLProblem;
-     d SQLProblem      PI
+//   dcl-pi SQLProblem;
-     d piSQLDebug                  1024    varying value
+//     piSQLDebug varchar(1024) value;
-
+//   end-pi;
-       //--- Local Variables ---------------------------------
+// //--- Local Variables ---------------------------------
-     d wkSQLDebug      s           1024    varying
+//   dcl-s wkSQLDebug varchar(1024);
-
+//   wkSQLDebug = 'SQLSTT ' + SQLSTT
-      /free
+//              + ' << Unexpected SQL Return Code: '
-       wkSQLDebug = 'SQLSTT ' + SQLSTT
+//              + piSQLDebug;
-                    + ' << Unexpected SQL Return Code: '
+//   dump(a);
-                    + piSQLDebug;
+//   SndEscMsg(wkSQLDebug);
-       dump(a);
+//   return;
-       SndEscMsg(wkSqlDebug);
+// end-proc;
-       return;
-      /end-free
-     p SQLProblem      E
 
 //--------------------------------------------------
 // Procedure name: FetchNextData
@@ -594,30 +505,25 @@
 //                   *ON   No more data, nothing returned
 //                   *OFF  Data returned
 //--------------------------------------------------
-     p FetchNextData   B
+dcl-proc FetchNextData;
-     d FetchNextData   PI              N
+  dcl-pi FetchNextData ind end-pi;
-
 // Local fields
-     d wkEof           S               N
+  dcl-s wkEof ind;
-      /FREE
+  wkEof= *off;
-         wkEoF= *off;
   exec sql fetch DataCur into
                       :FetchData.STATE,
                       :FetchData.NAME
     ;
   select;
-             when SQLSTT = SQLSuccess;
+    when SQLSTT = SQLSUCCESS;
       wkEof = *off;
-             when SQLSTT = SQLNoMoreData;
+    when SQLSTT = SQLNOMOREDATA;
       wkEof = *on;
     Other;
       SQLProblem('Fetch DATACUR');
   endsl;
-
   RETURN wkEof;
-
+end-proc;
-      /END-FREE
-     p FetchNextData   E
 
 //--------------------------------------------------
 // Procedure name: SndSflMsg
@@ -628,21 +534,17 @@
 // Parameter:      ErrMsgFile => Optional Error Message File
 //                 Defaults to CUSTMSGF
 //--------------------------------------------------
-     p SndSflMsg       B
+dcl-proc SndSflMsg;
-     d SndSflMsg       PI              N
+  dcl-pi SndSflMsg ind;
-     d  ErrMsgId                      7A   CONST
+    ErrMsgId char(7) const;
-     d  ErrMsgData                   80A   CONST
+    ErrMsgData char(80) const options(*nopass:*varsize);
-     d                                     OPTIONS(*NOPASS:*VARSIZE)
+    ErrMsgFile char(10) const options(*nopass);
-     d  ErrMsgFile                   10A   CONST
+  end-pi;
-     d                                     OPTIONS(*NOPASS)
-
 // Local fields
-     d retField        S               N
+  dcl-s retField ind;
-     d wkMsgId         s              7a
+  dcl-s wkMsgId char(7);
-     d wkMsgFile       s             10a
+  dcl-s wkMsgFile char(10);
-     d wkMsgData       s             80a   varying
+  dcl-s wkMsgData varchar(512);
-
-      /FREE
   if %parms >2;
     wkMsgFile = ErrMsgFile;
   else;
@@ -654,48 +556,41 @@
     wkMsgData = ' ';
   ENDIF;
   wkMsgId = ErrMsgId;
-       SNDMSGPGMQ(MainProc:
+  SndMsgPgmQ(MainProc:
-                  wkMsgid:
+           wkMsgId:
            wkMsgFile:
            wkMsgData);
-
   retField = *on;
   RETURN retField;
-
+end-proc;
-      /END-FREE
-     p SndSflMsg       E
 
 //--------------------------------------------------
 // Procedure name: CloseCurssor
 // Purpose:        Closes the SQL Cursor
 //--------------------------------------------------
-     p CloseCursor     B
+dcl-proc CloseCursor;
-     d CloseCursor     PI
+  dcl-pi CloseCursor end-pi;
-      /FREE
   if CursorOpen = *on;
     exec sql close DataCur;
-            if SQLSTT <> SQLSuccess;
+    if SQLSTT <> SQLSUCCESS;
       SQLProblem('Close DATACUR');
     endif;
     CursorOpen = *off;
   endif;
   RETURN;
-      /END-FREE
+end-proc;
-     p CloseCursor     E
 
 //--------------------------------------------------
 // Procedure name: SflClear
 // Purpose:        Clears the Subfile
 // Returns:
 //--------------------------------------------------
-     p SflClear        B
+dcl-proc SflClear;
-     d SflClear        PI
+  dcl-pi SflClear end-pi;
-      /FREE
   clear SflRRN;
   clear RcdsInSfl;
   scSflClr = *ON;
   write SFLCTL;
   scSflClr = *OFF;
   return;
-      /END-FREE
+end-proc;
-     p SflClear        E

5250_Subfile/README.md

@@ -18,13 +18,11 @@ This is a working application that allows display, selection and maintenance of
 
 ## General Notes
 
-Some of the programs use /Include statements, which are found in the Copy_Mbrs directory.  So to compile you will need to create and populate a source file named COPY_MBRS.
+Some of the programs use /Include statements, which are found in the Copy_Mbrs directory.
 
-The RPG code is free form, except that the D-Specs are fixed form. This probably allows more  developers who are still on older versions of the OS, or are still using the out of date SEU, to more easily use the code.  The code can be converted to totally free format using the free _**"JCRHFD - Rpg H,F,D to free form syntax"**_ command available at [JCRCMDS.COM](http://www.jcrcmds.com/jcrdown2.html#JCRHFD_tag). If there is interest I may post totally free form versions.
+The genesis of these programs was code that I wrote in RPG IV for a Fortune 500 retailer circa 2002-2004. The code was then cloned as a standard approach by another team leader. This code is a more modern version that I cleaned up in 2020 and restructured again in late 2023.
 
-The genesis of these programs was code that I wrote in RPG IV for a Fortune 500 retailer circa 2002-2004. The code was then cloned as a standard approach by another team leader.  This code is a more modern version that I cleaned up in 2020.
+My style tries to have consistent naming and I do not share field names between the RPG and the display files--I've seen too many accidental modifications in my support career.
-
-The style tries to have consistent naming and I do not share field names between the RPG and the display files--I've seen too many accidental modifications in my support career.
 
 The display file uses a private set of indicators, something I started doing to try to educate coworkers who were struggling with monolithic code where all 99 indicators were in use. You can also reset indicators and such in display files, but I prefer to do it myself.
 
@@ -41,6 +39,8 @@ The display file uses a private set of indicators, something I started doing to
   
   Conceptually, you can call this program from almost anywhere and control access to it  by whatever menuing or security system you have in place. The general user population would progably get Inquiry and Sales would have Maintenance. Selection could be used for any in-house program that needed to prompt for  a customer id number. 
   
+  Note that this version uses a static SQL cursor, where City and State selection criteria use a "between" predicate. This differs from [the originally posted version](https://github.com/SJLennon/IBM-i-RPG-Free-CLP-Code/blob/master/5250_Subfile/PMTCUSTR.SQLRPGLE) which used a dynamic cursor which had to be prepared when the selection criteria changed. I think a static cursor makes coding easier and can improve performance since it doesn't need a "prepare". Conversely, on large files this approach may hurt performance. However, I tested the program on PUB400.COM with 1 million records and there was no discernable performance hit.
+
 ### MTNCUSTR/MTNCUSTD
 
   RPG program that maintains a customer.  Customer id is provided as the first parameter. It also adds or displays a customer. Function is controlled by the second parameter. It is called from PMTCUSTR, but it could be called from any program that has a customer id available, or which needs to add a customer.
@@ -74,3 +74,35 @@ The window has a blue border of reverse image blanks. This will display consiste
 ### States.SQL
 
 SQL Code to create and populate the STATES table, which is a table of USA state names and their 2-character abbreviations.
+
+### Creating a large CUSTMAST
+
+I have provided a program that will create as large number of fairly realistic random CUSTMAST records. To get a decent distribution of City, State, ZIP values I used a USPS file which you will have to upload from the USPS site.
+
+#### LOADCUSTR.SQLRPGLE
+
+This clears CUSTMAST and repopulates it with an many randon records are you specify. It requires the CSZ file, below. Typical usage is `call loadcustr 1000` to load 1,000 records. 
+
+#### CSZ (City/State/ZIP) File
+
+This file contains real data, over 40,000 records, dowloaded from the USPS website.
+
+To create the CSZ file: 
+
+- Download  the City, State and Zip database from USPS as an Excel spreadsheet. It is a free download at this [link](https://www.unitedstateszipcodes.org/zip-code-database/).
+
+- Delete all columns except zip, type, primary city and state. Raname primary_city to city, save, but leave the spreadsheet open.
+
+- Select all data in the speadsheet (this will fill in starting and ending colums and rows later).
+
+- Using iACS "Data transfer to IBM i" upload the spreadsheet to file CSZ. 
+
+    - In the Actions tab choose "Create IBM i Database file" and follow the prompts.
+
+    - In "Change Data Options" set defaults of VARCHAR and INTEGER.
+
+    - Keep following the prompts. 
+
+    - Set Library/file to *yourlib*/CSZ.
+
+Read this [IBM article](https://www.ibm.com/support/pages/transferring-data-excel-using-access-client-solutions) on uploading data from Excel using Access Client Solutions if you need more help.

5250_Subfile/States.sql

@@ -1,6 +1,9 @@
 -- Build table of US State code and names
--- RUNSQLSTM SRCSTMF(states.sql) COMMIT(*NONE) ERRLVL(40)
+--  To run from the green screen, adjust the path below:
-set schema lennons1;
+-- RUNSQLSTM SRCSTMF('/home/LENNONS/IBMi_IFS_Dev/5250_Subfile/States.sql') COMMIT(*NONE) ERRLVL(40) 
+-- Our paste into Run SQL Scripts in iACS.
+-- Or run directly in VS Code with Code for IBM i extension.                                                 
+set schema lennonsb;   -- Change to your desired library
 drop table states;
 CREATE TABLE STATES ( 
 	STATE CHAR(2) CCSID 273 NOT NULL , 

APIs/GETJOBTR.RPGLE

@@ -20,11 +20,12 @@
 //            It was origially a standalone program. Perhaps it should
 //            be a service program and perhaps some of the diract API
 //            call should be in a service program.
+// 02/--/2024 Set for soource in IFS
 // -------------------------------------------------------------------
 ctl-opt debug option(*nodebugio: *srcstmt)
     dftactgrp(*no) actgrp(*caller)
     main(Main);
-/copy copy_mbrs,USPHDR
+/copy ../Copy_Mbrs/USPHDR.RPGLE
 //=== CRTUSRSPC (QUSCTRUS) Parameters ================================
 dcl-s CusName char(20) inz('GETJOBTR  QTEMP');
 dcl-s CusAttr char(10) inz('GETJOBTR  ');

APIs/GETOBJUC.CLLE

@@ -16,6 +16,8 @@ GETOBJUC: +
 /*            message fails. If this occurs, just continue and      */
 /*            *LIBL may appear in the message.                      */
 /* -----------------------------------------------------------------*/
+/* 02/--/2024 CPF7306 to allow for SQL created GETOBJUP member      */
+/* -----------------------------------------------------------------*/
 
 /* Input parameters */
   DCL VAR(&OBJECT)     TYPE(*CHAR) LEN(20)    /* Obj & lib */
@@ -58,6 +60,7 @@ GETOBJUC: +
       CRTDUPOBJ OBJ(GETOBJUP) FROMLIB(&FRMOBJLIB) OBJTYPE(*FILE) +
          TOLIB(QTEMP)
       ADDPFM FILE(QTEMP/GETOBJUP) MBR(GETOBJUP)
+      MONMSG MSGID(CPF7306)
       OVRDBF FILE(GETOBJUP) TOFILE(QTEMP/GETOBJUP) SECURE(*YES)
   ENDDO
 

APIs/GETOBJUP.SQL

@@ -0,0 +1,33 @@
+--  Generate SQL 
+--  Version:                   	V7R5M0 220415 
+--  Generated on:              	02/13/24 22:08:51 
+--  Relational Database:       	PUB400 
+--  Standards Option:          	Db2 for i 
+CREATE or REPLACE TABLE LENNONS1.GETOBJUP ( 
+--  SQL150B   10   REUSEDLT(*NO) in table GETOBJUP in LENNONS1 ignored. 
+--  SQL1505   20   Number of members for GETOBJUP in LENNONS1 not valid. 
+	OUJOBNAME CHAR(10) CCSID 37 NOT NULL DEFAULT '' , 
+	OUJOBUSER CHAR(10) CCSID 37 NOT NULL DEFAULT '' , 
+	OUJOBNUM CHAR(6) CCSID 37 NOT NULL DEFAULT '' , 
+	OUJOBTYPE CHAR(1) CCSID 37 NOT NULL DEFAULT '' )   
+	  
+	RCDFMT GETOBJU    ; 
+  
+LABEL ON TABLE LENNONS1.GETOBJUP 
+	IS 'Users of an object' ; 
+  
+LABEL ON COLUMN LENNONS1.GETOBJUP 
+( OUJOBNAME IS 'Job                 Name' , 
+	OUJOBUSER IS 'Job                 User' , 
+	OUJOBNUM IS 'Job                 Number' , 
+	OUJOBTYPE IS 'Type' ) ; 
+  
+LABEL ON COLUMN LENNONS1.GETOBJUP 
+( OUJOBNAME TEXT IS 'Job Name' , 
+	OUJOBUSER TEXT IS 'Job User' , 
+	OUJOBNUM TEXT IS 'Job Number' , 
+	OUJOBTYPE TEXT IS 'I=interact, other=non inter' ) ; 
+  
+GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE   
+ON LENNONS1.GETOBJUP TO LENNONS WITH GRANT OPTION ; 
+  

APIs/GETOBJUR.RPGLE

@@ -24,12 +24,13 @@
 //            1997. This code probably performs better than existing
 //            SQL interfaces. For most use cases performance may not
 //            be a consideration.
+// 02/--/2024 Set for source in IFS
 //--------------------------------------------------------------------
 ctl-opt debug option(*nodebugio: *srcstmt)
     dftactgrp(*no) actgrp(*caller)
     main(Main);
 dcl-f GETOBJUP usage(*output) usropn block(*yes);
-/copy copy_mbrs,USPHDR
+/copy ../Copy_Mbrs/USPHDR.RPGLE
 //=== CRTUSRSPC (QUSCTRUS) Parameters ================================
 dcl-ds *n;
     CusQName char(20);
@@ -51,7 +52,7 @@ dcl-s MSNStackE char(10) inz('*CTLBDY');
 dcl-s MSNStackC int(10) inz(1);
 dcl-s MSNMsgKey char(4);
 //=== List Object Locks List Entry Layout ============================
-dcl-ds LOLEntry based(loptr);
+dcl-ds LOLEntry based(LOPtr);
     LOJobName char(10);
     LOJobUser char(10);
     LOJobNum char(6);
@@ -74,17 +75,17 @@ dcl-ds APIError len(272);
 end-ds;
 //=== Misc Field Definitions =========================================
 dcl-s LolFmt char(8) inz('OBJL0100');
-dcl-s ObjMEM char(10);
+dcl-s ObjMem char(10);
 dcl-s NumJobs packed(5);
-dcl-c MaxJobs const(4); //Maximum jobs for detailed reporting.
+dcl-c MAXJOBS const(4); //Maximum jobs for detailed reporting.
-// If you increase MaxJobs, increase the message parameter by 30 bytes
+// If you increase MAXJOBS, increase the message parameter by 30 bytes
 // for each additional job.
 dcl-ds JobName26;
     SavJobName like(lojobname);
     SavJobUser like(lojobuser);
     SavJobNum like(lojobnum);
 end-ds;
-dcl-s Jobname28 char(28);
+dcl-s JobName28 char(28);
 dcl-s JobType char(1);
 //=== Parameters for SRTUSRSPC =======================================
 // SKeyStart - Array of key starting positions
@@ -193,7 +194,7 @@ dcl-proc Main ;
             pObjType:
             ObjMem:
             APIError);
-    exsr srtusrspc;
+    exsr SrtUsrSpc;
     // === Main Program Loop =========================================
     // Loop through the entries in the list
     exsr NxtJob;
@@ -213,11 +214,11 @@ dcl-proc Main ;
     endif;
     if pMsgYN='*YES';
         select;
-            when NumJobs >= 1 and NumJobs <=MaxJobs;
+            when NumJobs >= 1 and NumJobs <=MAXJOBS;
-                pMsgfld=%trimr(pMsgFld) + '.';
+                pMsgFld=%trimr(pMsgFld) + '.';
-            when NumJobs > MaxJobs;
+            when NumJobs > MAXJOBS;
-                pMsgfld=%trimr(pMsgFld) + ' plus ' +
+                pMsgFld=%trimr(pMsgFld) + ' plus ' +
-                %trim(%editc(NumJobs-MaxJobs:'J'))  +
+                %trim(%editc(NumJobs-MAXJOBS:'J'))  +
                 ' more.';
             other;
         endsl;
@@ -256,7 +257,7 @@ dcl-proc Main ;
     endsr;
     // === BldMsg ====================================================
 
-    // Adds current job to the message until MaxJobs have been added.
+    // Adds current job to the message until MAXJOBS have been added.
     begsr BldMsg;
         JobName28=%trimr(SavJobName) + '/' +
         %trimr(SavJobUser) + '/' +
@@ -269,8 +270,8 @@ dcl-proc Main ;
                 %trimr(pObjType) +
                 ' is in use by ' +
                 JobName28;
-            when NumJobs >= 2 and NumJobs <=MaxJobs;
+            when NumJobs >= 2 and NumJobs <=MAXJOBS;
-                pMsgFld=%trimr(pMsgfld) + ', ' +
+                pMsgFld=%trimr(pMsgFld) + ', ' +
                 JobName28;
         endsl;
     endsr;
@@ -298,10 +299,10 @@ dcl-proc Main ;
     // === Sort User Space ===========================================
 
     begsr SrtUsrSpc;
-        p_SRTUSRSPC(
+        p_srtusrspc(
             CusName:
             CusLib:
-            S#keys:
+            S#Keys:
             SKeyStart:
             SKeyLgth:
             SKeyAorD:
@@ -335,14 +336,14 @@ dcl-proc Main ;
         // === Create User Space =====================================
         // Allow for 100,000 entries, which should be more than enough
         APIEProv = 0;
-        CusIntSize=%size(UspHdr) + (%size(LOLentry)*100000);
+        CusIntSize=%size(UspHdr) + (%size(LOLEntry)*100000);
         UsrSpcCrt(
             CusQName:
             CusAttr:
             CusIntSize:
             CusIntVal:
             CusAut:
-            Custext);
+            CusText);
         // === Get Pointer to User Space =============================
         UsrSpcPointer(CusQName: UspPtr);
         // === Initialize requested outputs ==========================

APIs/LCKOBJ.CMD

@@ -0,0 +1,39 @@
+ LCKOBJ:     CMD        PROMPT('Get a lock on an object')
+ /*-----------------------------------------------------------------*/
+ /* CPP is LCKOBJC                                                  */
+ /* 02/00/97 LENNON Original writting                               */
+ /*-----------------------------------------------------------------*/
+             PARM       KWD(OBJ) TYPE(OBJSTUFF) MIN(1) +
+                          PROMPT('Object Name')
+
+             PARM       KWD(WAIT) TYPE(*DEC) LEN(5) DFT(*CLS) +
+                          RANGE(30 32767) SPCVAL((*CLS 99999) (0)) +
+                          PROMPT('Seconds to wait')
+
+             PARM       KWD(OPMAYCAN) TYPE(*CHAR) LEN(4) RSTD(*YES) +
+                          DFT(*NO) VALUES(*YES *NO) PROMPT('May +
+                          operator cancel job?')
+
+OBJSTUFF:    ELEM       TYPE(Q1) MIN(1) PROMPT('Object Name')
+
+             ELEM       TYPE(*CHAR) LEN(8) RSTD(*YES) VALUES(*AUTL +
+                          *BNDDIR *CLD *CRQD *CSI *CSPMAP *CSPTBL +
+                          *DEVD *DTAARA *DTADCT *DTAQ *FCT *FILE +
+                          *FNTRSC *FNTTBL *FORMDF *IPXD *LIB +
+                          *LOCALE *MENU *MODULE *MSGQ *NODL *NTBD +
+                          *NWSD *OVL *PAGDFN *PAGSEG *PDG *PGM +
+                          *PNLGRP *PSFCFG *QMFORM *QMQRY *QRYDFN +
+                          *SBSD *SCHIDX *SQLPKG *SRVPGM *SSND *S36 +
+                          *USRIDX *USRQ *USRSPC *WSCST) MIN(1) +
+                          PROMPT('Object Type')
+
+             ELEM       TYPE(*CHAR) LEN(8) RSTD(*YES) VALUES(*SHRRD +
+                          *SHRNUP *SHRUPD *EXCLRD *EXCL) MIN(1) +
+                          PROMPT('Lock state')
+
+             ELEM       TYPE(*NAME) LEN(10) SPCVAL((*FIRST)) +
+                          EXPR(*NO) PROMPT('Member, if data base file')
+
+ Q1:         QUAL       TYPE(*NAME) LEN(10) MIN(1)
+             QUAL       TYPE(*NAME) LEN(10) DFT(*LIBL) +
+                          SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library')

APIs/LCKOBJC.CLLE

@@ -0,0 +1,229 @@
+LCKOBJC: +
+  PGM PARM(&P_OBJ &P_WAIT &P_OPMAYCAN)
+/* -----------------------------------------------------------------*/
+/* Program attemps to lock an object with the requested lock state, */
+/* *EXCL, EXCLRD, etc.                                              */
+/* If it fails to obtain the lock in the specified time it talks to */
+/* the system operator, telling him which job are causing the       */
+/* ALCOBJ to fail. Operator can opt to cancel, or retry the ALCOBJ  */
+/* for 5, 10, 0r 30 minutes, or the default class wait time.        */
+/* -----------------------------------------------------------------*/
+/* Use the LCKOBJ command to invoke this program                    */
+/* -----------------------------------------------------------------*/
+/* 11/24/97 LENNON Original writing                                 */
+/* -----------------------------------------------------------------*/
+/* 10/05/2001 Sam Lennon. If a non file object is locked *EXCL then */
+/*            RTVOBJD to get real library name to put in the        */
+/*            message fails. If this occurs, just continue and      */
+/*            *LIBL may appear in the message.                      */
+/*            Change retry logic to allow entry of varying times.   */
+/*            Installed 9/2002.                                     */
+/* -----------------------------------------------------------------*/
+/* 02/--/2024 Build ALCOBJ commands for *FILE and all other to      */
+/*            handle Member being specified.                        */
+/*            Ignore *FIRST for member because it won't work        */
+/*            with the SQL service.                                 */
+/*            Add CONFLICT(*RQSRLS) to the ALCOBJ command.          */
+/* -----------------------------------------------------------------*/
+/* Input parameters */
+  DCL VAR(&P_OBJ)      TYPE(*CHAR) LEN(48)    /* Obj & lib */
+  DCL VAR(&P_WAIT)     TYPE(*DEC)  LEN(5)     /* Seconds */
+  DCL VAR(&P_OPMAYCAN) TYPE(*CHAR) LEN(4)     /* *YES *NO */
+
+/* Variables used in this program */
+  DCL VAR(&ORGWAIT)    TYPE(*DEC)  LEN(7)     /* Original wait*/
+  DCL VAR(&ELEMC)      TYPE(*CHAR) LEN(2)     /* # elements */
+  DCL VAR(&ELEMP)      TYPE(*DEC)  LEN(5)     /* # elements */
+  DCL VAR(&JOBTYPE)    TYPE(*CHAR) LEN(1)     /* 1=interactive */
+  DCL VAR(&LCKSTATE)   TYPE(*CHAR) LEN(8)     /* *SHRRD, etc */
+  DCL VAR(&KEYVAR)     TYPE(*CHAR) LEN(4)     /* messages */
+  DCL VAR(&MEMBER)     TYPE(*CHAR) LEN(10)    /* if *FILE */
+  DCL VAR(&OBJNAM)     TYPE(*CHAR) LEN(10)    /* Obj name  */
+  DCL VAR(&OBJLIB)     TYPE(*CHAR) LEN(10)    /* Obj lib   */
+  DCL VAR(&OPMSG)      TYPE(*CHAR) LEN(500)   /* No msg fld passed */
+  DCL VAR(&REPLY)      TYPE(*CHAR) LEN(2)     /* Oper Reply */
+  DCL VAR(&RETMSG)     TYPE(*CHAR) LEN(200)   /* From GETOBJUSR */
+  DCL VAR(&TYPE)       TYPE(*CHAR) LEN(8)     /* Obj type  */
+  DCL VAR(&WAIT)       TYPE(*DEC)  LEN(5)     /* Wait as num */
+  DCL VAR(&WAITC)      TYPE(*CHAR) LEN(5)     /* Wait as char */
+  DCL VAR(&WAITMIN)    TYPE(*DEC)  LEN(5)     /* Wait in mins */
+  DCL VAR(&WAITMSG)    TYPE(*CHAR) LEN(20)    /* temp field */
+  DCL VAR(&ALC_CMD)    TYPE(*CHAR) LEN(200)   /* ALLOBJ Command */
+
+ /* Error Handling Variables */
+  DCL VAR(&E_MSGID)    TYPE(*CHAR) LEN(7)
+  DCL VAR(&E_MSGF)     TYPE(*CHAR) LEN(10)
+  DCL VAR(&E_MSGFLIB)  TYPE(*CHAR) LEN(10)
+  DCL VAR(&E_MSGDTA)   TYPE(*CHAR) LEN(100)
+
+/* Catch unmonitored errors */
+  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
+
+/*==== Pre processing of input parameters =========================*/
+  /* &P_OBJ is a mixed list:                          */
+  /*    1 L2   binary # elements                      */
+  /*    3 L10  object name                            */
+  /*   13 L10  library                                */
+  /*   23 L8   object type                            */
+  /*   31 L8   lock state, *EXCL etc.                 */
+  /*   39 L10  member, if data base file              */
+
+  /* Get number of elements */
+  CHGVAR VAR(&ELEMC) VALUE(%SST(&P_OBJ 1 2))
+  CHGVAR VAR(&ELEMP) VALUE(%BIN(&ELEMC))
+
+  /* Extract elements from list.  First 3 are required. */
+  /* Obj and lib are considered 1 element */
+  CHGVAR VAR(&OBJNAM) VALUE(%SST(&P_OBJ 3 10))
+  CHGVAR VAR(&OBJLIB) VALUE(%SST(&P_OBJ 13 10))
+  CHGVAR VAR(&TYPE) VALUE(%SST(&P_OBJ 23 8))
+  CHGVAR VAR(&LCKSTATE) VALUE(%SST(&P_OBJ 31 8))
+
+  /* Member is optional */
+  IF COND(&ELEMP *GT 3) THEN(DO)
+      CHGVAR VAR(&MEMBER) VALUE(%SST(&P_OBJ 39 10))
+  ENDDO
+
+/* Set the default wait value                                */
+/* Wait 99999 means use *CLS as the wait value on the ALCOBJ */
+  IF COND(&P_WAIT = 99999) THEN(DO)
+      RTVJOBA TYPE(&JOBTYPE) DFTWAIT(&ORGWAIT)
+  ENDDO
+  ELSE CMD(DO)
+      CHGVAR VAR(&ORGWAIT) VALUE(&P_WAIT)
+  ENDDO
+  CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
+
+/*=== Attempt to allocate the object ==============================*/
+RETRY: +
+/* Convert *LIBL/*CURLIB into a real name, if possible,        */
+/* for clarity in operator message. This may fail if the object*/
+/* is already allocated *EXCL.  If so, we just continue.       */
+  IF COND(&OBJLIB *EQ '*LIBL') THEN(DO)
+      RTVOBJD OBJ(&OBJLIB/&OBJNAM) OBJTYPE(&TYPE) RTNLIB(&OBJLIB)
+      MONMSG MSGID(CPF9803) /* Cannot Allocate */
+  ENDDO
+
+/* Blank member is syntax error in ALLOBJ, but if you do        */
+/* not specify a member it is the same as specifying *FIRST     */
+/* so get the *FIRST actual name.                               */
+/* If not available just put in *FIRST and GETOBJUR will sort   */
+/* it out.                                                      */
+  IF COND((&TYPE *EQ '*FILE') *AND (&MEMBER *EQ ' ') ) THEN(DO)
+    RTVMBRD FILE(&OBJLIB/&OBJNAM) RTNMBR(&MEMBER)
+    MONMSG MSGID(CPF3018)  EXEC(DO) /* Not available */
+      CHGVAR VAR(&MEMBER) VALUE('*FIRST')
+    ENDDO
+  ENDDO
+
+  CHGVAR VAR(&WAITC) VALUE(&WAIT)
+  IF COND(&TYPE *NE '*FILE') THEN(DO)
+    /* Not a file: build command like this, without MEMBER */         
+    /* ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATE &MEMBER)) WAIT(&WAITC) +
+         CONFLICT(*RQSRLS) */
+    CHGVAR VAR(&ALC_CMD) +
+      VALUE('ALCOBJ OBJ(('  +
+        *TCAT &OBJLIB *TCAT '/' *TCAT &OBJNAM *TCAT ' ' +
+        *CAT &TYPE *TCAT ' ' *CAT &LCKSTATE +
+        *TCAT ')) WAIT(' *TCAT &WAITC *TCAT ')' +
+        *TCAT ' CONFLICT(*RQSRLS) ' +
+      )
+  ENDDO
+  ELSE CMD(DO)
+    /* Is a file: build command like this, with MEMBER */         
+    /* ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATER)) WAIT(&WAITC) +
+         CONFLICT(*RQSRLS) */
+  
+    CHGVAR VAR(&ALC_CMD) +
+    VALUE('ALCOBJ OBJ(('  +
+      *TCAT &OBJLIB *TCAT '/' *TCAT &OBJNAM *TCAT ' ' +
+      *CAT &TYPE *TCAT ' ' *CAT &LCKSTATE + 
+      *TCAT ' ' *CAT &MEMBER +
+      *TCAT ')) WAIT(' *TCAT &WAITC *TCAT ')' +
+      *TCAT ' CONFLICT(*RQSRLS) ' +
+    )
+  ENDDO
+
+  /* If fail to obtain lock, then we must analyse the situation */
+  /* SNDUSRMSG MSG(&ALC_CMD) MSGTYPE(*INFO) TOMSGQ(*EXT) */
+  CALL PGM(QCMDEXC) PARM(&ALC_CMD 200)
+  MONMSG MSGID(CPF1002) EXEC(DO) /* Not allocated */
+
+      /* If wait is longer than 60 seconds, make minutes for */
+      /* message and round up to next minute.                */
+      IF COND(&WAIT > 60 *AND &WAIT *NE 0) THEN(DO)
+          CHGVAR VAR(&WAITMIN) VALUE((&WAIT + 59) / 60)
+      /*  EDTVAR CHROUT(&WAITMSG) NUMINP(&WAITMIN) */
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMIN)
+          CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
+          IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' minutes. ')
+      ENDDO
+      ELSE CMD(DO)
+      /*  EDTVAR CHROUT(&WAITMSG) NUMINP(&WAIT)*/
+          CHGVAR VAR(&WAITMSG) VALUE(&WAIT)
+          CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
+          IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' seconds. ')
+      ENDDO
+
+      /* Find out who is using the object.  By now all the   */
+      /* locks may have been freed.  If so, retry the ALCOBJ */
+      GETOBJUSR OBJECT(&OBJLIB/&OBJNAM) TYPE(&TYPE) MEMBER(&MEMBER) +
+         MSGFLD(&RETMSG)
+      IF COND(&RETMSG *EQ ' ') THEN(GOTO CMDLBL(RETRY))
+
+      /* Build a message for the operator. */
+      CHGVAR VAR(&OPMSG) VALUE(&RETMSG *TCAT '  Waited for ' *CAT +
+         &WAITMSG *TCAT '  Please attempt to resolve the conflict, +
+         then enter R to retry, or 5 to retry for 5 minutes, 10 to +
+         retry for 10 minutes or 30 to retry for 30 minutes.')
+
+      /* If he may cancel the job, let him know */
+      IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
+          CHGVAR VAR(&OPMSG) VALUE(&OPMSG *TCAT ' (Or enter C to +
+             cancel.)')
+      ENDDO
+
+      /* Talk to the operator */
+TALKTOOP: +
+      SNDUSRMSG MSG(&OPMSG) MSGTYPE(*INQ) TOUSR(*REQUESTER) +
+         MSGRPY(&REPLY) VALUES(5 10 30 R C)
+
+      /* R = retry for originally specified time  */
+      IF COND(&REPLY *EQ 'R') THEN(DO)
+          CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
+          GOTO CMDLBL(RETRY)
+      ENDDO
+
+      /* Send a CPF9898 escape message if operator cancels */
+      IF COND(&REPLY *EQ 'C') THEN(DO)
+          IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
+              SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('PGM +
+                 was canceled by a response of C') MSGTYPE(*ESCAPE)
+          ENDDO
+          ELSE (DO)
+             GOTO CMDLBL(TALKTOOP)
+          ENDDO
+      ENDDO
+
+      /* Else set new specified wait time and retry */
+      CHGVAR VAR(&WAIT) VALUE(&REPLY)
+      CHGVAR VAR(&WAIT) VALUE(&WAIT * 60)
+
+      GOTO CMDLBL(RETRY)
+
+  ENDDO /* MONMSG CPF1002 */
+
+/*=== If we get this far we have the object locked as requested.===*/
+
+/* End of program */
+  GOTO CMDLBL(ENDPGM)
+
+/*=== Error handler - resend diagnostic & escape messages =========*/
+ERROR: +
+  MOVPGMMSG  MSGTYPE(*DIAG)
+  RSNESCMSG
+  
+ENDPGM: +
+ENDPGM

APIs/T0.CLLE

@@ -0,0 +1,5 @@
+             PGM
+             DCL        VAR(&MSG) TYPE(*CHAR) LEN(200)
+             GETOBJUSR  OBJECT(QIWS/QCUSTCDT) TYPE(*FILE) MSGFLD(&MSG)
+             SNDMSG     MSG(&MSG) TOUSR(*REQUESTER)
+             ENDPGM

APIs/T1.CLLE

@@ -0,0 +1,6 @@
+PGM
+             DCL        VAR(&MSG) TYPE(*CHAR) LEN(200)
+             GETOBJUSR  OBJECT(QSYS/LENNONS2) TYPE(*LIB) MSGFLD(&MSG)
+             SNDMSG     MSG(&MSG) TOUSR(*REQUESTER)
+
+             ENDPGM

APIs/T2.CLLE

@@ -0,0 +1,15 @@
+PGM
+             DCL        VAR(&MSG) TYPE(*CHAR) LEN(200)
+             GETOBJUSR  OBJECT(QSYS/QSYS) TYPE(*LIB) MSGFLD(&MSG) +
+                          RETFILE(*YES)
+             SNDMSG     MSG(&MSG) TOUSR(*REQUESTER)
+             QRY        FILE(QTEMP/GETOBJUP)
+
+
+             GETOBJUSR  OBJECT(QSYS/LENNONS2) TYPE(*LIB) MSGFLD(&MSG)
+             SNDMSG     MSG(&MSG) TOUSR(*REQUESTER)
+
+             GETOBJUSR  OBJECT(QSYS/LENNONS1) TYPE(*LIB) MSGFLD(&MSG)
+             SNDMSG     MSG(&MSG) TOUSR(*REQUESTER)
+
+             ENDPGM

APIs/T9.CLP

@@ -0,0 +1,6 @@
+             PGM
+             DCL        VAR(&MSG) TYPE(*CHAR) LEN(200)
+             GETOBJUSR  OBJECT(QIWS/QCUSTCDT) TYPE(*FILE) +
+                          MSGFLD(&MSG) RETFILE(*YES)
+             SNDMSG     MSG(&MSG) TOUSR(*REQUESTER)
+             ENDPGM

APIs/T9ALLOC1.CLLE

@@ -0,0 +1,4 @@
+             PGM                                                  
+             ALCOBJ     OBJ((QIWS/QCUSTCDT *FILE *SHRRD)) WAIT(0) 
+             DLYJOB     DLY(90)                                   
+             ENDPGM                                               

APIs/T9ALLOCMNY.CLP

@@ -0,0 +1,10 @@
+             PGM
+             SBMJOB     CMD(CALL PGM(T9ALLOC1)) JOB(CUSTLST) +
+                          JOBQ(QUSRNOMAX)
+             SBMJOB     CMD(CALL PGM(T9ALLOC1)) JOB(INV_UPD) +
+                          JOBQ(QUSRNOMAX)
+             SBMJOB     CMD(CALL PGM(T9ALLOC1)) JOB(DAILYORD) +
+                          JOBQ(QUSRNOMAX)
+             SBMJOB     CMD(CALL PGM(T9ALLOC1)) JOB(YTD_RPT) +
+                          JOBQ(QUSRNOMAX)
+             ENDPGM

APIs_SQL/GETOBJUR.SQLRPGLE

@@ -42,8 +42,8 @@ ctl-opt debug option(*nodebugio: *srcstmt)
     bnddir('UTIL_BND':'SQL_BND')
     main(Main);
 //=== Prototypes =====================================================
-/include copy_mbrs,Srv_Msg_P
+/include ../Copy_Mbrs/SRV_MSG_P.RPGLE
-/include copy_mbrs,Srv_SQL_P
+/include ../Copy_Mbrs/SRV_SQL_P.RPGLE
 
 // Gets job type entry for this job.
 // Returns:  JobType has the job type. I=interactive, B=batch, etc.
@@ -56,8 +56,7 @@ end-pr;
 // Input Parameters
 //   1) pObject is object name (10c) + object library (10c)
 //   2) pObjType is *FILE, *DTAARA, etc., standard OS/400 type
-//   3) pObjMem is the member for files, or *NONE if just want users
+//   3) pObjMem is the member for files
-//           of the file.
 //   4) pMsgYN is *YES to create a message.
 //   5) pFileYN is *YES if file GETOBJUP is to be created in QTEMP
 // Output Parameter
@@ -65,18 +64,18 @@ end-pr;
 
 //=== Global Definitions =============================================
 dcl-s JobName28 char(28);   // like '580065/JOBNM/USER''
-dcl-c SQLSuccess       '00000';
+dcl-c SQLSUCCESS       '00000';
-dcl-c SQLNoData        '02000';
+dcl-c SQLNODATA        '02000';
-dcl-c SQLNoMoreData    '02000';
+dcl-c SQLNOMOREDATA    '02000';
-dcl-c SQLProcWarning   '01548';
+dcl-c SQLPROCWARNING   '01548';
-dcl-c SQLFileNotFound  '42704';
+dcl-c SQLFILENOTFOUND  '42704';
 
 //====================================================================
 dcl-proc Main ;
 
     //=== Misc Field Definitions =====================================
     dcl-s NumJobs packed(5);
-    dcl-c MaxJobs const(4); //Maximum jobs for detailed reporting.
+    dcl-c MAXJOBS const(4); //Maximum jobs for detailed reporting.
     // If you increase MaxJobs, increase the message parameter by 30 bytes
     // for each additional job.
     dcl-s JobName26 char(26);   // is name(10) User(10) number(6)
@@ -96,6 +95,7 @@ dcl-proc Main ;
     dcl-s theLibrary char(10);
     dcl-s theObject char(10);
     dcl-s j int(10);
+    dcl-s wkMem like(pObjMem);
     // ---------------------------------------------------------
     dcl-pi *n extpgm('GETOBJUR');
         pObject char(20);
@@ -117,7 +117,7 @@ dcl-proc Main ;
 
     if pFileYN='*YES';
         exec sql drop table qtemp.GETOBJUP;
-        if SQLSTATE <> SQLSuccess and SQLSTATE <> SQLFileNotFound;
+        if SQLSTATE <> SQLSUCCESS and SQLSTATE <> SQLFILENOTFOUND;
             SQLProblem('Delete GETOBJUP');
         endif;
         exec sql declare global temporary table GETOBJUP (
@@ -131,8 +131,8 @@ dcl-proc Main ;
             OUOBJTYPE CHAR(10),
             OUOBJMBR CHAR(10)
         );
-        if SQLSTATE <> SQLSuccess;
+        if SQLSTATE <> SQLSUCCESS;
-            SQLProblem('Declare global tempory table GETOBJUP');
+            SQLProblem('Declare global temporary table GETOBJUP');
         endif;
     endif;
 
@@ -146,28 +146,38 @@ dcl-proc Main ;
     JobOBJTYPE = pObjType;
     JobOBJMBR = pObjMem;
 
+    // *FIRST doesn't work with SQL services. ALCOBJ puts a lock on
+    // the *FIRST member if you don't specify one and if the file
+    // is locked *EXCL then we can't get the first member name, so
+    // we leave it blank. Shouldn't matter because we're looking for
+    // any lock by any job.
+    if pObjMem = '*FIRST';
+        wkMem = ' ';
+    else;
+        wkMem = pObjMem;
+    endif;
 
     // === Find the locks ============================================
     exec sql declare Lock_Cursor cursor for
         select distinct JOB_NAME
         from QSYS2.OBJECT_LOCK_INFO
-        where SYSTEM_OBJECT_SCHEMA = :thelibrary
+        where SYSTEM_OBJECT_SCHEMA = :theLibrary
-          and SYSTEM_OBJECT_NAME = :theobject
+          and SYSTEM_OBJECT_NAME = :theObject
-          and OBJECT_TYPE = :pobjtype
+          and OBJECT_TYPE = :pObjType
           and ifnull(SYSTEM_TABLE_MEMBER,' ') =
-            case when :pobjtype = '*FILE' and :pobjmem <> '*ALL' then  :pobjmem
+            case when :pObjType = '*FILE' and :wkMem <> ' ' then  :wkMem
                  else ' '
             END
         order by JOB_NAME
     ;
     exec sql open Lock_Cursor ;
-    if SQLSTT <> SQLSuccess;
+    if SQLSTT <> SQLSUCCESS;
         SQLProblem('open Lock_Cursor');
     endif;
 
     // Loop through the cursor, building requested outputs
     fetchNext();
-    dow SQLSTT <> SQLNoData;
+    dow SQLSTT <> SQLNODATA;
         NumJobs += 1;
         if pFileYN='*YES';
             // Build JobName26, parm for GetJobType
@@ -192,11 +202,11 @@ dcl-proc Main ;
     // === End of Program ============================================
     if pMsgYN='*YES';
         select;
-            when NumJobs >= 1 and NumJobs <=MaxJobs;
+            when NumJobs >= 1 and NumJobs <= MAXJOBS;
-                pMsgfld=%trimr(pMsgFld) + '.';
+                pMsgFld = %trimr(pMsgFld) + '.';
-            when NumJobs > MaxJobs;
+            when NumJobs > MAXJOBS;
-                pMsgfld=%trimr(pMsgFld) + ' plus '
+                pMsgFld = %trimr(pMsgFld) + ' plus '
-                  +  %trim(%editc(NumJobs-MaxJobs:'J'))
+                  +  %trim(%editc(NumJobs-MAXJOBS:'J'))
                   + ' more.';
             other;
         endsl;
@@ -215,8 +225,8 @@ dcl-proc Main ;
                 %trimr(pObjType) +
                 ' is in use by ' +
                 JobName28;
-            when NumJobs >= 2 and NumJobs <=MaxJobs;
+            when NumJobs >= 2 and NumJobs <=MAXJOBS;
-                pMsgFld=%trimr(pMsgfld) + ', ' +
+                pMsgFld=%trimr(pMsgFld) + ', ' +
                 JobName28;
         endsl;
     endsr;
@@ -226,7 +236,7 @@ dcl-proc Main ;
     begsr WriteRec;
         JobNM28 = JobName28;
         exec sql insert into qtemp.GETOBJUP values(:JobSQLDS);
-        if SQLSTT <> SQLSuccess;
+        if SQLSTT <> SQLSUCCESS;
             sqlProblem('Insert into GETOBJUP');
         endif;
     endsr;
@@ -235,9 +245,9 @@ end-proc;
 // === fetchNext =====================================================
 dcl-proc fetchNext;
     exec sql fetch next from Lock_Cursor into :JobName28;
-    if SQLSTT <> SQLSuccess
+    if SQLSTT <> SQLSUCCESS
-        and SQLSTT <> SQLNOData
+        and SQLSTT <> SQLNODATA
-        and SQLSTT <> SQLProcWarning;
+        and SQLSTT <> SQLPROCWARNING;
         SQLProblem('fetchNext');
     endif;
 end-proc;

APIs_SQL/LCKOBJ.CMD

@@ -0,0 +1,39 @@
+ LCKOBJ:     CMD        PROMPT('Get a lock on an object')
+ /*-----------------------------------------------------------------*/
+ /* CPP is LCKOBJC                                                  */
+ /* 02/00/97 LENNON Original writting                               */
+ /*-----------------------------------------------------------------*/
+             PARM       KWD(OBJ) TYPE(OBJSTUFF) MIN(1) +
+                          PROMPT('Object Name')
+
+             PARM       KWD(WAIT) TYPE(*DEC) LEN(5) DFT(*CLS) +
+                          RANGE(30 32767) SPCVAL((*CLS 99999) (0)) +
+                          PROMPT('Seconds to wait')
+
+             PARM       KWD(OPMAYCAN) TYPE(*CHAR) LEN(4) RSTD(*YES) +
+                          DFT(*NO) VALUES(*YES *NO) PROMPT('May +
+                          operator cancel job?')
+
+OBJSTUFF:    ELEM       TYPE(Q1) MIN(1) PROMPT('Object Name')
+
+             ELEM       TYPE(*CHAR) LEN(8) RSTD(*YES) VALUES(*AUTL +
+                          *BNDDIR *CLD *CRQD *CSI *CSPMAP *CSPTBL +
+                          *DEVD *DTAARA *DTADCT *DTAQ *FCT *FILE +
+                          *FNTRSC *FNTTBL *FORMDF *IPXD *LIB +
+                          *LOCALE *MENU *MODULE *MSGQ *NODL *NTBD +
+                          *NWSD *OVL *PAGDFN *PAGSEG *PDG *PGM +
+                          *PNLGRP *PSFCFG *QMFORM *QMQRY *QRYDFN +
+                          *SBSD *SCHIDX *SQLPKG *SRVPGM *SSND *S36 +
+                          *USRIDX *USRQ *USRSPC *WSCST) MIN(1) +
+                          PROMPT('Object Type')
+
+             ELEM       TYPE(*CHAR) LEN(8) RSTD(*YES) VALUES(*SHRRD +
+                          *SHRNUP *SHRUPD *EXCLRD *EXCL) MIN(1) +
+                          PROMPT('Lock state')
+
+             ELEM       TYPE(*NAME) LEN(10)  +
+                          EXPR(*NO) PROMPT('Member, if data base file')
+
+ Q1:         QUAL       TYPE(*NAME) LEN(10) MIN(1)
+             QUAL       TYPE(*NAME) LEN(10) DFT(*LIBL) +
+                          SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library')

APIs_SQL/LCKOBJC.CLLE

@@ -0,0 +1,229 @@
+LCKOBJC: +
+  PGM PARM(&P_OBJ &P_WAIT &P_OPMAYCAN)
+/* -----------------------------------------------------------------*/
+/* Program attemps to lock an object with the requested lock state, */
+/* *EXCL, EXCLRD, etc.                                              */
+/* If it fails to obtain the lock in the specified time it talks to */
+/* the system operator, telling him which job are causing the       */
+/* ALCOBJ to fail. Operator can opt to cancel, or retry the ALCOBJ  */
+/* for 5, 10, 0r 30 minutes, or the default class wait time.        */
+/* -----------------------------------------------------------------*/
+/* Use the LCKOBJ command to invoke this program                    */
+/* -----------------------------------------------------------------*/
+/* 11/24/97 LENNON Original writing                                 */
+/* -----------------------------------------------------------------*/
+/* 10/05/2001 Sam Lennon. If a non file object is locked *EXCL then */
+/*            RTVOBJD to get real library name to put in the        */
+/*            message fails. If this occurs, just continue and      */
+/*            *LIBL may appear in the message.                      */
+/*            Change retry logic to allow entry of varying times.   */
+/*            Installed 9/2002.                                     */
+/* -----------------------------------------------------------------*/
+/* 02/--/2024 Build ALCOBJ commands for *FILE and all other to      */
+/*            handle Member being specified.                        */
+/*            Ignore *FIRST for member because it won't work        */
+/*            with the SQL service.                                 */
+/*            Add CONFLICT(*RQSRLS) to the ALCOBJ command.          */
+/* -----------------------------------------------------------------*/
+/* Input parameters */
+  DCL VAR(&P_OBJ)      TYPE(*CHAR) LEN(48)    /* Obj & lib */
+  DCL VAR(&P_WAIT)     TYPE(*DEC)  LEN(5)     /* Seconds */
+  DCL VAR(&P_OPMAYCAN) TYPE(*CHAR) LEN(4)     /* *YES *NO */
+
+/* Variables used in this program */
+  DCL VAR(&ORGWAIT)    TYPE(*DEC)  LEN(7)     /* Original wait*/
+  DCL VAR(&ELEMC)      TYPE(*CHAR) LEN(2)     /* # elements */
+  DCL VAR(&ELEMP)      TYPE(*DEC)  LEN(5)     /* # elements */
+  DCL VAR(&JOBTYPE)    TYPE(*CHAR) LEN(1)     /* 1=interactive */
+  DCL VAR(&LCKSTATE)   TYPE(*CHAR) LEN(8)     /* *SHRRD, etc */
+  DCL VAR(&KEYVAR)     TYPE(*CHAR) LEN(4)     /* messages */
+  DCL VAR(&MEMBER)     TYPE(*CHAR) LEN(10)    /* if *FILE */
+  DCL VAR(&OBJNAM)     TYPE(*CHAR) LEN(10)    /* Obj name  */
+  DCL VAR(&OBJLIB)     TYPE(*CHAR) LEN(10)    /* Obj lib   */
+  DCL VAR(&OPMSG)      TYPE(*CHAR) LEN(500)   /* No msg fld passed */
+  DCL VAR(&REPLY)      TYPE(*CHAR) LEN(2)     /* Oper Reply */
+  DCL VAR(&RETMSG)     TYPE(*CHAR) LEN(200)   /* From GETOBJUSR */
+  DCL VAR(&TYPE)       TYPE(*CHAR) LEN(8)     /* Obj type  */
+  DCL VAR(&WAIT)       TYPE(*DEC)  LEN(5)     /* Wait as num */
+  DCL VAR(&WAITC)      TYPE(*CHAR) LEN(5)     /* Wait as char */
+  DCL VAR(&WAITMIN)    TYPE(*DEC)  LEN(5)     /* Wait in mins */
+  DCL VAR(&WAITMSG)    TYPE(*CHAR) LEN(20)    /* temp field */
+  DCL VAR(&ALC_CMD)    TYPE(*CHAR) LEN(200)   /* ALLOBJ Command */
+
+ /* Error Handling Variables */
+  DCL VAR(&E_MSGID)    TYPE(*CHAR) LEN(7)
+  DCL VAR(&E_MSGF)     TYPE(*CHAR) LEN(10)
+  DCL VAR(&E_MSGFLIB)  TYPE(*CHAR) LEN(10)
+  DCL VAR(&E_MSGDTA)   TYPE(*CHAR) LEN(100)
+
+/* Catch unmonitored errors */
+  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
+
+/*==== Pre processing of input parameters =========================*/
+  /* &P_OBJ is a mixed list:                          */
+  /*    1 L2   binary # elements                      */
+  /*    3 L10  object name                            */
+  /*   13 L10  library                                */
+  /*   23 L8   object type                            */
+  /*   31 L8   lock state, *EXCL etc.                 */
+  /*   39 L10  member, if data base file              */
+
+  /* Get number of elements */
+  CHGVAR VAR(&ELEMC) VALUE(%SST(&P_OBJ 1 2))
+  CHGVAR VAR(&ELEMP) VALUE(%BIN(&ELEMC))
+
+  /* Extract elements from list.  First 3 are required. */
+  /* Obj and lib are considered 1 element */
+  CHGVAR VAR(&OBJNAM) VALUE(%SST(&P_OBJ 3 10))
+  CHGVAR VAR(&OBJLIB) VALUE(%SST(&P_OBJ 13 10))
+  CHGVAR VAR(&TYPE) VALUE(%SST(&P_OBJ 23 8))
+  CHGVAR VAR(&LCKSTATE) VALUE(%SST(&P_OBJ 31 8))
+
+  /* Member is optional */
+  IF COND(&ELEMP *GT 3) THEN(DO)
+      CHGVAR VAR(&MEMBER) VALUE(%SST(&P_OBJ 39 10))
+  ENDDO
+
+/* Set the default wait value                                */
+/* Wait 99999 means use *CLS as the wait value on the ALCOBJ */
+  IF COND(&P_WAIT = 99999) THEN(DO)
+      RTVJOBA TYPE(&JOBTYPE) DFTWAIT(&ORGWAIT)
+  ENDDO
+  ELSE CMD(DO)
+      CHGVAR VAR(&ORGWAIT) VALUE(&P_WAIT)
+  ENDDO
+  CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
+
+/*=== Attempt to allocate the object ==============================*/
+RETRY: +
+/* Convert *LIBL/*CURLIB into a real name, if possible,        */
+/* for clarity in operator message. This may fail if the object*/
+/* is already allocated *EXCL.  If so, we just continue.       */
+  IF COND(&OBJLIB *EQ '*LIBL') THEN(DO)
+      RTVOBJD OBJ(&OBJLIB/&OBJNAM) OBJTYPE(&TYPE) RTNLIB(&OBJLIB)
+      MONMSG MSGID(CPF9803) /* Cannot Allocate */
+  ENDDO
+
+/* Blank member is syntax error in ALLOBJ, but if you do        */
+/* not specify a member it is the same as specifying *FIRST     */
+/* so get the *FIRST actual name.                               */
+/* If not available just put in *FIRST and GETOBJUR will sort   */
+/* it out.                                                      */
+  IF COND((&TYPE *EQ '*FILE') *AND (&MEMBER *EQ ' ') ) THEN(DO)
+    RTVMBRD FILE(&OBJLIB/&OBJNAM) RTNMBR(&MEMBER)
+    MONMSG MSGID(CPF3018)  EXEC(DO) /* Not available */
+      CHGVAR VAR(&MEMBER) VALUE('*FIRST')
+    ENDDO
+  ENDDO
+
+  CHGVAR VAR(&WAITC) VALUE(&WAIT)
+  IF COND(&TYPE *NE '*FILE') THEN(DO)
+    /* Not a file: build command like this, without MEMBER */         
+    /* ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATE &MEMBER)) WAIT(&WAITC) +
+         CONFLICT(*RQSRLS) */
+    CHGVAR VAR(&ALC_CMD) +
+      VALUE('ALCOBJ OBJ(('  +
+        *TCAT &OBJLIB *TCAT '/' *TCAT &OBJNAM *TCAT ' ' +
+        *CAT &TYPE *TCAT ' ' *CAT &LCKSTATE +
+        *TCAT ')) WAIT(' *TCAT &WAITC *TCAT ')' +
+        *TCAT ' CONFLICT(*RQSRLS) ' +
+      )
+  ENDDO
+  ELSE CMD(DO)
+    /* Is a file: build command like this, with MEMBER */         
+    /* ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATER)) WAIT(&WAITC) +
+         CONFLICT(*RQSRLS) */
+  
+    CHGVAR VAR(&ALC_CMD) +
+    VALUE('ALCOBJ OBJ(('  +
+      *TCAT &OBJLIB *TCAT '/' *TCAT &OBJNAM *TCAT ' ' +
+      *CAT &TYPE *TCAT ' ' *CAT &LCKSTATE + 
+      *TCAT ' ' *CAT &MEMBER +
+      *TCAT ')) WAIT(' *TCAT &WAITC *TCAT ')' +
+      *TCAT ' CONFLICT(*RQSRLS) ' +
+    )
+  ENDDO
+
+  /* If fail to obtain lock, then we must analyse the situation */
+  /* SNDUSRMSG MSG(&ALC_CMD) MSGTYPE(*INFO) TOMSGQ(*EXT) */
+  CALL PGM(QCMDEXC) PARM(&ALC_CMD 200)
+  MONMSG MSGID(CPF1002) EXEC(DO) /* Not allocated */
+
+      /* If wait is longer than 60 seconds, make minutes for */
+      /* message and round up to next minute.                */
+      IF COND(&WAIT > 60 *AND &WAIT *NE 0) THEN(DO)
+          CHGVAR VAR(&WAITMIN) VALUE((&WAIT + 59) / 60)
+      /*  EDTVAR CHROUT(&WAITMSG) NUMINP(&WAITMIN) */
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMIN)
+          CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
+          IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' minutes. ')
+      ENDDO
+      ELSE CMD(DO)
+      /*  EDTVAR CHROUT(&WAITMSG) NUMINP(&WAIT)*/
+          CHGVAR VAR(&WAITMSG) VALUE(&WAIT)
+          CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
+          IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' seconds. ')
+      ENDDO
+
+      /* Find out who is using the object.  By now all the   */
+      /* locks may have been freed.  If so, retry the ALCOBJ */
+      GETOBJUSR OBJECT(&OBJLIB/&OBJNAM) TYPE(&TYPE) MEMBER(&MEMBER) +
+         MSGFLD(&RETMSG)
+      IF COND(&RETMSG *EQ ' ') THEN(GOTO CMDLBL(RETRY))
+
+      /* Build a message for the operator. */
+      CHGVAR VAR(&OPMSG) VALUE(&RETMSG *TCAT '  Waited for ' *CAT +
+         &WAITMSG *TCAT '  Please attempt to resolve the conflict, +
+         then enter R to retry, or 5 to retry for 5 minutes, 10 to +
+         retry for 10 minutes or 30 to retry for 30 minutes.')
+
+      /* If he may cancel the job, let him know */
+      IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
+          CHGVAR VAR(&OPMSG) VALUE(&OPMSG *TCAT ' (Or enter C to +
+             cancel.)')
+      ENDDO
+
+      /* Talk to the operator */
+TALKTOOP: +
+      SNDUSRMSG MSG(&OPMSG) MSGTYPE(*INQ) TOUSR(*REQUESTER) +
+         MSGRPY(&REPLY) VALUES(5 10 30 R C)
+
+      /* R = retry for originally specified time  */
+      IF COND(&REPLY *EQ 'R') THEN(DO)
+          CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
+          GOTO CMDLBL(RETRY)
+      ENDDO
+
+      /* Send a CPF9898 escape message if operator cancels */
+      IF COND(&REPLY *EQ 'C') THEN(DO)
+          IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
+              SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('PGM +
+                 was canceled by a response of C') MSGTYPE(*ESCAPE)
+          ENDDO
+          ELSE (DO)
+             GOTO CMDLBL(TALKTOOP)
+          ENDDO
+      ENDDO
+
+      /* Else set new specified wait time and retry */
+      CHGVAR VAR(&WAIT) VALUE(&REPLY)
+      CHGVAR VAR(&WAIT) VALUE(&WAIT * 60)
+
+      GOTO CMDLBL(RETRY)
+
+  ENDDO /* MONMSG CPF1002 */
+
+/*=== If we get this far we have the object locked as requested.===*/
+
+/* End of program */
+  GOTO CMDLBL(ENDPGM)
+
+/*=== Error handler - resend diagnostic & escape messages =========*/
+ERROR: +
+  MOVPGMMSG  MSGTYPE(*DIAG)
+  RSNESCMSG
+  
+ENDPGM: +
+ENDPGM

APIs_SQL/LCKOBJCorg.CLLE

@@ -0,0 +1,199 @@
+LCKOBJC: +
+  PGM PARM(&P_OBJ &P_WAIT &P_OPMAYCAN)
+/* -----------------------------------------------------------------*/
+/* Program attemps to lock an object with the requested lock state, */
+/* *EXCL, EXCLRD, etc.                                              */
+/* If it fails to obtain the lock in the specified time it talks to */
+/* the system operator, telling him which job are causing the       */
+/* ALCOBJ to fail. Operator can opt to cancel, or retry the ALCOBJ  */
+/* for 5, 10, 0r 30 minutes, or the default class wait time.        */
+/* -----------------------------------------------------------------*/
+/* Use the LCKOBJ command to invoke this program                    */
+/* -----------------------------------------------------------------*/
+/* 11/24/97 LENNON Original writing                                 */
+/* -----------------------------------------------------------------*/
+/* 10/05/2001 Sam Lennon. If a non file object is locked *EXCL then */
+/*            RTVOBJD to get real library name to put in the        */
+/*            message fails. If this occurs, just continue and      */
+/*            *LIBL may appear in the message.                      */
+/*            Change retry logic to allow entry of varying times.   */
+/*            Installed 9/2002.                                     */
+/* -----------------------------------------------------------------*/
+/* Input parameters */
+  DCL VAR(&P_OBJ)      TYPE(*CHAR) LEN(48)    /* Obj & lib */
+  DCL VAR(&P_WAIT)     TYPE(*DEC)  LEN(5)     /* Seconds */
+  DCL VAR(&P_OPMAYCAN) TYPE(*CHAR) LEN(4)     /* *YES *NO */
+
+/* Variables used in this program */
+  DCL VAR(&ORGWAIT)    TYPE(*DEC)  LEN(7)     /* Original wait*/
+  DCL VAR(&ELEMC)      TYPE(*CHAR) LEN(2)     /* # elements */
+  DCL VAR(&ELEMP)      TYPE(*DEC)  LEN(5)     /* # elements */
+  DCL VAR(&JOBTYPE)    TYPE(*CHAR) LEN(1)     /* 1=interactive */
+  DCL VAR(&LCKSTATE)   TYPE(*CHAR) LEN(8)     /* *SHRRD, etc */
+  DCL VAR(&KEYVAR)     TYPE(*CHAR) LEN(4)     /* messages */
+  DCL VAR(&MEMBER)     TYPE(*CHAR) LEN(10)    /* if *FILE */
+  DCL VAR(&OBJNAM)     TYPE(*CHAR) LEN(10)    /* Obj name  */
+  DCL VAR(&OBJLIB)     TYPE(*CHAR) LEN(10)    /* Obj lib   */
+  DCL VAR(&OPMSG)      TYPE(*CHAR) LEN(500)   /* No msg fld passed */
+  DCL VAR(&REPLY)      TYPE(*CHAR) LEN(2)     /* Oper Reply */
+  DCL VAR(&RETMSG)     TYPE(*CHAR) LEN(200)   /* From GETOBJUSR */
+  DCL VAR(&TYPE)       TYPE(*CHAR) LEN(8)     /* Obj type  */
+  DCL VAR(&WAIT)       TYPE(*DEC)  LEN(5)     /* Wait as num */
+  DCL VAR(&WAITC)      TYPE(*CHAR) LEN(5)     /* Wait as char */
+  DCL VAR(&WAITMIN)    TYPE(*DEC)  LEN(5)     /* Wait in mins */
+  DCL VAR(&WAITMSG)    TYPE(*CHAR) LEN(20)     /* temp field */
+
+ /* Error Handling Variables */
+  DCL VAR(&E_MSGID)    TYPE(*CHAR) LEN(7)
+  DCL VAR(&E_MSGF)     TYPE(*CHAR) LEN(10)
+  DCL VAR(&E_MSGFLIB)  TYPE(*CHAR) LEN(10)
+  DCL VAR(&E_MSGDTA)   TYPE(*CHAR) LEN(100)
+
+/* Catch unmonitored errors */
+  MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
+
+/*==== Pre processing of input parameters =========================*/
+  /* &P_OBJ is a mixed list:                          */
+  /*    1 L2   binary # elements                      */
+  /*    3 L10  object name                            */
+  /*   13 L10  library                                */
+  /*   23 L8   object type                            */
+  /*   31 L8   lock state, *EXCL etc.                 */
+  /*   39 L10  member, if data base file              */
+
+  /* Get number of elements */
+  CHGVAR VAR(&ELEMC) VALUE(%SST(&P_OBJ 1 2))
+  CHGVAR VAR(&ELEMP) VALUE(%BIN(&ELEMC))
+
+  /* Extract elements from list.  First 3 are required. */
+  /* Obj and lib are considered 1 element */
+  CHGVAR VAR(&OBJNAM) VALUE(%SST(&P_OBJ 3 10))
+  CHGVAR VAR(&OBJLIB) VALUE(%SST(&P_OBJ 13 10))
+  CHGVAR VAR(&TYPE) VALUE(%SST(&P_OBJ 23 8))
+  CHGVAR VAR(&LCKSTATE) VALUE(%SST(&P_OBJ 31 8))
+
+  /* Member is optional */
+  IF COND(&ELEMP *GT 3) THEN(DO)
+      CHGVAR VAR(&MEMBER) VALUE(%SST(&P_OBJ 39 10))
+  ENDDO
+
+/* If MEMBER is blank, change to *FIRST. *FIRST is ignored on   */
+/* non-file objects, but blanks causes a syntax error in ALCOBJ */
+  /* IF COND(&MEMBER *EQ ' ') THEN(DO) */
+      /* CHGVAR VAR(&MEMBER) VALUE('*FIRST') */
+  /* ENDDO */
+
+/* Set the default wait value                                */
+/* Wait 99999 means use *CLS as the wait value on the ALCOBJ */
+  IF COND(&P_WAIT = 99999) THEN(DO)
+      RTVJOBA TYPE(&JOBTYPE) DFTWAIT(&ORGWAIT)
+  ENDDO
+  ELSE CMD(DO)
+      CHGVAR VAR(&ORGWAIT) VALUE(&P_WAIT)
+  ENDDO
+  CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
+
+/*==== Convert *LIBL/*CURLIB into a real name, if possible,========*/
+/*     for clarity in operator message. This may fail if the object*/
+/*     is already allocated *EXCL.  If so, we just continue.       */
+  IF COND(&OBJLIB *EQ '*LIBL') THEN(DO)
+      RTVOBJD OBJ(&OBJLIB/&OBJNAM) OBJTYPE(&TYPE) RTNLIB(&OBJLIB)
+      MONMSG MSGID(CPF9803) /* Cannot Allocate */
+  ENDDO
+
+/* Blank member is syntax error in ALLOBJ, but if you do        */
+/* not specify a member it is the same as specifying *FIRST     */
+/* so get the *FIRST actual name.                               */
+  IF COND((&TYPE *EQ '*FILE') *AND (&MEMBER *EQ ' ') ) THEN(DO)
+    RTVMBRD FILE(&OBJLIB/&OBJNAM) RTNMBR(&MEMBER)
+  ENDDO
+
+/*=== Attempt to allocate the object ==============================*/
+RETRY: +
+  CHGVAR VAR(&WAITC) VALUE(&WAIT)
+  ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATE &MEMBER)) WAIT(&WAITC)
+
+  /* If fail to obtain lock, then we must analyse the situation */
+  MONMSG MSGID(CPF1002) EXEC(DO) /* Not allocated */
+
+      /* If wait is longer than 60 seconds, make minutes for */
+      /* message and round up to next minute.                */
+      IF COND(&WAIT > 60 *AND &WAIT *NE 0) THEN(DO)
+          CHGVAR VAR(&WAITMIN) VALUE((&WAIT + 59) / 60)
+      /*  EDTVAR CHROUT(&WAITMSG) NUMINP(&WAITMIN) */
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMIN)
+          CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
+          IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' minutes. ')
+      ENDDO
+      ELSE CMD(DO)
+      /*  EDTVAR CHROUT(&WAITMSG) NUMINP(&WAIT)*/
+          CHGVAR VAR(&WAITMSG) VALUE(&WAIT)
+          CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
+          IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
+          CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' seconds. ')
+      ENDDO
+
+      /* Find out who is using the object.  By now all the   */
+      /* locks may have been freed.  If so, retry the ALCOBJ */
+      GETOBJUSR OBJECT(&OBJLIB/&OBJNAM) TYPE(&TYPE) MEMBER(&MEMBER) +
+         MSGFLD(&RETMSG)
+      IF COND(&RETMSG *EQ ' ') THEN(GOTO CMDLBL(RETRY))
+
+      /* Build a message for the operator. */
+      CHGVAR VAR(&OPMSG) VALUE(&RETMSG *TCAT '  Waited for ' *CAT +
+         &WAITMSG *TCAT '  Please attempt to resolve the conflict, +
+         then enter R to retry, or 5 to retry for 5 minutes, 10 to +
+         retry for 10 minutes or 30 to retry for 30 minutes.')
+
+      /* If he may cancel the job, let him know */
+      IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
+          CHGVAR VAR(&OPMSG) VALUE(&OPMSG *TCAT ' (Or enter C to +
+             cancel.)')
+      ENDDO
+
+      /* Talk to the operator */
+TALKTOOP: +
+      SNDUSRMSG MSG(&OPMSG) MSGTYPE(*INQ) TOUSR(*REQUESTER) +
+         MSGRPY(&REPLY) VALUES(5 10 30 R C)
+
+      /* R = retry for originally specified time  */
+      IF COND(&REPLY *EQ 'R') THEN(DO)
+          CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
+          GOTO CMDLBL(RETRY)
+      ENDDO
+
+      /* Send a CPF9898 escape message if operator cancels */
+      IF COND(&REPLY *EQ 'C') THEN(DO)
+          IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
+              SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('PGM +
+                 was canceled by a response of C') MSGTYPE(*ESCAPE)
+          ENDDO
+          ELSE (DO)
+             GOTO CMDLBL(TALKTOOP)
+          ENDDO
+      ENDDO
+
+      /* Else set new specified wait time and retry */
+      CHGVAR VAR(&WAIT) VALUE(&REPLY)
+      CHGVAR VAR(&WAIT) VALUE(&WAIT * 60)
+
+      GOTO CMDLBL(RETRY)
+
+  ENDDO /* MONMSG CPF1002 */
+
+/*=== If we get this far we have the object locked as requested.===*/
+
+/* End of program */
+  GOTO CMDLBL(ENDPGM)
+
+/*=== Error handler - resend any trapped escape message ===========*/
+ERROR: +
+  RCVMSG MSGTYPE(*LAST) MSGDTA(&E_MSGDTA) MSGID(&E_MSGID) +
+     MSGF(&E_MSGF) MSGFLIB(&E_MSGFLIB)
+  MONMSG MSGID(CPF0000) /* Just in case */
+  SNDPGMMSG MSGID(&E_MSGID) MSGF(&E_MSGFLIB/&E_MSGF) +
+     MSGDTA(&E_MSGDTA) MSGTYPE(*ESCAPE)
+  MONMSG MSGID(CPF0000) /* Just in case */
+ENDPGM: +
+  ENDPGM

APIs_SQL/T2.CLLE

@@ -1,5 +1,5 @@
 PGM
-/* Masic test, using a library as the oject of choice. */
+/* Basic test, using a library as the oject of choice. */
 /* Return just a file. Message will be blank.          */
 
              DCL        VAR(&MSG) TYPE(*CHAR) LEN(200)

APIs_SQL/T9ALLOC1.CLLE

@@ -2,6 +2,6 @@
 
 /* Create a lock and delay. Called by T9ALLOCMNY        */
 
-             ALCOBJ     OBJ((QIWS/QCUSTCDT *FILE *SHRRD)) WAIT(0)
+             ALCOBJ     OBJ((lennons1/qclsrc *FILE *SHRRD)) WAIT(0)
-             DLYJOB     DLY(90)
+             DLYJOB     DLY(180)
              ENDPGM

APIs_SQL/T9ALLOCMNY.CLLE

@@ -1,11 +1,17 @@
              PGM
 /***************************************************************/
-/* Creates locks on QIWS/QCUSTCDT to test GETOBJUR.            */
+/* Creates locks on LENNONS/QCLSRC to test GETOBJUR.            */
 /* Call T9DSPMNY to report the locks.                          */
 /***************************************************************/
-
+            DCL        VAR(&JOBTYP) TYPE(*CHAR) LEN(1)
+            RTVJOBA    TYPE(&JOBTYP)
+            IF         COND(&JOBTYP *EQ '1') THEN(DO)              
+                SBMJOB     CMD(CALL PGM(T9ALLOCMNY) ) +
+                            JOB(T9ALLOCMNY) JOBQ(QUSRNOMAX)                        
+                RETURN                                           
+            ENDDO                                                  
 /* Create an interactive lock                                  */
-             ALCOBJ     OBJ((QIWS/QCUSTCDT *FILE *SHRRD))
+             ALCOBJ     OBJ((lennons1/qclsrc *FILE *SHRRD))
 
 /* Create some batch locks. Submitted jobs wait for 90 seconds */
 /* so you can call T9DSPMAY to see the locks.                  */
@@ -17,4 +23,4 @@
                           JOBQ(QUSRNOMAX)
              SBMJOB     CMD(CALL PGM(T9ALLOC1)) JOB(YTD_RPT) +
                           JOBQ(QUSRNOMAX)
-             ENDPGM
+ENDPGM:      ENDPGM

APIs_SQL/T9DSPMNY.CLLE

@@ -3,7 +3,7 @@
 /* Display locks after running T9ALLOCMNY              */
 
              DCL        VAR(&MSG) TYPE(*CHAR) LEN(200)
-             GETOBJUSR  OBJECT(QIWS/QCUSTCDT) TYPE(*FILE) +
+             GETOBJUSR  OBJECT(lennons1/qclsrc) TYPE(*FILE) +
                           MSGFLD(&MSG) RETFILE(*YES)
              SNDMSG     MSG(&MSG) TOUSR(*REQUESTER)
              QRY        FILE(QTEMP/GETOBJUP)

APIs_SQL/t90.clle

@@ -0,0 +1,10 @@
+pgm     
+             DCL        VAR(&MSG) TYPE(*CHAR) LEN(200)
+
+             GETOBJUSR  OBJECT(lennons1/qclsrc) TYPE(*file) +
+                          MSGFLD(&MSG) RETFILE(*YES)
+
+             SNDMSG     MSG(&MSG) TOUSR(*REQUESTER)
+             QRY        FILE(QTEMP/GETOBJUP)
+
+             ENDPGM

BASE36/BASE36_Px.RPGLE

@@ -0,0 +1,5 @@
+**FREE
+// === BASE36ADD prototype ==========================================
+dcl-pr BASE36ADD varchar(50);
+    theValue varchar(50) const;
+end-pr;

BASE36/BTBR.SQLRPGLE

@@ -17,7 +17,7 @@
 ctl-opt debug  option(*nodebugio: *srcstmt) dftactgrp(*no)
         actgrp(*caller) bnddir('SRV_BASE36')
         main(Main);
-/include base36,base36_p
+/include ../base36/base36_p.rpgle
 
 dcl-proc Main ;
 dcl-pi *N extpgm('BTBR');

BASE36/BTIR.RPGLE

@@ -11,7 +11,7 @@
 ctl-opt debug  option(*nodebugio: *srcstmt) dftactgrp(*no)
         actgrp(*caller) bnddir('SRV_BASE36')
         main(Main);
-/include base36,base36_p
+/include ../base36/base36_p.rpgle
 
 dcl-f   BTID    WORKSTN     INFDS(dfInfDS) Usropn;
 dcl-ds dfInfDS;
@@ -20,7 +20,7 @@ end-ds;
 
 dcl-c   F03     x'33';
 dcl-c   F05     x'35';
-dcl-s   ValVar  varchar(20);
+dcl-s   valVar  varchar(20);
 dcl-s   j       int(10);
 
 dcl-ds  *N;     // Rolling screen fields
@@ -61,14 +61,14 @@ dow Key <> F03;
 
     // Roll values up the screen
     for j = 1 to %elem(Values)-1;
-        Values(j) = Values(J+1);
+        Values(j) = Values(j+1);
     endfor;
     Val18 = Val;
 
     // Increment by 1
     valVar = %trim(val);
-    valVar = BASE36ADD(ValVar);
+    valVar = BASE36ADD(valVar);
-    Val = ValVar;
+    Val = valVar;
     exfmt SCREEN;
 enddo;
 

BASE36/SRV_BASE36.RPGLE

@@ -24,7 +24,7 @@
 
 ctl-opt debug nomain option(*nodebugio: *srcstmt) ;
 
-/include BASE36,BASE36_P
+/include ../BASE36/BASE36_P.RPGLE
 
 dcl-proc BASE36ADD export ;
     dcl-pi BASE36ADD varchar(50);
@@ -35,8 +35,8 @@ dcl-s wkValue like(PI_Value);
 dcl-s inx int(10);
 
 // Ascending values of a postion is A,B,...,Y,Z,0,1,2,...,7,8,9.
-dcl-c From 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
+dcl-c FROM 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
-dcl-c To   'BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789A';
+dcl-c TO   'BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789A';
 
 wkValue = PI_Value;
 // Increment the last position in the input value. If it now is
@@ -44,9 +44,9 @@ wkValue = PI_Value;
 // so move to the prior input value field and repeat.
 inx = %len(PI_Value);
 dow inx > 0;
-    %subst(wkValue:inx:1) = %xlate(From:To:%subst(wkValue:inx:1));
+    %subst(wkValue:inx:1) = %xlate(FROM:TO:%subst(wkValue:inx:1));
     // if %subst(wkValue:inx:1) <> 'A';  // Not rolled over
-    if %subst(wkValue:inx:1) <> %subst(To:%size(To):1) ;  // Not rolled over
+    if %subst(wkValue:inx:1) <> %subst(TO:%size(TO):1) ;  // Not rolled over
         leave;
     endif;
     inx -= 1;

Copy_Mbrs/AIDBYTES.RPGLE

@@ -0,0 +1,51 @@
+**FREE
+// 5250 Attention Indicator (AID) definitions
+dcl-c F01 const(x'31');
+dcl-c F02 const(x'32');
+dcl-c F03 const(x'33');
+dcl-c F04 const(x'34');
+dcl-c F05 const(x'35');
+dcl-c F06 const(x'36');
+dcl-c F07 const(x'37');
+dcl-c F08 const(x'38');
+dcl-c F09 const(x'39');
+dcl-c F10 const(x'3A');
+dcl-c F11 const(x'3B');
+dcl-c F12 const(x'3C');
+dcl-c F13 const(x'B1');
+dcl-c F14 const(x'B2');
+dcl-c F15 const(x'B3');
+dcl-c F16 const(x'B4');
+dcl-c F17 const(x'B5');
+dcl-c F18 const(x'B6');
+dcl-c F19 const(x'B7');
+dcl-c F20 const(x'B8');
+dcl-c F21 const(x'B9');
+dcl-c F22 const(x'BA');
+dcl-c F23 const(x'BB');
+dcl-c F24 const(x'BC');
+// Page Down/Roll Up
+dcl-c RollUp         const(x'F5');
+dcl-c PageDown       const(x'F5');
+// Page Up/Roll Down
+dcl-c RollDown       const(x'F4');
+dcl-c PageUp         const(x'F4');
+// Enter
+dcl-c Enter          const(x'F1');
+dcl-c Home           const(x'F8');
+ //Mouse events linked to DDS MOUBTN keyword
+dcl-c ME00 const(x'70');
+dcl-c ME01 const(x'71');
+dcl-c ME02 const(x'72');
+dcl-c ME03 const(x'73');
+dcl-c ME04 const(x'74');
+dcl-c ME05 const(x'75');
+dcl-c ME06 const(x'76');
+dcl-c ME07 const(x'77');
+dcl-c ME08 const(x'78');
+dcl-c ME09 const(x'79');
+dcl-c ME10 const(x'7A');
+dcl-c ME11 const(x'7B');
+dcl-c ME12 const(x'7C');
+dcl-c ME13 const(x'7D');
+dcl-c ME14 const(x'7E');

Copy_Mbrs/BASE36_P.RPGLE

@@ -0,0 +1,5 @@
+**FREE                                                               
+// === BASE36ADD prototype ==========================================
+dcl-pr BASE36ADD varchar(50);                                        
+    theValue varchar(50) const;                                      
+end-pr;                                                              

Copy_Mbrs/README.md

@@ -2,30 +2,34 @@
 
 These are source files that will be copied into programs using /COPY or /INCLUDE
 
-* ##AIDBTYE
+* ##AIDBTYE.RPGLE
 
     5250 Attention ID Definitions. These are the value that are returned in byte 369 of the display file indicator data structure when a screen entry is made.
 
-* SRV_MSG_P
+* SRV_MSG_P.RPGLE
 
      Prototype definitions for procedures in the SRV_MSG service program.
 
-* SRV_STR_P
+* SRV_RAND_P.RPGLE
 
-     Prototype definitions for procedures in the SRV_STR service program.
+     Prototype definitions for procedures in the SRV_RANDOM service program.
 
-* SRV_SQL_P
+* SRV_SQL_P.RPGLE
 
      Prorotype definitions for procedures in the SQL_SRV service program.
 
-* USADRVAL_P
+* SRV_STR_P.RPGLE
+
+     Prototype definitions for procedures in the SRV_STR service program.
+
+* USADRVAL_P.RPGLE
 
      Prototype for the USADRVAL service program.
 
-* USADRVALDS
+* USADRVALDS.RPGLE
 
      Template Data Structure for the USADRVAL parameters.
 
-* USPHDR
+* USPHDR.RPGLE
 
      User Space Header Layout.

Copy_Mbrs/SRV_MSG_P.RPGLE

@@ -1,34 +1,33 @@
 
        //=== Prototypes for SRV_MSG routines ========================
        //============================================================
-     D SndMsgPgmQ      pr                                                       Send Msg to PGM Q
+       dcl-pr SndMsgPgmQ;   // Send Msg to PGM Q
-     D  pMsgQ                        10
+        *n char(10);                      // pMsgQ
-     D  pMsgid                        7
+        *n char(7);                       // pMsgid
-     D  pMsgFile                     10
+        *n char(10);                      // pMsgFile
-     D  pMsgDta                     512    options(*NOPASS)
+        *n varchar(512) options(*nopass); // pMsgDta
-     D                                     Varying
+       end-pr;
        //============================================================
-     D ClrMsgPgmQ      pr              N                                        Clear PGM Msg Q
+       dcl-pr ClrMsgPgmQ ind; // Clear PGM Msg Q
-     D pPgmMsgQ                      10
+        *n char(10);            // pPgmMsgQ
-
+       end-pr;
        //============================================================
-     D SndEscMsg       pr                                                       Send ESC Msg
+       dcl-pr SndEscMsg;        // Send ESC Msg
-     D piMsg                        512a   Const Varying
+        *n varchar(512) const;             // piMsg
-     D pStackEnt                     10i 0 Const options(*nopass)
+        *n int(10) const options(*nopass); // pStackEnt
-
+       end-pr;
        //============================================================
-     D SndInfMsg       pr                                                       Send INF Msg
+       dcl-pr SndInfMsg;        // Send INF Msg
-     D piMsg                        512a   Const Varying
+        *n varchar(512) const;    // piMsg
-
+       end-pr;
        //============================================================
-     D JobLogMsg       Pr
+       dcl-pr JobLogMsg;
-     D piMsg                        512a   Value Varying                        Msg to job log
+        *n varchar(512) value; // piMsg  Msg to job log
-
+       end-pr;
        //============================================================
-     D Show            pr                  extpgm('SHOW')                       Show popup msg
+       dcl-pr Show extpgm('SHOW'); // Show popup msg
-     D piPext                      8192a   Const Varying
+        *n varchar(8192) const; // piPext
-     D piMsgId                        7a   Const options(*NOPASS)
+        *n char(7) const options(*nopass); // piMsgId
-     d piMsgFile                     21a   Const options(*NOPASS)
+        *n char(21) const options(*nopass); // piMsgFile
-
+       end-pr;
-
        //=== End of Prototypes forSRV_MSG Routines ==================

Copy_Mbrs/SRV_SQL_P.RPGLE

@@ -1,4 +1,6 @@
-       //============================================================
+**free
-        Dcl-PR SQLProblem ; // Report SQL Problem
+// === Prototype for SRV_SQL routines =========================
+dcl-pr SQLProblem ; // Report SQL Problem                    
      pDebugMsg      varchar(200) const;                         
-        End-PR;
+end-pr;
+// === End of Prototype for SRV_SQL routines ==================

Copy_Mbrs/SRV_STR_P.RPGLE

@@ -1,8 +1,7 @@
-
+**FREE
 //=== Prototypes for SRV_STR routines ========================
 //============================================================
-     d CenterStr       pr           256a   varying
+dcl-pr CenterStr varchar(256);
-     d InStr                        256a   varying const
+    *n varchar(256) const; // InStr
-     d
+end-pr;
-
 //=== End of Prototypes forSRV_STR Routines ==================

Copy_Mbrs/USPHDR.RPGLE

@@ -1,25 +1,26 @@
-
+**free
 //=== USPHDR Description =============================================
 // The list APIs which return data in a user space put a standard
 // header at the start of the user space.  This descibes the header.
 //=== Basing Pointer for Header ======================================
-     D UspPtr          s               *   inz(*Null)
+ dcl-s UspPtr pointer inz(*null);
 //=== User Space Header Layout =======================================
-     D UspHdr          ds                  based(UspPtr)
+ dcl-ds UspHdr based(uspptr);
-     D UspH                         192a
+  UspH char(192);
-     D  UspUser                      64a   overlay(UspH:1)
+  UspUser char(64) overlay(usph:1);
-     D  UspSize                      10i 0 overlay(UspH:65)
+  UspSize int(10) overlay(usph:65);
-     D  UspInfSts                     1a   overlay(UspH:104)
+  UspInfSts char(1) overlay(usph:104);
-     D   UspICmpl      c                   const('C')
+  UspSpSize int(10) overlay(usph:105);
-     D   UspIPrtl      c                   const('P')
+  UspInOff int(10) overlay(usph:109);
-     D   UspIIncp      c                   const('I')
+  UspInSize int(10) overlay(usph:113);
-     D  UspSpSize                    10i 0 overlay(UspH:105)
+  UspHdrOfs int(10) overlay(usph:117);
-     D  UspInOff                     10i 0 overlay(UspH:109)
+  UspHdrSize int(10) overlay(usph:121);
-     D  UspInSize                    10i 0 overlay(UspH:113)
+  UspLstOfs int(10) overlay(usph:125);
-     D  UspHdrOfs                    10i 0 overlay(UspH:117)
+  UspLstSize int(10) overlay(usph:129);
-     D  UspHdrSize                   10i 0 overlay(UspH:121)
+  UspLst#Ent int(10) overlay(usph:133);
-     D  UspLstOfs                    10i 0 overlay(UspH:125)
+  UspLstEntSz int(10) overlay(usph:137);
-     D  UspLstSize                   10i 0 overlay(UspH:129)
+ end-ds;
-     D  UspLst#Ent                   10i 0 overlay(UspH:133)
+// UspInfSts values
-     D  UspLstEntSz                  10i 0 overlay(UspH:137)
+ dcl-c UspICmpl const('C');
-
+ dcl-c UspIPrtl const('P');
+ dcl-c UspIIncp const('I');

DATEADJ/DATEADJR.RPGLE

@@ -13,7 +13,7 @@ ctl-opt option(*nodebugio: *srcstmt)
   actgrp(*new)
   main(Main);
 ctl-opt BndDir('UTIL_BND');
-/COPY copy_mbrs,Srv_Msg_P
+/COPY ../Copy_Mbrs/SRV_MSG_P.RPGLE
 dcl-pr getSpecFmts extpgm('DATEADJC');
   jobfmt char(4);
   sysvalfmt char(3);

DATEADJ/ReadMe.md

@@ -4,7 +4,7 @@ Date arithmetic in CL programs is limited and lacks the simplicity and scope fou
 
 The DATEADJ command adds the functionality of RPG date handling to CL programs. 
 
-DATEADJ adds or subtracts days, months or years from a date and returns an adjusted date. Input and output dates can be in almost any format that RPG recognizes.
+DATEADJ adds or subtracts days, months or years from a date and returns an adjusted date. Input and output dates can be in almost any format that RPG recognizes. It can also be used to just change the format of a date by specifying an adjustment of 0.
 
 A prompted DATEADJ command looks like this:
 

DATEADJ/T1R.RPGLE

@@ -2,8 +2,8 @@
 ctl-opt DftActGrp(*NO) ActGrp(*new) option(*nodebugio: *srcstmt)
 main(Main);
 ctl-opt BndDir('UTIL_BND');
-/COPY copy_mbrs,Srv_Msg_P
+/COPY ../Copy_Mbrs/SRV_MSG_P.RPGLE
-/COPY copy_mbrs,Prt_p
+/COPY ../Copy_Mbrs/PRT_P.RPGLE
 
 dcl-proc Main;
 
@@ -48,7 +48,7 @@ dcl-proc Main;
   head.inType = 'Type';
   head.outDate = 'OutDate';
   head.outFmt = 'OutFmt';
-  PRT(head :'*HEAD') ;
+  PRT(head :'*H1') ;
 
   // === Test default stuff ====
   inType = '*DAYS';

DATE_UDF/DATE_SQL.RPGLE

@@ -1,3 +1,4 @@
+**free
 /title SQL UDFs to convert numeric to true dates
 //===============================================================
 // The DATE_SQL service program contains routines that are
@@ -49,37 +50,40 @@
 // 3) Run the CREATE_FNSQL statements to register to SQL
 //===============================================================
 
-     H NoMain
+Ctl-Opt NoMain;
 //=== Prototypes ================================================
-     D Date_YMD        pr
+Dcl-PR Date_YMD;
-     D  NumericDate                   8p 0 const
+    NumericDate    Packed(8:0) const;
-     d  RealDate                       d
+    RealDate       Date;
-     D  Indicators                    5i 0 dim(1)
+    Indicators     Int(5)     dim(1);
-     D  RetInd                        5i 0
+    RetInd         Int(5);
-     d  SQLSTATE                      5a
+    SQLSTATE       Char(5);
-     d  FuncName                    517a   varying
+    FuncName       Varchar(517);
-     d  SpecificName                128a   varying
+    SpecificName   Varchar(128);
-     d  ErrText                    1000a   varying
+    ErrText        Varchar(1000);
+End-PR;
 
-     D Date_CYMD       pr
+Dcl-PR Date_CYMD;
-     D  NumericDate                   8p 0 const
+    NumericDate    Packed(8:0) const;
-     d  RealDate                       d
+    RealDate       Date;
-     D  Indicators                    5i 0 dim(1)
+    Indicators     Int(5)     dim(1);
-     D  RetInd                        5i 0
+    RetInd         Int(5);
-     d  SQLSTATE                      5a
+    SQLSTATE       Char(5);
-     d  FuncName                    517a   varying
+    FuncName       Varchar(517);
-     d  SpecificName                128a   varying
+    SpecificName   Varchar(128);
-     d  ErrText                    1000a   varying
+    ErrText        Varchar(1000);
+End-PR;
 
-     D Date_MDY        pr
+Dcl-PR Date_MDY;
-     D  NumericDate                   8p 0 const
+    NumericDate    Packed(8:0) const;
-     d  RealDate                       d
+    RealDate       Date;
-     D  Indicators                    5i 0 dim(1)
+    Indicators     Int(5)     dim(1);
-     D  RetInd                        5i 0
+    RetInd         Int(5);
-     d  SQLSTATE                      5a
+    SQLSTATE       Char(5);
-     d  FuncName                    517a   varying
+    FuncName       Varchar(517);
-     d  SpecificName                128a   varying
+    SpecificName   Varchar(128);
-     d  ErrText                    1000a   varying
+    ErrText        Varchar(1000);
+End-PR;
 
 //===============================================================
 // DATE_YMD
@@ -92,18 +96,18 @@
 // If input date is valid, then a true date.
 // If input date is invalid, returns null with warning 01H99.
 
-     p Date_YMD        b                   export
+Dcl-Proc Date_YMD export;
-     d Date_YMD        pi
+    Dcl-PI Date_YMD;
-     d  pDateIn                       8p 0 const
+        pDateIn        Packed(8:0) const;
-     d  pDateOut                       d
+        pDateOut       Date;
-     d  pIndicators                   5i 0 dim(1)
+        pIndicators    Int(5)     dim(1);
-     d  pRetInd                       5i 0
+        pRetInd        Int(5);
-     d  pSQLSTATE                     5a
+        pSQLSTATE      Char(5);
-     d  pFuncName                   517a   varying
+        pFuncName      Varchar(517);
-     d  pSpecificName               128a   varying
+        pSpecificNam   Varchar(128);
-     d  pErrText                   1000a   varying
+        pErrText       Varchar(1000);
+    End-PI;
 
-      /FREE
     pRetInd = 0;
     pSQLSTATE = '00000';
     monitor;
@@ -122,8 +126,7 @@
         pErrText = %char(pDateIn) + ' is not a (numeric) date';
     endmon;
     return;
-      /END-FREE
+End-Proc;
-     p Date_YMD        e
 
 //===============================================================
 // DATE_CYMD
@@ -136,18 +139,18 @@
 // If input date is valid, then a true date.
 // If input date is invalid, returns null with warning 01H99.
 
-     p Date_CYMD       b                   export
+Dcl-Proc Date_CYMD export;
-     d Date_CYMD       pi
+    Dcl-PI Date_CYMD;
-     d  pDateIn                       8p 0 const
+        pDateIn        Packed(8:0) const;
-     d  pDateOut                       d
+        pDateOut       Date;
-     d  pIndicators                   5i 0 dim(1)
+        pIndicators    Int(5)     dim(1);
-     d  pRetInd                       5i 0
+        pRetInd        Int(5);
-     d  pSQLSTATE                     5a
+        pSQLSTATE      Char(5);
-     d  pFuncName                   517a   varying
+        pFuncName      Varchar(517);
-     d  pSpecificName               128a   varying
+        pSpecificNam   Varchar(128);
-     d  pErrText                   1000a   varying
+        pErrText       Varchar(1000);
+    End-PI;
 
-      /FREE
     pRetInd = 0;
     pSQLSTATE = '00000';
     monitor;
@@ -159,8 +162,7 @@
         pErrText = %char(pDateIn) + ' is not a (numeric) date';
     endmon;
     return;
-      /END-FREE
+End-Proc;
-     p Date_CYMD       e
 
 //===============================================================
 // DATE_MDY
@@ -173,18 +175,18 @@
 // If input date is valid, then a true date.
 // If input date is invalid, returns null with warning 01H99.
 
-     p Date_MDY        b                   export
+Dcl-Proc Date_MDY export;
-     d Date_MDY        pi
+    Dcl-PI Date_MDY;
-     d  pDateIn                       8p 0 const
+        pDateIn        Packed(8:0) const;
-     d  pDateOut                       d
+        pDateOut       Date;
-     d  pIndicators                   5i 0 dim(1)
+        pIndicators    Int(5)     dim(1);
-     d  pRetInd                       5i 0
+        pRetInd        Int(5);
-     d  pSQLSTATE                     5a
+        pSQLSTATE      Char(5);
-     d  pFuncName                   517a   varying
+        pFuncName      Varchar(517);
-     d  pSpecificName               128a   varying
+        pSpecificNam   Varchar(128);
-     d  pErrText                   1000a   varying
+        pErrText       Varchar(1000);
+    End-PI;
 
-      /FREE
     pRetInd = 0;
     pSQLSTATE = '00000';
     monitor;
@@ -203,5 +205,4 @@
         pErrText = %char(pDateIn) + ' is not a (numeric) date';
     endmon;
     return;
-      /END-FREE
+End-Proc;
-     p Date_MDY        e

DATE_UDF/DATE_SQLFX.RPGLE

@@ -0,0 +1,207 @@
+      /title SQL UDFs to convert numeric to true dates
+      //===============================================================
+      // The DATE_SQL service program contains routines that are
+      // registered as User Defined Functions to SQL and which
+      // convert legacy numeric dates to true dates.  This makes doing
+      // date arithmetic in SQL much easier.
+      //
+      // For example, if DSTPT is a 6-digit date in YYMMDD format, in SQL
+      // you can code:
+      //
+      //   SELECT PNOPT FROM MVPSPRTP
+      //   WHERE DATE_YMD(DSTPT) >= CURDATE() - 9O DAYS
+      //
+      // On alder versions of the OS,you may need to cast character dates
+      // to numeric before using.
+      // For example, WHERE DECIMAL(DATE_YMD(DSTPT)) >= ...
+      //
+      // Function included are:
+      //   DATE_YMD       Accepts numeric dates in YMD format, with
+      //                  either 6 or 8 digits.
+      //   DATE_MDY       Accepts numeric dates in MDY format, with
+      //                  either 6 or 8 digits.
+      //   DATE_CYMD      Accepts 7 digit numeric dates. If the 1st
+      //                  digit is 0 then it is in the 1900s and if
+      //                  it is 1 then it is the 2000s. These are
+      //                  standard IBM seven byte dates.
+      //    ???????       Similar routines could be added to
+      //                  accept other formats
+      //
+      // For YMD or MDY dates, it handles either 6 or 8 digits.
+      // If the date passed is greater then 999999 then is it
+      // assumed to already have the century.
+      //
+      // Invalid dates return a null value.  This means the UDFs will
+      // not crash, but be aware that your results may be skewed if
+      // you have bad data.  (Logic could be added to convert
+      // "special" bad dates into some corporately acceptable value,
+      // e.g., 999999 could be converted to 9999-12-31.)
+      //
+      // Originally coded late 1990s, before the Y2K cleanups. Since
+      // tidied up and converted to free form..
+      //
+      // To Create
+      // =========
+      // 1) CRTRPGMOD MODULE(DATE_SQL) SRCFILE(DATE_UDF)
+      //    OPTION(*EVENTF) DBGVIEW(*SOURCE)
+      // 2) CRTSRVPGM SRVPGM(DATE_SQL) EXPORT(*ALL)
+      //       TEXT('DATE_SQL Service Program')
+      // 3) Run the CREATE_FNSQL statements to register to SQL
+      //===============================================================
+
+     H NoMain
+      //=== Prototypes ================================================
+     D Date_YMD        pr
+     D  NumericDate                   8p 0 const
+     d  RealDate                       d
+     D  Indicators                    5i 0 dim(1)
+     D  RetInd                        5i 0
+     d  SQLSTATE                      5a
+     d  FuncName                    517a   varying
+     d  SpecificName                128a   varying
+     d  ErrText                    1000a   varying
+
+     D Date_CYMD       pr
+     D  NumericDate                   8p 0 const
+     d  RealDate                       d
+     D  Indicators                    5i 0 dim(1)
+     D  RetInd                        5i 0
+     d  SQLSTATE                      5a
+     d  FuncName                    517a   varying
+     d  SpecificName                128a   varying
+     d  ErrText                    1000a   varying
+
+     D Date_MDY        pr
+     D  NumericDate                   8p 0 const
+     d  RealDate                       d
+     D  Indicators                    5i 0 dim(1)
+     D  RetInd                        5i 0
+     d  SQLSTATE                      5a
+     d  FuncName                    517a   varying
+     d  SpecificName                128a   varying
+     d  ErrText                    1000a   varying
+
+      //===============================================================
+      // DATE_YMD
+      // ========
+      // SQL User Defined Function (UDF) converts a 6 or 8 digit
+      // numeric date in YMD format to a true date.
+      //
+      // Returns
+      // =======
+      // If input date is valid, then a true date.
+      // If input date is invalid, returns null with warning 01H99.
+
+     p Date_YMD        b                   export
+     d Date_YMD        pi
+     d  pDateIn                       8p 0 const
+     d  pDateOut                       d
+     d  pIndicators                   5i 0 dim(1)
+     d  pRetInd                       5i 0
+     d  pSQLSTATE                     5a
+     d  pFuncName                   517a   varying
+     d  pSpecificName               128a   varying
+     d  pErrText                   1000a   varying
+
+      /FREE
+       pRetInd = 0;
+       pSQLSTATE = '00000';
+       monitor;
+           select;
+               // === 8 digit dates, yyyymmdd =================================
+               when pDateIn > 999999;
+                   pDateOut = %date(pDateIn: *ISO);
+               // === 6 digit dates, yymmdd ===================================
+               other;
+                   pDateOut = %date(pDateIn: *YMD);
+           endsl;
+       on-error;
+           pRetInd = -1;
+           pDateOut = %date('9999-01-03');
+           pSQLSTATE = '01H99';
+           pErrText = %char(pDateIn) + ' is not a (numeric) date';
+       endmon;
+       return;
+      /END-FREE
+     p Date_YMD        e
+
+      //===============================================================
+      // DATE_CYMD
+      // =========
+      // SQL User Defined Function (UDF) converts a 7 digit
+      // numeric date in CYMD format to a true date.
+      //
+      // Returns
+      // =======
+      // If input date is valid, then a true date.
+      // If input date is invalid, returns null with warning 01H99.
+
+     p Date_CYMD       b                   export
+     d Date_CYMD       pi
+     d  pDateIn                       8p 0 const
+     d  pDateOut                       d
+     d  pIndicators                   5i 0 dim(1)
+     d  pRetInd                       5i 0
+     d  pSQLSTATE                     5a
+     d  pFuncName                   517a   varying
+     d  pSpecificName               128a   varying
+     d  pErrText                   1000a   varying
+
+      /FREE
+       pRetInd = 0;
+       pSQLSTATE = '00000';
+       monitor;
+           pDateOut = %date(pDateIn: *CYMD);
+       on-error;
+           pRetInd = -1;
+           pDateOut = %date('9999-01-01');
+           pSQLSTATE = '01H99';
+           pErrText = %char(pDateIn) + ' is not a (numeric) date';
+        endmon;
+        return;
+      /END-FREE
+     p Date_CYMD       e
+
+      //===============================================================
+      // DATE_MDY
+      // ========
+      // SQL User Defined Function (UDF) converts a 6 or 8 digit
+      // numeric date in MDY format to a true date.
+      //
+      // Returns
+      // =======
+      // If input date is valid, then a true date.
+      // If input date is invalid, returns null with warning 01H99.
+
+     p Date_MDY        b                   export
+     d Date_MDY        pi
+     d  pDateIn                       8p 0 const
+     d  pDateOut                       d
+     d  pIndicators                   5i 0 dim(1)
+     d  pRetInd                       5i 0
+     d  pSQLSTATE                     5a
+     d  pFuncName                   517a   varying
+     d  pSpecificName               128a   varying
+     d  pErrText                   1000a   varying
+
+      /FREE
+       pRetInd = 0;
+       pSQLSTATE = '00000';
+       monitor;
+           select;
+               // === 8 digit dates, mmddyyyy =================================
+               when pDateIn > 999999;
+                   pDateOut = %date(pDateIn: *USA);
+               // === 6 digit dates, mmddyy ===================================
+               other;
+                   pDateOut = %date(pDateIn: *MDY);
+           endsl;
+       on-error;
+           pRetInd = -1;
+           pDateOut = %date('9999-01-02');
+           pSQLSTATE = '01H99';
+           pErrText = %char(pDateIn) + ' is not a (numeric) date';
+       endmon;
+       return;
+      /END-FREE
+     p Date_MDY        e

DATE_UDF/ReadMe.md

@@ -10,7 +10,7 @@ Legacy databases on the IBM i stored dates in numeric (or character) fields. Doi
 
 ## Development
 
-What these functions do can also be done, with some work, directly in SQL. And I'm aware there are other open source date UDFs avaliable, e.g. [iDate](https://www.think400.dk/downloads.htm).
+What these functions do can also be done, *with some work*, directly in SQL. And I'm aware there are other open source date UDFs avaliable, e.g. [iDate](https://www.think400.dk/downloads.htm).
 
 However...
 
@@ -41,15 +41,15 @@ An invalid input value will return a null value and give a 01H99 SQLSTATE warnin
 
 ## DATE_SQL
 
-The RPG code for the DATE_SQL service program, which contains the functions.  It is free format but the D-Specs are still fixed, and it can be edited in SEU. (When I originally wrote it, it was in fixed form RPGIV.)
+The RPG code for the DATE_SQL service program, which contains the functions.  
 
-## DATE_SQLFR
+## DATE_SQLFX
 
-This is DATE_SQL but converted to totally free form. I converted it using [RpgFreeWeb](https://github.com/worksofbarry/rpgfreeweb), which does a nice job.
+This is DATE_SQL with the D-Specs in fixed form, as a convenience for any who might still be on older releases.
 
 ## DATECRTFN
 
-This is SQL "Create Function" code that tells SQL where the functions are.
+This is SQL "Create Function" code that tells SQL where the functions are. Use the RUNSQLSTM command or iACS Run SQL Scripts. 
 
 ## TEST_CYMD/TEST_MDY/TEST_YMD
 

GRP_JOB/ReadMe.md

@@ -40,4 +40,4 @@ This program is called from GRP to establish each group job. The command it runs
 
 ## GRP_ATN
 
-This is called when the Attn key is pressed. **Shift+Esc is the Attn keys in most 5250 emulators.** It pops up a very functional but effective IBM menu to pick another group job.
+This is called when the Attn key is pressed. **Shift+Esc is the Attn keys in most 5250 emulators.** It pops up a very functional but effective IBM menu to pick another group job. You can add your own menu to make this more friendly.

PGM_REFS/Readme.MD

@@ -10,8 +10,10 @@ So far I have not found a decent manual or turorial. If you know of any please p
 
 My primary approach was trial and error, with help
 from these articles on IT Jungle:
-    [Ted HolT Article 1](https://www.itjungle.com/2017/06/12/guru-error-handling-sql-pl-part-1/) and 
+    [Ted Holt Article 1](https://www.itjungle.com/2016/09/27/fhg092716-story02/) and
-    [Ted Holt Article 2](https://www.itjungle.com/2017/10/16/guru-error-handling-sql-pl-part-2/)
+    [Ted Holt Article 2](https://www.itjungle.com/2016/10/18/fhg101816-story03/) and
+    [Ted HolT Article 3](https://www.itjungle.com/2017/06/12/guru-error-handling-sql-pl-part-1/) and 
+    [Ted Holt Article 4](https://www.itjungle.com/2017/10/16/guru-error-handling-sql-pl-part-2/)
 and browsing [Scott Forstie Gists on Github](https://gist.github.com/forstie
 )
 
@@ -41,7 +43,7 @@ You need to supply library and name. The type will default to `*PGM` and the dep
 
 ### Library list
 
-Since many objects will have a library of `*LIBL`, that is what will get passed to DSPPGMREF for expansion. So you need to have your library list contain all libraries whose objects you want expanded.
+Since many objects will have a library of `*LIBL`, that is what will get passed to DSPPGMREF for expansion. So you need to make sure your library list contain all libraries whose objects you want expanded.
 
 ### DSPPGMREF Failure
 

PRT_CL/DEMO_RPG1.SQLRPGLE

@@ -20,8 +20,8 @@
 ctl-opt option(*srcstmt: *nodebugio)
     bnddir('SQL_BND')
     actgrp(*new) main(Main);
-/COPY copy_mbrs,prt_p
+/COPY ../Copy_Mbrs/PRT_P.RPGLE
-/COPY copy_mbrs,srv_sql_p
+/COPY ../Copy_Mbrs/SRV_SQL_P.RPGLE
 
 dcl-proc Main;
     dcl-pi Main;
@@ -205,4 +205,4 @@ dcl-proc Main;
         endif;
     endsr;
 
-end-proc main;
+end-proc Main;

PRT_CL/PRT_T.RPGLE

@@ -1,7 +1,7 @@
 **free
 // === Test program to exercise the PRT program =====================
 ctl-opt option(*srcstmt: *nodebugio) actgrp(*new) main(Main);
-/COPY copy_mbrs,prt_p
+/COPY ../Copy_Mbrs/PRT_P.RPGLE
 dcl-proc Main;
   dcl-pi Main;
     // pi_head   char(132);
@@ -217,5 +217,4 @@ dcl-proc Main;
 
   *inlr = *on;
 
-
 end-proc;

README.md

@@ -1,15 +1,45 @@
-# RPGLE free format, SQL and CLP Code for the IBM i
+# RPGLE free format, SQL & CLP Code for the IBM i
 
-More developers are learning about the **IBM i** as a wonderful business platform. (It was formerly known as the **AS/400**.)
+**This repository contains *working* example code, using RPGLE free-format, enbedded SQL and CLP for the IBM i. All RPG code here is totally free form.**.
-
-This repository contains *working* example code, using RPGLE free-format, enbedded SQL and CLP for the IBM i.
-
-My intent is to provide real programs that help you learn and/or improve your current understanding. Explore and adapt the code to your needs. Some of the code may be of use "as is" but no guarantee is provided.
 
 **Each folder has its own ReadMe with additional infomation/documentation.**
 
+My intent is to provide real programs that help you learn and/or improve your current understanding. Explore and adapt the code to your needs. Some of the code may be of use "as is" but no guarantee is provided.
+
 Feel free to provide comments and feedback as issues.
 
+# Source Control Philosophy 
+
+This code in this repository is based on having source in the file system (IFS) rather than the traditional approach of members in a PF-SRC file.
+
+For these personal projects I use the free IBM i [PUB400.COM](https://pub400.com/). 
+
+I edit and compile using [VS Code](https://code.visualstudio.com/) with the ["Code for IBM i"](https://codefori.github.io/docs/#/) extension. My source is/was in PF-SRC members and for backup I created a SAVF file of my PF-SRC files and downloaded it to my PC. But  I didn't do it regularly.
+
+Now that ["Code for IBM i"](https://codefori.github.io/docs/#/) supports local development on a PC and will push code to the IFS, I am using Github as a permanent repository. Doing editing on my PC and pushing changes to Github and the IFS is easier than creating a save file and downloading it.
+
+This means that on the IBM i, code is in directories in the IFS instead of being in PF-SRC file members.
+
+This is my setup:
+
+ - Github contains my personal "production" source. 
+ - My PC has Git installed and the PC files are where I make changes. 
+ - I deploy to the IFS to compile with ["Code for IBM i"](https://codefori.github.io/docs/#/).
+ 
+My PC has a directory structure like this:
+
+| Directory shown in VS CODE                   |Directory shown in File Explorer                       |
+|----------------------------------------|---------------------------------------|
+|     ![Directory Structure](image.png)  | ![Directory Structure](image-2.png)   |
+
+The IFS directory after deployment looks like this:
+
+ ![Directory Structure](image-1.png)
+ 
+The primary difference from moving away from PF-SRC file members is that COPY and INCLUDE statements must now reference an IFS file. I do not want to hard code directory names so I am using relative addressing, such as
+
+ ``/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE``. 
+
 ## Copy_Mbrs
 
 Code to be copied into other programs.
@@ -74,3 +104,4 @@ Developer Utilities.
     QRY - Qry (List) Contents of a file
     
     RC - Display File Record count
+

RcdLckDsp/RCDLCKBAD.RPGLE

@@ -1,51 +1,45 @@
-      *==============================================================
+**free
-      * Program that locks a record and then waits for input from
+// ==============================================================
-      * the operator.
+//  Program that locks a record and then waits for input from
-      *
+//  the operator.
-      * Call this program in two different sessions to see the effect.
+// 
-      * Second program will typically get a error:
+//  Call this program in two different sessions to see the effect.
-      *   'Unable to allocate a record in file' (RNX1218)
+//  Second program will typically get a error:
-      * and the end user typically choses an unhelpful response.
+//    'Unable to allocate a record in file' (RNX1218)
-      *==============================================================
+//  and the end user typically choses an unhelpful response.
-      * Note: This is a poor technique because the record remains
+// ==============================================================
-      *       locked to all other users until the transaction is
+//  Note: This is a poor technique because the record remains
-      *       completed, which may be in a few seconds or after lunch.
+//        locked to all other users until the transaction is
-      *
+//        completed, which may be in a few seconds or after lunch.
-      *Note: Pgm reads by RRN for convenience. This is not a good
+// 
-      *      idea is a production program.
+// Note: Pgm reads by RRN for convenience. This is not a good
-      *
+//       idea is a production program.
-      *Note: DSPLY is use to simulate a display file interaction
+// 
-      *      with the user.
+// Note: DSPLY is use to simulate a display file interaction
-      *
+//       with the user.
-      *Note: QIWS/QCUSTCDT: believed to be on virtually all systems.
+// 
-      *==============================================================
+// Note: QIWS/QCUSTCDT: believed to be on virtually all systems.
+// ==============================================================
 
-     H DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF)
+ Ctl-Opt DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF);
-     H DFTACTGRP(*NO) ACTGRP(*NEW)
+ Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
-
+ Dcl-F QCUSTCDT Usage(*Update:*Delete:*Output) USROPN EXTDESC('QIWS/QCUSTCDT') RECNO(RRN)
-     FQCUSTCDT  UF   E             DISK    USROPN EXTDESC('QIWS/QCUSTCDT')
+//                                 INFSR(*PSSR)
-     F                                     RECNO(RRN)
+;
-     F*                                    INFSR(*PSSR)
+ Dcl-PR QCmdexc  EXTPGM('QCMDEXC');
-
+   Cmd            Char(512);
-     D QCmdexc         PR                  EXTPGM('QCMDEXC')
+   lgth           Packed(15:5) CONST;
-     D  CMD                         512A
+  End-PR;
-     D  lgth                         15P 5 const
+ Dcl-S RRN          Packed(10:0) INZ(10);
-
+ Dcl-S reply        Char(1)    INZ('*');
-     D RRN             s             10p 0 inz(10)
+ Dcl-S Cmd          Char(512);
-     D reply           S              1A   inz('*')
-     D Cmd             S            512A
-
-      /free
  *inlr = *on;
-
  // Set update file to a short wait time. Otherwise the file or
  // system default wait time applies.
-       cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
+ Cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
-       QCMDEXC(cmd:512);
+ QCmdexc(Cmd:512);
  open QCUSTCDT;
-
  chain RRN QCUSTCDT;
-
  if %found(QCUSTCDT);
    // Logic to update the record would be here.
    dsply 'Read for update' ' ' reply;
@@ -53,12 +47,10 @@
    // Logic for record not found would be here
    dsply 'Record not found' ' ' reply;
  endif;
-
  // === End of Program =========================================
  // Close file before returning
  close QCUSTCDT;
  return;
-
  // Often found in old programs. Uncomment INFSR(*PSSR) in the
  // F-SPEC to make this active.
  BEGSR *PSSR;

RcdLckDsp/RCDLCKDEMO.RPGLE

@@ -1,54 +1,53 @@
-      *==============================================================
+**free
-      * Program that locks a record and then waits for input from
+//  ==============================================================
-      * the operator.
+//   Program that locks a record and then waits for input from
-      *
+//   the operator.
-      * Call this program in two different sessions to see the effect.
+//  
-      *==============================================================
+//   Call this program in two different sessions to see the effect.
-      * -  Locking the record first is a poor technique because
+//  ==============================================================
-      *    the record remains locked to all other users until the
+//   -  Locking the record first is a poor technique because
-      *    transaction is completed, which may be in a few seconds or
+//      the record remains locked to all other users until the
-      *    after lunch.
+//      transaction is completed, which may be in a few seconds or
-      *    It is used here to demonstate the RCDLCKDSP processing.
+//      after lunch.
-      *==============================================================
+//      It is used here to demonstate the RCDLCKDSP processing.
-      * - Pgm reads by RRN for convenience. This is generally not a
+//  ==============================================================
-      *   good idea is a production program.
+//   - Pgm reads by RRN for convenience. This is generally not a
-      *
+//     good idea is a production program.
-      *-  DSPLY is use to simulate a display file interaction with
+//  
-      *   the user. Not normally done in production.
+//  -  DSPLY is use to simulate a display file interaction with
-      *
+//     the user. Not normally done in production.
-      * - QIWS/QCUSTCDT: believed to be on virtually all systems.
+//  
-      *==============================================================
+//   - QIWS/QCUSTCDT: believed to be on virtually all systems.
+//  ==============================================================
 
-     H DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF)
+Ctl-Opt DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF);
-     H DFTACTGRP(*NO) ACTGRP(*NEW)
+Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
 
-     FQCUSTCDT  UF   E             DISK    USROPN EXTDESC('QIWS/QCUSTCDT')
+Dcl-F QCUSTCDT Usage(*Update:*Delete:*Output) 
-     F                                     RECNO(RRN)
+    USROPN EXTDESC('QIWS/QCUSTCDT') RECNO(RRN)
-     F*                                    INFSR(*PSSR)
+//        INFSR(*PSSR)
+;
 
-     D RCDLCKDSP       PR                  EXTPGM('RCDLCKDSP')
+Dcl-PR RCDLCKDSP  EXTPGM('RCDLCKDSP');
-     D  poReply                       1A
+  poReply        Char(1);
-     D  piPSDS                         *
+  piPSDS         Pointer;
-
+ End-PR;
-     D QCmdexc         PR                  EXTPGM('QCMDEXC')
+Dcl-PR QCmdexc  EXTPGM('QCMDEXC');
-     D  CMD                         512A
+  Cmd            Char(512);
-     D  lgth                         15P 5 const
+  lgth           Packed(15:5) CONST;
-
+ End-PR;
-     D RRN             s             10p 0 inz(10)
+Dcl-S RRN          Packed(10:0) INZ(10);
-     D reply           S              1A   inz('*')
+Dcl-S reply        Char(1)    INZ('*');
-     D Cmd             S            512A
+Dcl-S Cmd          Char(512);
-
+Dcl-DS myPSDS  PSDS;
-     D  myPSDS        SDS
+ End-DS;
-     D  myPSDS_ptr     S               *   inz(%addr(myPSDS))
+Dcl-S myPSDS_ptr   Pointer    INZ(%ADDR(myPSDS));
-
-      /free
 *inlr = *on;
 // Set update file to a short wait time. Otherwise the file or
 // system default wait time applies.
-       cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
+Cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
-       QCMDEXC(cmd:512);
+QCmdexc(Cmd:512);
 open QCUSTCDT;
-
 dou not %error;
      chain(e) RRN QCUSTCDT;
      if %error;
@@ -65,7 +64,6 @@
          endif;
      endif;
 enddo;
-
 if %found(QCUSTCDT);
      // Logic to update the record would be here.
      dsply 'Read for update' ' ' reply;
@@ -73,12 +71,10 @@
      // Logic for record not found would be here
      dsply 'Record not found' ' ' reply;
 endif;
-
 // === End of Program =========================================
 // Close file before returning
 close QCUSTCDT;
 return;
-
 begsr Prog_Cancelled;
      close QCUSTCDT;
      // Put graceful ending logic & notification to user here

RcdLckDsp/RCDLCKDSP.RPGLE

@@ -1,136 +1,118 @@
-      *==============================================================
+**free
-      * When an interactive program tries to update a record that is
+//  ==============================================================
-      * locked by another user, often the program doesn't handle it.
+//   When an interactive program tries to update a record that is
-      * The RPG error routines kick in and give the user a confusing
+//   locked by another user, often the program doesn't handle it.
-      * error message.
+//   The RPG error routines kick in and give the user a confusing
-      *
+//   error message.
-      * Instead, trap the error and handle it by calling this program.
+//  
-      *
+//   Instead, trap the error and handle it by calling this program.
-      * This program communicates info about a locked record to an
+//  
-      * interactive user telling who has the lock.
+//   This program communicates info about a locked record to an
+//   interactive user telling who has the lock.
 
-      * See program RCDLCKDEMO for a usage example.
+//   See program RCDLCKDEMO for a usage example.
-      *
+//  
-      * RCDLCKDSP accepts a continuation reply from the user and
+//   RCDLCKDSP accepts a continuation reply from the user and
-      * passes it back to the caller.
+//   passes it back to the caller.
-      *
+//  
-      * If the status is not 1218, then it is considered an
+//   If the status is not 1218, then it is considered an
-      * unexpected error and a slightly different dialog is
+//   unexpected error and a slightly different dialog is
-      * presented, asking the user to contact IT. You can
+//   presented, asking the user to contact IT. You can
-      * customize this as you see fit. Or add other statuses.
+//   customize this as you see fit. Or add other statuses.
-      *
+//  
-      * Information is retrieved from the *PSDS passed from the caller.
+//   Information is retrieved from the *PSDS passed from the caller.
-      *
+//  
-      *==============================================================
+//  ==============================================================
-      * Parameters
+//   Parameters
-      * ==========
+//   ==========
-      * 1  Output CL1 User's reply about what to do:
+//   1  Output CL1 User's reply about what to do:
-      *               R - Retry the IO operation that failed
+//                 R - Retry the IO operation that failed
-      *               C - Cancel the program
+//                 C - Cancel the program
-      *               D - DUmp the program and cancel
+//                 D - DUmp the program and cancel
-      * 2  Input   *  Pointer to the *PSDS in the calling program.
+//   2  Input   *  Pointer to the *PSDS in the calling program.
-      *               (A pointer is used because the *PDSD is not
+//                 (A pointer is used because the *PDSD is not
-      *                always the same length in a program.)
+//                  always the same length in a program.)
-      *==============================================================
+//  ==============================================================
-      * Create with CRTBNDRPG
+//   Create with CRTBNDRPG
-      * New activation group so we destroy nothing in the caller.
+//   New activation group so we destroy nothing in the caller.
-      * No worries about overhead since rarely called.
+//   No worries about overhead since rarely called.
-     h  OPTION(*NODEBUGIO: *SRCSTMT)
+       Ctl-Opt OPTION(*NODEBUGIO: *SRCSTMT);
-     H  DFTACTGRP(*NO) ACTGRP(*NEW)
+       Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
-      *==============================================================
+//  ==============================================================
 
-     FrcdlckdspdCF   E             WORKSTN
+Dcl-F rcdlckdspd WORKSTN;
+Dcl-PR RCDLCKDSP;
+  poReply        Char(1);
+  piPSDS         Pointer;
+ End-PR;
+Dcl-PI RCDLCKDSP;
+  poReply        Char(1);
+  piPSDS         Pointer;
+ End-PI;
 
-     d RCDLCKDSP       pr
+//   === The caller's Program Status Data Structure ===============
-     D  poReply                       1A
+//   Many fields not currently used.
-     D  piPSDS                         *
+Dcl-DS PSDS  QUALIFIED BASED(PIPSDS);
+  PROC_NAME      Char(10)   Pos(1); //* Procedure name
+  PGM_STATUS     Zoned(5:0) Pos(11); //* Status code
+  PRV_STATUS     Zoned(5:0) Pos(16); //* Previous status
+  LINE_NUM       Char(8)    Pos(21); //* Src list line num
+  ROUTINE        Char(8)    Pos(29); //* Routine name
+  PARMS          Char(3)    Pos(37); //* Num passed parms
+  EXCP_TYPE      Char(3)    Pos(40); //* Exception type
+  EXCP_NUM       Char(4)    Pos(43); //* Exception number
+  PGM_LIB        Char(10)   Pos(81); //* Program library
+  EXCP_DATA      Char(80)   Pos(91); //* Exception data
+  EXCP_ID        Char(4)    Pos(171); //* Exception Id
+  LAST_FILE_IO   Char(10)   Pos(175); //* Last file used
+  DATE           Char(8)    Pos(191); //* Date (*DATE fmt)
+  YEAR           Zoned(2:0) Pos(199); //* Year (*YEAR fmt)
+  LAST_FILE      Char(8)    Pos(201); //* Last file used
+  FILE_INFO_STATUS Zoned(5:0) Pos(209) ; //* Last file status
+  FILE_INFO_OPCODE Char(6)    Pos(214); //* Last file opcode
+  FILE_INFO_ROUTINE Char(8)    Pos(220) ; //* Last file RPG
+  FILE_INFO_LIST_NUM Char(8)    Pos(228) ; //* Last file listing
+  FILE_INFO_RECORD Int(20)    Pos(236) ; //* Last file record
+  JOB_NAME       Char(10)   Pos(244); //* Job name
+  USER           Char(10)   Pos(254); //* User name
+  JOB_NUM        Zoned(6:0) Pos(264); //* Job number
+  JOB_DATE       Zoned(6:0) Pos(270); //* Date (UDATE fmt)
+  RUN_DATE       Zoned(6:0) Pos(276); //* Run date (UDATE)
+  RUN_TIME       Zoned(6:0) Pos(282); //* Run time (UDATE)
+  CRT_DATE       Char(6)    Pos(288); //* Create date
+  CRT_TIME       Char(6)    Pos(294); //* Create time
+  CPL_LEVEL      Char(4)    Pos(300); //* Compiler level
+  SRC_FILE       Char(10)   Pos(304); //* Source file
+  SRC_LIB        Char(10)   Pos(314); //* Source file lib
+  SRC_MBR        Char(10)   Pos(324); //* Source file mbr
+  PROC_PGM       Char(10)   Pos(334); //* Pgm Proc is in
+  PROC_MOD       Char(10)   Pos(344); //* Mod Proc is in
+  LINE_NUM_SRCID Int(5)     Pos(354); //* Src list source ID
+  FILE_INFO_LIST_NUM_SRCID Int(5)     Pos(356) ; //* Last file listing
+  CURR_USER      Char(10)   Pos(358) ; //* Current user
+  EXTERNAL_RC    Int(10)    Pos(368) ; //* External return
+  NUM_XML_ELEMS  Int(20)    Pos(372) ; //* Number of XML
+ End-DS;
+//  === My Variables ==============================================
+Dcl-DS MyPSDS  PSDS;
+         MyName         Char(10)   Pos(1); //* This program
+        End-DS;
 
-     d RCDLCKDSP       pi
+Dcl-C USER       'USER: ';
-     D  poReply                       1A
+Dcl-S UserPrf      Char(10)   INZ(' ');
-     D  piPSDS                         *
+Dcl-S UserName     Char(40)   INZ(' ');
-
+Dcl-S wkI          Int(10);
-      * === The caller's Program Status Data Structure ===============
+Dcl-S wkJ          Int(10);
-      * Many fields not currently used.
+Dcl-S myStatus     Zoned(4:0);
-     D PSDS            DS                  qualified based(piPSDS)
+//Dcl-DS AAA  LIKEDS(PSDS);
-     D  PROC_NAME              1     10                                         * Procedure name
-     D  PGM_STATUS            11     15s 0                                      * Status code
-     D  PRV_STATUS            16     20S 0                                      * Previous status
-     D  LINE_NUM              21     28                                         * Src list line num
-     D  ROUTINE               29     36                                         * Routine name
-     D  PARMS                 37     39                                         * Num passed parms
-     D  EXCP_TYPE             40     42                                         * Exception type
-     D  EXCP_NUM              43     46                                         * Exception number
-     D  PGM_LIB               81     90                                         * Program library
-     D  EXCP_DATA             91    170                                         * Exception data
-     D  EXCP_ID              171    174                                         * Exception Id
-     D  LAST_FILE_IO         175    184                                         * Last file used
-     D  DATE                 191    198                                         * Date (*DATE fmt)
-     D  YEAR                 199    200S 0                                      * Year (*YEAR fmt)
-     D  LAST_FILE            201    208                                         * Last file used
-     D  FILE_INFO_STATUS...
-     D                       209    213S 0                                      * Last file status
-     D                                                                          *   Code
-     D  FILE_INFO_OPCODE...
-     D                       214    219                                         * Last file opcode
-     D  FILE_INFO_ROUTINE...
-     D                       220    227                                         * Last file RPG
-     D                                                                          *   routine
-     D  FILE_INFO_LIST_NUM...
-     D                       228    235                                         * Last file listing
-     D                                                                          *   line
-     D  FILE_INFO_RECORD...
-     D                       236    243I 0                                      * Last file record
-     D                                                                          *   name
-     D  JOB_NAME             244    253                                         * Job name
-     D  USER                 254    263                                         * User name
-     D  JOB_NUM              264    269S 0                                      * Job number
-     D  JOB_DATE             270    275S 0                                      * Date (UDATE fmt)
-     D  RUN_DATE             276    281S 0                                      * Run date (UDATE)
-     D  RUN_TIME             282    287S 0                                      * Run time (UDATE)
-     D  CRT_DATE             288    293                                         * Create date
-     D  CRT_TIME             294    299                                         * Create time
-     D  CPL_LEVEL            300    303                                         * Compiler level
-     D  SRC_FILE             304    313                                         * Source file
-     D  SRC_LIB              314    323                                         * Source file lib
-     D  SRC_MBR              324    333                                         * Source file mbr
-     D  PROC_PGM             334    343                                         * Pgm Proc is in
-     D  PROC_MOD             344    353                                         * Mod Proc is in
-     D  LINE_NUM_SRCID...
-     D                       354    355I 0                                      * Src list source ID
-     D  FILE_INFO_LIST_NUM_SRCID...
-     D                       356    357I 0                                      * Last file listing
-     D                                                                          *   source ID
-     D  CURR_USER            358    367                                         * Current user
-     D                                                                          *   profile
-     D  EXTERNAL_RC          368    371I 0                                      * External return
-     D                                                                          *   code
-     D  NUM_XML_ELEMS        372    379I 0                                      * Number of XML
-     d                                                                          *   elements
-      *=== My Variables ==============================================
-     D MyPSDS         sDS
-     D  MyName                 1     10                                         * This program
-
-     D User            c                   'User: '
-     D UserPrf         S             10A   inz(' ')
-     D UserName        S             40A   inz(' ')
-
-     D wkI             s             10I 0
-     D wkJ             s             10I 0
-
-     d myStatus        s              4S 0
-     D*AAA             DS                  likeds(PSDS)
-      /FREE
 // AAA = PSDS;  // Eases Debugging...
-
  SH_PGM = MyName;
-
  // Sometimes the Status is not numeric
  monitor;
-            myStatus = psds.FILE_INFO_STATUS;
+     myStatus = PSDS.FILE_INFO_STATUS;
  on-error;
      myStatus = -0;
  ENDMON;
-
  // Display fields are prefixed with SC_.
  select;
  when myStatus = 1218; //Record locked
@@ -138,44 +120,35 @@
      SC_USER2 = 'their transaction or exits their application.';
      exsr GetUserPrf;
      //exsr GetUserName;
-
      // Fill in user profile and user name
      select;
      when UserPrf = ' ' and UserName = ' ';
-                SC_USER3 = User + '*Unknown* -- Call IT Now.';
+         SC_USER3 = USER + '*Unknown* -- Call IT Now.';
      when UserName = ' ';
-                 SC_USER3 = User + UserPrf;
+          SC_USER3 = USER + UserPrf;
      other;
-                 SC_USER3 = User + UserName;
+          SC_USER3 = USER + UserName;
      endsl;
-
      SC_INSTR = 'Enter R to Retry, C to Cancel';
-
  other;   //Unknown error
      SC_USER1 = 'An unexpected error has occurred.';
      SC_USER2 = 'Please contact IT now.';
      SC_INSTR = 'IT: D=Dump, C=Cancel; R=Retry';
  endsl;
-
  // We try to fill in this info for all conditions
  SC_IT_PGM = PSDS.PROC_NAME;
  SC_IT_STS = myStatus;
  SC_IT_FILE = PSDS.LAST_FILE;
  SC_IT_OPCD = PSDS.FILE_INFO_OPCODE;
-
  SC_IT_EM1 = %subst(PSDS.EXCP_DATA: 1: %len(SC_IT_EM1));
  SC_IT_EM2 = %subst(PSDS.EXCP_DATA: %len(SC_IT_EM1)+1);
-
+ exfmt DSPWIN;
-        exfmt dspwin;
-
  poReply = 'R';  //Default to R
  if SC_RESP = 'C' or SC_RESP = 'R' or SC_RESP = 'D';
      poReply = SC_RESP;
  endif;
-
  *inlr = *on;
  return;
-
  begsr GetUserPrf;
  // Dig the user profile out of the error message (EXCP_DATA)
  // which looks like this:
@@ -185,18 +158,16 @@
      if wkI <> 0;
          wkI = wkI +1;
          wkJ = %scan('/' :PSDS.EXCP_DATA: wkI);
-                if WkJ <> 0;
+         if wkJ <> 0;
-                     wkJ = WkJ - wkI;
+              wkJ = wkJ - wkI;
              if wkI > 0;
                  UserPrf = %subst(PSDS.EXCP_DATA: wkI: wkJ);
              endif;
          endif;
      endif;
  endsr;
-
  begsr GetUserName;
  // If you have a way to connect a user name to a user
  // then set UserName here.
      UserName = ' ';
  endsr;
-      /END-FREE

RcdLckDsp/Readme.md

@@ -16,7 +16,7 @@ The top half of the window is information for the current user of the interactiv
 
 The bottom half provides information for the IT Department should the need arise.
 
-## RCDLCKDSP
+## RCDLCKDSP.RPGLE
 
 This is the standalone RPG program that handles the window display. It is passed two parameters:
 

SQL_SKELETON/SQL_SKEL2.SQLRPGLE

@@ -26,14 +26,14 @@
     main(SQL_SKEL);
 
 //=== Prototypes ======================================
-/include copy_mbrs,srv_sql_p
+/include ../Copy_Mbrs/SRV_SQL_P.RPGLE
 
 //=== SQL State Constants =============================
-dcl-c SQLSuccess    '00000';
+dcl-c SQLSUCCESS    '00000';
-dcl-c SQLNoData     '02000';
+dcl-c SQLNODATA     '02000';
-dcl-c SQLNoMoreData '02000';
+dcl-c SQLNOMOREDATA '02000';
-dcl-c SQLDupRecd    '23505';
+dcl-c SQLDUPRECD    '23505';
-dcl-c SQLRowLocked  '57033';
+dcl-c SQLROWLOCKED  '57033';
 
 //=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=
 //    Main Program                                    =
@@ -47,7 +47,7 @@ dcl-proc SQL_SKEL;
   dcl-ds InTbl extname('QIWS/QCUSTCDT') template
   end-ds;
 
-  dcl-s MyCusnum like(cusnum);
+  dcl-s MyCusNum like(cusnum);
   dcl-s MyLstNam like(lstnam);
   dcl-s MyInit like(init);
   dcl-s MyState like(state);
@@ -73,12 +73,12 @@ dcl-proc SQL_SKEL;
       ;
 //=== Initialization ================================
   exec sql open  DemoCursor;
-  if SQLSTT <> SQLSuccess;
+  if SQLSTT <> SQLSUCCESS;
     SQLProblem('open DemoCursor');
   endif;
 //=== Main Logic ====================================
   exsr FetchCur;
-  dow SQLSTT = SQLSuccess;
+  dow SQLSTT = SQLSUCCESS;
     RecordsRead += 1;
      // Real program logic goes here <<<<<<<<<<
     exsr FetchCur;
@@ -89,7 +89,7 @@ dcl-proc SQL_SKEL;
   // ---- Deliberate bug to exercise SQLProblem -----
   exec sql close DemoCursor;
   // ------------------------------------------------
-  if SQLSTT <> SQLSuccess;
+  if SQLSTT <> SQLSUCCESS;
     SQLProblem('close DemoCursor');
   endif;
   *inlr = *on;
@@ -111,8 +111,8 @@ dcl-proc SQL_SKEL;
                 :MyState,
                 :MyBalDue
       ;
-    if SQLSTT <> SQLSuccess
+    if SQLSTT <> SQLSUCCESS
-      and SQLSTT <> SQLNoMoreData;
+      and SQLSTT <> SQLNOMOREDATA;
       SQLProblem('fetch DemoCursor');
     endif;
   endsr;

Service_Pgms/CRTBNDDIR.CLLE

@@ -0,0 +1,17 @@
+             PGM
+/* === Create UTIL_BND binding directory ======================== */
+
+             /* === Set your target library here ================ */
+             DCL VAR(&TGT_LIB) TYPE(*CHAR) LEN(10) + 
+                 VALUE('*CURLIB')              
+             /* ================================================= */
+            
+             DLTBNDDIR BNDDIR(&TGT_LIB/UTIL_BND)
+             MONMSG     MSGID(CPF0000)
+          
+             CRTBNDDIR  BNDDIR(&TGT_LIB/UTIL_BND) TEXT('Utilities +
+                          Service PGMs')
+
+             ADDBNDDIRE BNDDIR(UTIL_BND) OBJ((SRV_MSG *SRVPGM *DEFER))
+             ADDBNDDIRE BNDDIR(UTIL_BND) OBJ((SRV_STR *SRVPGM *DEFER))
+             ENDPGM

Service_Pgms/README.md

@@ -10,13 +10,13 @@ Contains procedures to send messages from an RPG program.
 
   **ClrMsgPgmQ**:  Clear all messages from the provided program queue. (Interactive programming.)
 
-  **SndEscMsg**:    Send provided text as an escape message.
+  **SndEscMsg**:    Send provided text as an escape message. (Note that the SND-MSG opcode can replace this in newer compiler versions.)
 
-  **SndInfMsg**:   Send provided text as info message to the external message queue.
+  **SndInfMsg**:   Send provided text as info message to the external message queue. (Note that the SND-MSG opcode can replace this in newer compiler versions.)
 
   **JobLogMsg**:   Send provided text to the job log using Qp0zLprintf, a C function. For testing, a convenient alternative to the DSPLY opcode for longer messages.
 
-## SRV_RANDON
+## SRV_RANDOM
 
 Convenience procedures relating to pseudo random number generation.
 
@@ -63,6 +63,6 @@ Contains procedures to manipulate strings in an RPG program.
 ## SHOW
 
   RPG program to display a 5250 message using the QUILNGTX API. Useful for testing, but possibly
-  JobLogMsg in SRV_MSG is more useful. Really should be part of SRV_MSG, but it is totally *FREE for and I have left SRV_MSG partially fixed.
+  JobLogMsg in SRV_MSG is more useful. Really should be part of SRV_MSG.
 
   * SHOW_T   RPG program to test & exercise SHOW.

Service_Pgms/SHOW_T.RPGLE

@@ -4,7 +4,7 @@ Ctl-Opt DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt);
 Ctl-Opt BndDir('UTIL_BND');
 
 //=== Service Program Prototypes ==============================
-/include copy_mbrs,Srv_Msg_P
+/include ../Copy_Mbrs/SRV_MSG_P.RPGLE
 
 dcl-s short1 char(30) inz('A typical short msg.');
 

Service_Pgms/SRV_MSG.RPGLE

@@ -1,9 +1,9 @@
-
+**free
 //==============================================================
 //=== SRV_MSG service program contains prodcedure for sending
 //=== messages:
-      //   With QMHSNDPM
+//   1) With QMHSNDPM
-      //   With Qp0zLprintf (to job log.)
+//   2) With Qp0zLprintf (to job log.)
 //==============================================================
 // CRTRPGMOD MODULE(SRV_MSG)
 //
@@ -12,49 +12,53 @@
 //   TEXT('Messages service program')
 //
 // ADDBNDDIRE BNDDIR(UTIL_BND) OBJ((SRV_MSG *SRVPGM *DEFER))
+//==============================================================
+// 12/2023  Convert to totally **FREE
+//==============================================================
 
-     h nomain option(*NoDebugIo: *srcstmt)
+ctl-opt nomain option(*nodebugio: *srcstmt);
-      /include copy_mbrs,Srv_Msg_P
+/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE
 
 //=== QMHSNDPM internal prototype =============================
-     D QMHSNDPM        pr                  ExtPgm('QMHSNDPM')
+dcl-pr QMHSNDPM extpgm('QMHSNDPM');
-     D  piMsgId                       7a   Const
+    *n char(7) const; // piMsgId
-     D  piMsgFile                    20a   Const
+    *n char(20) const; // piMsgFile
-     D  piMsgData                  1024a   Const OPTIONS(*varsize)
+    *n char(1024) const options(*varsize); // piMsgData
-     D  piMsgDataLgth                10i 0 Const
+    *n int(10) const; // piMsgDataLgth
-     D  piMsgType                    10a   Const
+    *n char(10) const; // piMsgType
-     D  piCallStk                    10a   Const
+    *n char(10) const; // piCallStk
-     D  piRelCallStk                 10i 0 Const
+    *n int(10) const; // piRelCallStk
-     D  piRtnMsgKey                   4a
+    *n char(4); // piRtnMsgKey
-     D  apiErrorDS                   17a
+    *n char(17); // apiErrorDS
+end-pr;
 
 //=== QMHRMVPM internal prototype =============================
-     d QMHRMVPM        pr                  Extpgm('QMHRMVPM')
+dcl-pr QMHRMVPM extpgm('QMHRMVPM');
-     d pPgmMsgQ                      10a
+    *n char(10); // pPgmMsgQ
-     d PgmStk                        10i 0
+    *n int(10); // PgmStk
-     d MsgKey                         4a
+    *n char(4); // MsgKey
-     d Remove                        10a
+    *n char(10); // Remove
-     D  apiErrorDS                   17a
+    *n char(17); // apiErrorDS
+end-pr;
 
 //=== Qp0zLprintf =============================================
-     d printF          pr                  extproc('Qp0zLprintf')
+dcl-pr printF extproc('Qp0zLprintf');
-     d piMsg                           *   value options(*string)
+    *n pointer value options(*string); // piMsg
+end-pr;
 
 //=== SNDMSGPGMQ ===============================================
 //    SeND a MeSsaGe to a ProGraM message Queue.
 // Sends a pre-defined message to a program message queue
 // that you provide as a parameter.
-
 // Primarily designed to be used in interactive programs
 // that send messages via a message subfile.
-
 // See also CLRMSGPGMQ which clears messages from a program
 // message queue.
 //==============================================================
 // Conceptual call:
 //=================
 // H BndDir('UTIL_BND')
-      //  /include copy_mbrs,Srv_Msg_P
+//  /include ../Copy_Mbrs/SRV_MSG_P.RPGLE   
 // D ProgStatus     sds
 // D PgmName           *PROC
 //  SNDMSGPGMQ(PgmName:
@@ -62,13 +66,13 @@
 //             MsgFile:
 //             MsgDta);
 //==============================================================
-     P SndMsgPgmQ      b                   export
+dcl-proc SndMsgPgmQ export;
-     d SndMsgPgmQ      pi
+    dcl-pi SndMsgPgmQ;
-     d  pMsgQ                        10
+        pMsgQ char(10);
-     d  pMsgid                        7
+        pMsgid char(7);
-     d  pMsgFile                     10
+        pMsgFile char(10);
-     d  pMsgDta                     512    options(*NOPASS)
+        pMsgDta varchar(512) options(*nopass);
-     d                                     Varying
+    end-pi;
 //=== Calling Parameters =======================================
 // Parm        I/O/B  Description
 // ----        -----  -----------
@@ -80,23 +84,22 @@
 //                    is assumed as *LIBL.)
 // pMsgDta     I      Optional: Data to substitute into the message.
 //                    (Trailing blanks will be truncated before use.)
-
 //=== API Error Code Structure ==================================
 // We don't provide any bytes, so an error will cause a crash,
 // because if we get an error here something bad has happened.
-     dAPIError         ds           272
+    dcl-ds APIError len(272);
-     d APIEProv                1      4b 0 inz(0)
+        APIEProv int(10) inz(0) pos(1);
-     d APIEAvail               5      8b 0 inz(0)
+        APIEAvail int(10) inz(0) pos(5);
-     d APIErrId                9     15    inz(*blanks)
+        APIErrId char(7) inz(*blanks) pos(9);
+    end-ds;
 //=== QMHSNDPM Parameters =======================================
-     d QMsgFile        s             20
+    dcl-s QMsgFile char(20);
-     d MsgType         s             10    inz('*INFO')
+    dcl-s MsgType char(10) inz('*INFO');
-     d StackCntr       s             10i 0 inz(0)
+    dcl-s StackCntr int(10) inz(0);
-     d MsgKey          s              4    inz(' ')
+    dcl-s MsgKey char(4) inz(' ');
-     d MsgDta          s            256    inz(' ')
+    dcl-s MsgDta char(256) inz(' ');
-     d MsgDtaLgth      s             10i 0
+    dcl-s MsgDtaLgth int(10);
 //=== SNDMSGPGMQ execution starts here ==========================
-      /free
     QMsgFile = pMsgFile + '*LIBL';
          // Message data length for QMHSNDPM is optional.  If supplied,
          // use, else default to 0.
@@ -119,94 +122,86 @@
     // Exit with LR off. This is a tiny routine which will probably
     // be called again.
     return;
-      /end-free
+end-proc;
-     p SndMsgPgmQ      e
-
 //=== CLRMSGPGMQ =-=============================================
 //    CLeaRs all MeSsaGes from a ProGraM message Queue
 // Clears all the messages from a program message queue that
 // you specify as a parameter.
-
 // It is primarily designed for use by interactive programs that
 // send messages through a message subfile.
-
 // See also SNDMSGPGMQ which sends a message to the program queue.
 //
 // Always returns *OFF
 //===============================================================
-
 // Conceptual call:
 //=================
 // H BndDir('UTIL_BND')
-      //  /include copy_mbrs,Srv_Msg_P
+//  /include ../Copy_Mmbrs/SRV_MSG_P.RPGLE   
 // D ProgStatus     sds
 // D PgmName           *PROC
 //  CLRMSGPGMQ(PgmName)
 
-     p ClrMsgPgmQ      b                   export
+dcl-proc ClrMsgPgmQ export;
-     D ClrMsgPgmQ      pi              N
+    dcl-pi ClrMsgPgmQ ind;
-     d pPgmMsgQ                      10
+        pPgmMsgQ char(10);
+    end-pi;
 
     //=== API Error Code Structure ==================================
     // We don't provide any bytes, so an error will cause a crash,
     // because if we get an error here something bad has happened.
-     dAPIError         ds           272
+    dcl-ds APIError len(272);
-     d APIEProv                1      4b 0 inz(0)
+        APIEProv int(10) inz(0) pos(1);
-     d APIEAvail               5      8b 0 inz(0)
+        APIEAvail int(10) inz(0) pos(5);
-     d APIErrId                9     15    inz(*blanks)
+        APIErrId char(7) inz(*blanks) pos(9);
+    end-ds;
     //=== Parameters for QMHRMVPM API ===============================
-     d PgmStk          s             10i 0 inz(0)
+    dcl-s PgmStk int(10) inz(0);
-     d MSgKey          s              4    inz(*blanks)
+    dcl-s MSgKey char(4) inz(*blanks);
-     d Remove          s             10    inz('*ALL')
+    dcl-s Remove char(10) inz('*ALL');
 
   //=== Calling Parameters =============================================
   // Parm      I/O/B    Description
   // ----      -----    -----------
   // pPGMMsgQ    I      Program message queue to clear.
-
   //=== ClrMsgPgmQ execution starts here ==========================
-       /free
     QMHRMVPM(pPgmMsgQ
                  :PgmStk
-                 :MsgKey
+                 :MSgKey
                  :Remove
                  :APIError);
 
-      /free
     // Exit with LR off.  This is a tiny routine which will probably
     // be called again.
-         RETURN *off;
+    return *off;
-      /end-free
 
-     p ClrMsgPgmQ      e
+end-proc;
 
 //=== SndEscMsg ===============================================
 // Sends CPF9898 Escape message of the provided text.
 // This will kill the current program and cause an
 // exception in the one that called it.
 
-     P SndEscMsg       B                   Export
+dcl-proc SndEscMsg export;
 
-     D SndEscMsg       PI
+    dcl-pi SndEscMsg;
-     D piMsg                        512a   Const Varying
+        piMsg varchar(512) const;
-     D piStackEnt                    10i 0 Const options(*Nopass)
+        piStackEnt int(10) const options(*nopass);
+    end-pi;
 
        //--- Parameters for QMHSNDPM -------------------------
-     D MsgId           c                   const('CPF9898')
+    dcl-c MSGID const('CPF9898');
-     d MsgF            c                   const('QCPFMSG   *LIBL     ')
+    dcl-c MSGF const('QCPFMSG   *LIBL     ');
-     d MsgType         c                   const('*ESCAPE   ')
+    dcl-c MSGTYPE const('*ESCAPE   ');
-     d PgmQue          c                   const('*         ')
+    dcl-c PGMQUE const('*         ');
-     d InvCount        s             10i 0 inz(2)
+    dcl-s InvCount int(10) inz(2);
-     d ApiError        s             17a   inz(X'00')
+    dcl-s ApiError char(17) inz(x'00');
-     d RetMsgKey       s              4a
+    dcl-s RetMsgKey char(4);
-     D DataLen         s             10i 0
+    dcl-s DataLen int(10);
 
     //--- Local Variables ---------------------------------
-     D MsgData         s           1024a
+    dcl-s MsgData char(1024);
 
-      /FREE
+    DataLen = %len(piMsg);
-
-          DataLen = %len(PiMSG);
     MsgData = piMsg;
 
     if %parms = 2;
@@ -215,80 +210,75 @@
         InvCount = 2;
     endif;
 
-          QMHSNDPM(MsgId
+    QMHSNDPM(MSGID
-                  :MsgF
+                  :MSGF
                   :MsgData
                   :DataLen
-                  :MsgType
+                  :MSGTYPE
-                  :PgmQue
+                  :PGMQUE
                   :InvCount
                   :RetMsgKey
-                  :APIError);
+                  :ApiError);
     return;
 
-      /end-free
 
-     P SndEscMsg       E
+end-proc;
 
 //=== SndInfMsg ===============================================
 // Sends CPF9898 Info message of the provided text to the
 // external message queue.
 // Useful for debugging. See also JobLogMsg.
 
-     P SndInfMsg       B                   Export
+dcl-proc SndInfMsg export;
 
-     D SndInfMsg       PI
+    dcl-pi SndInfMsg;
-     D piMsg                        512a   Const Varying
+        piMsg varchar(512) const;
+    end-pi;
 
     //--- Parameters for QMHSNDPM -------------------------
-     D MsgId           c                   const('CPF9898')
+    dcl-c MSGID const('CPF9898');
-     d MsgF            c                   const('QCPFMSG   *LIBL     ')
+    dcl-c MSGF const('QCPFMSG   *LIBL     ');
-     d MsgType         c                   const('*INFO     ')
+    dcl-c MSGTYPE const('*INFO     ');
-     d PgmQue          c                   const('*EXT      ')
+    dcl-c PGMQUE const('*EXT      ');
-     d InvCount        c                   const(2)
+    dcl-c INVCOUNT const(2);
-     d ApiError        s             17a   inz(X'00')
+    dcl-s ApiError char(17) inz(x'00');
-     d RetMsgKey       s              4a
+    dcl-s RetMsgKey char(4);
-     D DataLen         s             10i 0
+    dcl-s DataLen int(10);
 
     //--- Local Variables ---------------------------------
-     D MsgData         s           1024a
+    dcl-s MsgData char(1024);
 
-      /FREE
+    DataLen = %len(piMsg);
-
-          DataLen = %len(PiMSG);
     MsgData = piMsg;
 
-          QMHSNDPM(MsgId
+    QMHSNDPM(MSGID
-                  :MsgF
+                  :MSGF
                   :MsgData
                   :DataLen
-                  :MsgType
+                  :MSGTYPE
-                  :PgmQue
+                  :PGMQUE
-                  :InvCount
+                  :INVCOUNT
                   :RetMsgKey
-                  :APIError);
+                  :ApiError);
     return;
 
-      /end-free
+end-proc;
-
-     P SndInfMsg       E
 
 //=== JobLogMsg ===============================================
 // Write arbitray message to the Job log.
 // Uses Qp0zLprintf, which is a C function.
 // Useful for debugging. See also SndInfMsg.
 
-     P JobLogMsg       B                   Export
+dcl-proc JobLogMsg export;
 
-     D JobLogMsg       PI
+    dcl-pi JobLogMsg;
-     D piMsg                        512a   Value Varying
+        piMsg varchar(512) value;
+    end-pi;
 
-     d wkMsg           s             +1    like(piMSg)
+    dcl-s wkMsg like(piMsg:+1);
-     d EOL             c                   x'25'
+    dcl-c EOL x'25';
 
-      /FREE
     wkMsg = piMsg + EOL;
     printF(wkMsg);
     return;
-      /end-free
+end-proc;
-     P JobLogMsg       E

Service_Pgms/SRV_MSGTL.RPGLE

@@ -2,10 +2,10 @@
 //=== Tests JobLogMsg procedures in SRV_MSG service program ========
 ctl-opt  option(*NoDebugIo: *SrcStmt :*NoUnref) indent(' |')
     ActGrp('QILE') DftActGrp(*no)
-    BndDir('UTIL_BND':'SQL_BND')
+    BndDir('UTIL_BND')
     Main(Main);
 
-/include copy_mbrs,Srv_Msg_P
+/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE
 
 dcl-proc Main  ;
     dcl-pi *n extpgm('SRV_MSGTL');
@@ -36,5 +36,5 @@ dcl-proc Main  ;
     // JobLogMsg(scale );
 
     SndInfMsg('SndInfMsg - to compare to JobLogMsg');
-    JobLogmsg('JobLogMsg - to compare to SndInfMsg');
+    JobLogMsg('JobLogMsg - to compare to SndInfMsg');
 end-proc;

Service_Pgms/SRV_MSGTR.RPGLE

@@ -1,51 +1,50 @@
-
+**free
 //=== Tests procedures in SRV_MSG service program =============
-     H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
+ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
-     H BndDir('UTIL_BND')
+       bnddir('UTIL_BND');
 
 //=== Display File ============================================
-     FSRV_MSGTD CF   E             WorkStn INFDS(dfInfDS)
+dcl-f SRV_MSGTD workstn infds(dfInfDS) indds(dfIndDS) usropn;
-     F                                     INDDS(dfIndDS)
-     F                                     USROPN
 
 //=== Service Program Prototypes ==============================
-      /include copy_mbrs,Srv_Msg_P
+/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE
 
 //=== Named hexadecimal constants for function keys ===========
-      /include copy_mbrs,##AIDBYTES
+/INCLUDE ../Copy_Mbrs/AIDBYTES.RPGLE
 
 //=== Display File Information Data Structure =================
 //    Allows us to determine which function key was pressed
-     D dfInfDS         DS
+dcl-ds dfInfDS;
-     D Key                   369    369
+  Key char(1) pos(369);
+end-ds;
 //=== Display File Indicator Data Structure ===================
-
 // This is a "private" indicator area for the display file.
-     D dfIndDS         ds            99
+dcl-ds dfIndDS len(99);
-     D SH_ERR                 40     40n
+  SH_ERR ind pos(40);
-
+end-ds;
 
 //=== Global Switches =========================================
-     D SflMsgSnt       s               n
+dcl-s SflMsgSnt ind;
-     D CowsComeHome    c                   const('0')
+dcl-c COWSCOMEHOME const('0');
 
 //=== Work Fields =============================================
-     D inx             s             10i 0
+dcl-s inx int(10);
+
 
 //=== Program Status Data Structure ===========================
-     D ProgStatus     sds
+dcl-ds ProgStatus PSDS;
-     D PgmName           *PROC
+  PgmName *PROC;
+end-ds;
 
-      /FREE
 //=============================================================
 // === Main Program Loop ======================================
 //=============================================================
-       exsr init;
+Init();
 SFT_KEYS='F3/F12=Exit';
 SH_Cnt = 2;
 SH_MSG = 'This is a fine pickle Ollie!';
 
-       dou CowsComeHome;
+dou COWSCOMEHOME;
   write SH_HDR;
   write SFT_FKEY;
   if SflMsgSnt = *on;
@@ -56,7 +55,7 @@
   SH_ERR = *off;
 
   if key = F03 or Key = F12;
-             exsr CloseDownPgm;
+    CloseDownPgm();
     return;
   endif;
 
@@ -101,6 +100,7 @@
     when Key = F08;
       JobLogMsg(SH_MSG);
       iter;
+    other;
 
   endsl;
 enddo;
@@ -109,27 +109,25 @@
 //=== End of Main Program Loop ================================
 //=============================================================
 
-
 //=== CloseDownPgm ============================================
 // Things to do before we issue a return to the caller
-       begsr CloseDownPgm;
+Dcl-Proc CloseDownPgm;
   *inlr = *on;
   close SRV_MSGTD;
-       endsr;
+End-Proc;
 
 //=== Init ====================================================
-       begsr Init;
+Dcl-Proc Init;
   MSGPGMQ = PgmName;
   SH_PGM = PgmName;
   if not %open(SRV_MSGTD);
     open SRV_MSGTD;
   endif;
-       endsr;
+End-Proc;
 
 //=============================================================
 //   S u b  P r o c e d u r e s
 //=============================================================
-
 //=== SndSflMsg ===============================================
 // Send a message to the Error Subfile
 // Returns:        *ON
@@ -138,22 +136,19 @@
 // Parameter:      ErrMsgFile => Optional Error Message File
 //                 Defaults to CUSTMSGF
 //------------------------------------------------------------
-      /END-FREE
+dcl-proc SndSflMsg;
-     P SndSflMsg       B
+  dcl-pi SndSflMsg ind;
-     D SndSflMsg       PI              N
+    ErrMsgId char(7) const;
-     D  ErrMsgId                      7A   CONST
+    ErrMsgData char(80) const options(*nopass:*varsize);
-     D  ErrMsgData                   80A   CONST
+    ErrMsgFile char(10) const options(*nopass);
-     D                                     OPTIONS(*NOPASS:*VARSIZE)
+  end-pi;
-     D  ErrMsgFile                   10A   CONST
-     D                                     OPTIONS(*NOPASS)
 
     // Local fields
-     D retField        S               N
+  dcl-s retField ind;
-     D wkMsgId         s              7a
+  dcl-s wkMsgId char(7);
-     D wkMsgFile       s             10a
+  dcl-s wkMsgFile char(10);
-     D wkMsgData       s            512a   varying
+  dcl-s wkMsgData varchar(512);
 
-      /FREE
   if %parms >2;
     wkMsgFile = ErrMsgFile;
   else;
@@ -165,15 +160,12 @@
     wkMsgData = ' ';
   ENDIF;
   wkMsgId = ErrMsgId;
-       SNDMSGPGMQ(PgmName:
+  SndMsgPgmQ(PgmName:
-             wkMsgid:
+             wkMsgId:
              wkMsgFile:
              wkMsgData);
 
   retField = *on;
   RETURN retField;
 
-      /END-FREE
+end-proc;
-     P SndSflMsg       E
-
-

Service_Pgms/SRV_RANDT1.SQLRPGLE

@@ -3,7 +3,7 @@
 // writing them to file RNUM.
 ctl-opt DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
       BndDir('UTIL_BND');
-/COPY copy_mbrs,srv_rand_p
+/COPY ../Copy_Mbrs/SRV_RAND_P.RPGLE
 exec sql set  option datfmt=*iso,
               commit=*none,
               closqlcsr=*endmod;

Service_Pgms/SRV_SQL.SQLRPGLE

@@ -9,7 +9,8 @@
 
 ctl-opt nomain
       bnddir('UTIL_BND')
-      option(*NoDebugIo: *srcstmt);
+      option(*NoDebugIo: *srcstmt)
+;
 
 //=== SQLProblem ===============================================
 // For those "Never should happen" SQL errors.
@@ -21,7 +22,7 @@ dcl-proc SQLProblem export;
     piSQLDebug varchar(200) const;
   end-pi;
 
-  /include copy_mbrs,Srv_Msg_P
+  /include ../Copy_Mbrs/SRV_MSG_P.RPGLE
 
   //--- Local Variables ---------------------------------
   dcl-s myDebugMsg varchar(512); //Max CPF9898 supports

Service_Pgms/SRV_STR.RPGLE

@@ -1,6 +1,7 @@
+**free
 //==============================================================
 //=== SRV_STR service program contains procedures working
-      //=== with strings
+//=== with fixed length strings
 //==============================================================
 // CRTRPGMOD MODULE(SRV_STR)
 // CRTSRVPGM SRVPGM(SRV_STR) EXPORT(*ALL)
@@ -10,14 +11,18 @@
 // Return the centered string. The input string is normally
 // fixed length and RPG will promote it to varying on the
 // call. A varying string is returned which RPG will reset
-      // to fixed if needed.
+// to fixed.
-      // It will also execute with a varying string input but the
+
-      // result may not be what you expect.
+//  **********************************************************
-      //
+//  *** It will also execute with a varying string input   ***
+//  *** but the result probably wont't be what you expect. ***
+//  *** So don't use it on a varchar string.               ***
+//  **********************************************************
+
 // Conceptual call:
 //=================
 // H BndDir('UTIL_BND')
-      //  /include copy_mbrs,Srv_Str_P
+//  /include ../Copy_Mbrs,SRV_STR_P.RPGLE
 // d Head            S             20A   inz('Inquiry')
 //       Head = CenterStr(Head);
 // Notes:
@@ -28,18 +33,16 @@
 //   Right justify is also simple:
 //      evalr str = %trim(str);
 
-     h nomain option(*NoDebugIo: *srcstmt)
+ctl-opt nomain option(*nodebugio: *srcstmt);
-      /include copy_mbrs,SRV_STR_P
+/INCLUDE ../Copy_Mbrs/SRV_STR_P.RPGLE
-     p CenterStr       b                   export
+dcl-proc CenterStr export;
-     d CenterStr       pi           256a   varying
+    dcl-pi CenterStr varchar(256);
-     d InStr                        256a   varying const
+        InStr varchar(256) const;
-     d
+    end-pi;
-     d blanks          s            256a   varying inz
+    dcl-s blanks varchar(256) inz;
-     d trimInStr       s            256a   varying
+    dcl-s trimInStr varchar(256);
-      /free
     trimInStr = %trim(InStr);
     // Set length to materialize required leading blanks.
-       %len(blanks) = %int((%len(inStr) - %len(trimInStr))/2);
+    %len(blanks) = %int((%len(InStr) - %len(trimInStr))/2);
     return  blanks + trimInStr;
-      /end-free
+end-proc;
-     p CenterStr       e

Service_Pgms/SRV_STRTR.RPGLE

@@ -1,78 +1,82 @@
-
+**free
 // === Test the SRV_STR service program========================
 
-     H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
+ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
-     H BndDir('UTIL_BND')
+       bnddir('UTIL_BND');
 
-     d X1              S              1A   inz('A')                             One char
+dcl-s X1 char(1) inz('1');
-     d X2              S              2A   inz('B ')                            Two char
+dcl-s X2 char(2) inz('2 ');
-     d X3              S              4A   inz('C   ')                          3 blanks
+dcl-s X3 char(3) inz('3  ');
-     d X4              S              5A   inz('D    ')                         4 blanks
+dcl-s X4 char(4) inz('4   ');
-     d X5              S              6A   inz('E    ')                         5 blanks
+dcl-s X5 char(5) inz('5    ');
-     d X0              S              5A   inz('     ')                         all blank
+dcl-s X6 char(6) inz('6     ');
-     d Xl              S             20A   inz('20-chars  ')                    longer
+dcl-s X7 char(7) inz('    7  ');
-     d Xm              S             21A   inz('       21-Chars')               longer
+dcl-s X8 char(8) inz('   8    ');
-     d Xv              S             24    inz('    24-varying  ') varying      Varying-note result
+dcl-s X0 char(5) inz('     '); // all blank
-     d l1              S             20A   inz('           ABCDE  ')            Left align
+dcl-s XL char(20) inz(' 20-chars'); // longer
-     d l2              S             20A   inz('Left already      ')            Left align
+dcl-s XM char(21) inz(' 21-Chars'); // longer
-     d r1              S             20A   inz('abc')                           Right align
+dcl-s XV varchar(20) inz('20-vary');                // Varying-fails
-     d r2              S             20A   inz('   defgh  ')                    Right align
+dcl-s XW varchar(21) inz(' 21-vary             ');  // Varying-fails
-      /include copy_mbrs,SRV_STR_P
-      /free
-         x1 = tst(x1);
-         dsply ('-' + x1 + '-');
 
-         x2 = tst(x2);
+// dcl-s l1 char(20) inz('           ABCDE  '); // Left align
-         dsply ('-' + x2 + '-');
+// dcl-s l2 char(20) inz('Left already      '); // Left align
+// dcl-s r1 char(20) inz('abc'); // Right align
+// dcl-s r2 char(20) inz('   defgh  '); // Right align
 
-         x3 = tst(x3);
+/include ../Copy_Mbrs/SRV_STR_P.RPGLE
-         dsply ('-' + x3 + '-');
+/include ../Copy_Mbrs/PRT_P.RPGLE
 
-         x4=tst(x4);
+PRT('*** Testing SRV_STR Service Program ***' : '*H1');
-         dsply ('-' + x4 + '-');
+CenterIt(X1);
+CenterIt(X2);
+CenterIt(X3);
+CenterIt(X4);
+CenterIt(X5);
 
-         x5 = tst(x5);
+CenterIt(X6);
-         dsply ('-' + x5 + '-');
+CenterIt(X7);
+CenterIt(X8);
 
-         x0 = tst(x0);
+CenterIt(X0);
-         dsply ('-' + x0 + '-');
 
-         xl = tst(xl);
+CenterIt(XL);
-         dsply ('-' + xl + '-');
 
-         xm = tst(xm);
+CenterIt(XM);
-         dsply ('-' + xm + '-');
 
-         xv = tst(xv);
+CenterIt(XV);
-         dsply ('-' + xv + '-');
+CenterIt(XW);
 
-         dsply ('---- Left Justify ---');
+// dsply ('---- Left Justify ---');
-         dsply ('-' + l1 + '-');
+// dsply ('-' + l1 + '-');
-         l1 =%trim(l1);
+// l1 =%trim(l1);
-         dsply ('-' + l1 + '-');
+// dsply ('-' + l1 + '-');
 
-         dsply ('-' + l2 + '-');
+// dsply ('-' + l2 + '-');
-         l2 =%trim(l2);
+// l2 =%trim(l2);
-         dsply ('-' + l2 + '-');
+// dsply ('-' + l2 + '-');
 
-         dsply ('---- Right Justify ---');
+// dsply ('---- Right Justify ---');
-         dsply ('-' + r1 + '-');
+// dsply ('-' + r1 + '-');
-         evalr r1 = %trim(r1);
+// evalr r1 = %trim(r1);
-         dsply ('-' + r1 + '-');
+// dsply ('-' + r1 + '-');
 
-         dsply ('-' + r2 + '-');
+// dsply ('-' + r2 + '-');
-         evalr r2 = %trim(r2);
+// evalr r2 = %trim(r2);
-         dsply ('-' + r2 + '-');
+// dsply ('-' + r2 + '-');
 
+PRT(' ' :'*CLOSE');
 *inlr = *on;
 return;
-      /END-FREE
+
-     p tst             b
+dcl-proc CenterIt;
-     d tst             pi            50a   varying
+    dcl-pi CenterIt;
-     d II                            50a   varying const
+        II varchar(50) const;
-      /free
+    end-pi;
-       dsply '---------------------';
+    dcl-s wk varchar(50) inz;
-         DSPLY ('-' + ii + '-');
+    wk = CenterStr(II);
-         return CenterStr(ii);
+    %len(wk) = %len(II);
-      /end-free
+    PRT('-1234567890123456789012345');
-     p tst             e
+    PRT('-' + II + '-');
+    PRT('-' + wk + '-');
+    return;
+end-proc;

USPS_Address/MTNCUSTR.SQLRPGLE

@@ -40,21 +40,22 @@
 //=============================================================
 
 ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
-bnddir('UTIL_BND':'ADRVAL_BND') main(main);
+bnddir('UTIL_BND': 'ADRVAL_BND': 'SRV_BASE36') main(Main);
 
 //=== Display File =============================================
-dcl-f MTNCUSTD workstn infds(dfinfds) indds(dfindds) usropn;
+dcl-f MTNCUSTD workstn infds(dfInfDS) indds(dfIndDS) usropn;
 
 //=== Service Program Prototypes ===============================
-/include copy_mbrs,Srv_Msg_P
+/include ../Copy_Mbrs/SRV_MSG_P.RPGLE
-/include copy_mbrs,Srv_Str_P
+/include ../Copy_Mbrs/SRV_STR_P.RPGLE
-/include usps,USAdrVal_p
+/include ../Copy_Mbrs/USADRVAL_P.RPGLE
+/include ../Copy_Mbrs/BASE36_P.RPGLE
 
 //=== Named hexadecimal constants for function keys ============
-/include copy_mbrs,##AIDBYTES
+/include ../Copy_Mbrs/AIDBYTES.RPGLE
 
 //=== USAdrVal Paramter DS ======================================
-/include usps,USAdrvalDS
+/include ../Copy_Mbrs/USADRVALDS.RPGLE
 dcl-ds AdrIn  likeds (USAdrValDS);
 dcl-ds AdrOut likeds (USAdrValDS);
 
@@ -133,12 +134,9 @@ 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 ==========================
-dcl-s Cust_Next packed(4) dtaara('CUSTNEXT');
+dcl-s Cust_Next char(4) dtaara('CUSTNEXT');
+dcl-s varCust_Next varchar(4);
 
 //=== Program Status Data Structure ============================
 dcl-ds ProgStatus PSDS;
@@ -617,7 +615,9 @@ dcl-proc Main;
   begsr AddRecd;
     NoErrors = *on;
     in *LOCK Cust_Next;
-    Cust_Next += 1;
+    varCust_Next = Cust_Next;
+    varCust_Next = BASE36ADD(varCust_Next);
+    Cust_Next = varCust_Next;
     Out Cust_Next;
     CUSTID= Cust_Next;
     CHGTIME = %timestamp();
@@ -702,7 +702,7 @@ dcl-proc Main;
       write MSGCTL;
     endif;
 
-    exfmt Details;
+    exfmt DETAILS;
 
     // Clear most display file indicators
     clear dfIndClr;

USPS_Address/Readme.md

@@ -32,4 +32,4 @@ If ADDRESS2 is non blank, then you have a valid address.  Otherwise find a descr
 
 ### USADRVAL_T
 
-A program to exercise USADRVAL with a some addresses, writing the input and output side by side to QSYSPRT.
+A program to exercise USADRVAL with some addresses, writing the input and output side by side to QSYSPRT.

USPS_Address/USADRVAL.SQLRPGLE

@@ -27,10 +27,10 @@ ctl-opt
     option(*nodebugio: *srcstmt)
 ;
 //=== Prototypes =====================================================
-/copy copy_mbrs,Srv_SQL_P
+/copy ../Copy_Mbrs/SRV_SQL_P.RPGLE
 
 //=== Parameter Data Structure Template ==============================
-/copy copy_mbrs,USAdrValDS
+/copy ../Copy_Mbrs/USADRVALDS.RPGLE
 
 // === Data area containing your USPS supplied User id. ==============
 // (The USPS supplied USER ID length is not clear, so I made it

USPS_Address/USADRVAL_T.RPGLE

@@ -7,9 +7,9 @@ ctl-opt debug option(*nodebugio: *srcstmt)
 // Program to exercise USADRVAL.
 // Results are printed to QSYSPPRT.
 //====================================================================
-/copy copy_mbrs,USAdrValDS
+/copy ../Copy_Mbrs/USADRVALDS.RPGLE
-/copy copy_mbrs,Srv_Msg_P
+/copy ../Copy_Mbrs/SRV_MSG_P.RPGLE
-/copy copy_mbrs,USAdrVal_p
+/copy ../Copy_Mbrs/USADRVAL_P.RPGLE
 
 dcl-f qsysprt printer(132) usropn;