ecki/IBM-i-RPG-Free-CLP-Code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

USADRVAL Initial Add

Browse Source
This commit is contained in:
SJLennon
2022-01-24 17:58:27 -05:00
parent 0caad3875e
commit dc2b442cfa
8 changed files with 1411 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Copy_Mbrs/README.md
+8
View File
@@ -17,3 +17,11 @@ These are source files that will be copied into programs using /COPY or /INCLUDE
* SRV_SQL_P * SRV_SQL_P
Prorotype definitions for procedures in the SQL_SRV service program. Prorotype definitions for procedures in the SQL_SRV service program.
* USADRVAL_P
Prototype for the USADRVAL service program.
* USADRVALDS
Template Data Structure for the USADRVAL parameters.
README.md
+5
View File
@@ -50,6 +50,11 @@ Commands, CLLE, SQLRPGLE using SQL access to APIs.
Sets up group jobs suitable for an IBM i developer. Sets up group jobs suitable for an IBM i developer.
## USPS_Address
SQL QSYS2.HTTP_GET call to the US Post Office webtools API AddressValidateRequest.
RPG service program to call the API and parse the returned XML.
## Utils ## Utils
Developer Utilities. Developer Utilities.
USPS_Address/CRTBNDDIR.CLLE
+8
View File
@@ -0,0 +1,8 @@
PGM
/* Create ADRVAL_BND binding directory in *CURLIB */
/* Change next statement if needed */
CRTBNDDIR BNDDIR(*CURLIB/ADRVAL_BND) TEXT('USADRVAL +
Service PGM')
ADDBNDDIRE BNDDIR(ADRVAL_BND) OBJ((USADRVAL *SRVPGM +
*DEFER))
ENDPGM
USPS_Address/MTNCUSTD.DSPF
+194
View File
@@ -0,0 +1,194 @@
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* 01/2021 Lennon Allow lower case on name, address, city
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 0 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 9CHECK(LC)
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 9CHECK(LC)
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 9CHECK(LC)
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 15CHECK(LC)
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>
USPS_Address/MTNCUSTR.SQLRPGLE
+860
View File
@@ -0,0 +1,860 @@
**FREE
/TITLE MNTCUSTR - Update/Display a Customer Master
//==============================================================
// A maintenance or display program for a Customer Master Recds
//
//
// Parameters
// ----------
// 1 In Z4 Customer Id to, or 0 to add a new code
// 2 In CL1 Function
// E - Edit passed record
// D - Display passed record
// A - Add a new record
//
// If no parms passed, close the display file and return.
//==============================================================
// Program is essentially without indicators. (Indicators are
// stil lneeded to control the display file, but all have names.)
//
// Naming Conventions
// ==================
// - Lower case is the default for opcodes.
// - TitleCase is used for program variables, subroutines and procedure
// names, e.g. MaxOrderQty, BldFkeyText, etc.
// - Temporary variables are prefixed with "wk", e.g., wkDate. Such
// variables contain valid data for only a short time and are never
// carried across subroutines.
// - UPPERCASE is used for external names, i.e., files, fields, formats
// and anything else not directly coded in the program.
//
// - In the display file, this screen field naming convention is used:
// Screen Header: Fields begin with SH_
// Detail Fields begin with SD_
// Screen footer: Fields begin with SFT_
//==============================================================
// Compilation
// Use CRTSQLRPGI command.
// Note that /INCLUDEs expects to find code in DEMO library,
// not the default of QRPGLESRC. Change as needed.
//=============================================================
ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
bnddir('UTIL_BND':'ADRVAL_BND') main(main);
//=== Display File =============================================
dcl-f MTNCUSTD workstn infds(dfinfds) indds(dfindds) usropn;
//=== Service Program Prototypes ===============================
/include copy_mbrs,Srv_Msg_P
/include copy_mbrs,Srv_Str_P
/include usps,USAdrVal_p
//=== Named hexadecimal constants for function keys ============
/include copy_mbrs,##AIDBYTES
//=== USAdrVal Paramter DS ======================================
/include usps,USAdrvalDS
dcl-ds AdrIn likeds (USAdrValDS);
dcl-ds AdrOut likeds (USAdrValDS);
//=== Fields read by SQL ========================================
// NOTE: Only the fields in the SQL statement are populated!
dcl-ds CUSTMAST extname('CUSTMAST') end-ds;
//=== SQL State Constants ======================================
dcl-c SQLSUCCESS '00000';
dcl-c SQLNODATA '02000';
dcl-c SQLNOMOREDATA '02000';
dcl-c SQLDUPRECD '23505';
dcl-c SQLROWLOCKED '57033';
//=== Display File Information Data Structure ==================
// Allows us to determine which function key was pressed
dcl-ds dfInfDS;
Key char(1) pos(369);
end-ds;
//=== Display File Indicator Data Structure ====================
// This is a "private" indicator area for the display file.
//--- 01-20 are not automatically cleared after EXFMT ----------
dcl-ds dfIndDS len(99);
//--- 21-99 are automatically cleared after EXFMT --------------
Protect_SD_ALL ind pos(10);
dfIndClr char(79) pos(21);
RI_SD_ACTIVE ind pos(40);
PC_SD_ACTIVE ind pos(41);
RI_SD_NAME ind pos(42);
PC_SD_NAME ind pos(43);
RI_SD_ADDR ind pos(44);
PC_SD_ADDR ind pos(45);
RI_SD_CITY ind pos(46);
PC_SD_CITY ind pos(47);
RI_SD_STATE ind pos(48);
PC_SD_STATE ind pos(49);
RI_SD_ZIP ind pos(50);
PC_SD_ZIP ind pos(51);
RI_SD_ACCTPH ind pos(52);
PC_SD_ACCTPH ind pos(53);
RI_SD_ACCTMGR ind pos(54);
PC_SD_ACCTMGR ind pos(55);
RI_SD_CORPPH ind pos(56);
PC_SD_CORPPH ind pos(57);
DSP_SD_STAMP ind pos(61);
end-ds;
//=== Screen Header Text =======================================
dcl-s H2TextE like(sh_funct) inz('Change Customer');
dcl-s H2TextA like(sh_funct) inz('Add Customer');
dcl-s H2TextD like(sh_funct) inz('Displaying Customer');
//=== Text for function keys ===================================
dcl-c F3TEXT 'F3=Exit';
dcl-c F4TEXT 'F4=Prompt+';
dcl-c F5TEXT 'F5=Refresh';
dcl-c F12TEXT 'F12=Cancel';
//=== External Programs Prototypes =============================
dcl-pr PmtState extpgm('PMTSTATER');
*n like(state); // TheState
end-pr;
//=== Global Switches ==========================================
dcl-c COWSCOMEHOME const('0');
dcl-c DISPLAYING const('D');
dcl-c EDITING const('E');
dcl-c ADDING const('A');
dcl-s SflMsgSnt ind;
dcl-s Function char(1);
dcl-s NoErrors ind;
// === Global Fields ===========================================
dcl-s Orig_CHGTIME timestamp;
//=== Work Fields ==============================================
dcl-s wkInt int(10);
dcl-s wkMsgText varchar(256);
// === Next available customer number ==========================
dcl-s Cust_Next packed(4) dtaara('CUSTNEXT');
//=== Program Status Data Structure ============================
dcl-ds ProgStatus PSDS;
PgmName *PROC;
CURR_USER char(10) pos(358); // * Current user
end-ds;
dcl-s MainProc char(10);
//==============================================================
//==============================================================
// === Program Starts Here =====================================
//==============================================================
dcl-proc Main;
dcl-pi Main;
pID like(custid);
pMaintain char(1);
end-pi;
//=== Set SQL Options ===============================
exec sql set option datfmt=*iso,
closqlcsr=*endmod,
commit = *NONE;
//=== Initialization Logic ===================================
exsr Init;
//--- Establish window that other formats refer to ---
write SH_HDR;
//============================================================
// === Main Program Loop =====================================
//============================================================
// Loops until logic decides to exit.
dou (COWSCOMEHOME);
select;
// =======================================================
// === DISPLAYING an existing Customer ===================
// =======================================================
when ( Function = DISPLAYING);
exsr ReadRecd;
if (SQLSTT = SQLNODATA);
SQLProblem('Calling error 1: Code passed in does not exist.');
endif;
exsr FillScreenFields;
// All Fields protected
exsr ProtectAll;
exsr ScreenIO;
exsr CloseDownPgm;
return;
// =======================================================
// === Updating an existing Customer =====================
// =======================================================
when (Function = EDITING);
exsr ReadRecd;
if (SQLSTT = SQLNODATA);
SQLProblem('Calling error 2: Code passed in does not exist.');
endif;
exsr FillScreenFields;
// Write/read screen until all data is valid,
// then re-display for confirmation to update.
dou (NoErrors);
exsr ScreenIO;
select;
when (Key = F12);
exsr CloseDownPgm;
return;
when (Key = F05);
exsr ReadRecd;
if (SQLSTT = SQLNODATA);
// Record vanished!
SflMsgSnt= SndSflMsg('DEM0599'); //Delete, redo search
clear CUSTMAST;
endif;
NoErrors = *off;
when (Key = F04);
exsr F04Prompt;
when (Key = Enter);
exsr EditUpdData;
if (NoErrors);
// Re-display screen fields for confirmation
exsr ProtectAll;
exsr FillScreenFields;
SflMsgSnt = SndSflMsg('DEM0000'); // Enter to update ...
exsr ScreenIO;
select;
when (Key = F12 or Key = F05);
// Loop again
when (Key = Enter);
exsr UpdateRecd;
if (NoErrors);
exsr CloseDownPgm; // Success! Exit program
return;
endif;
other;
SflMsgSnt = SndSflMsg('DEM0003'); // Key not active
NoErrors = *off;
endsl;
endif;
// Open up fields for correction of errors
exsr UnProtectAll;
other;
SflMsgSnt = SndSflMsg('DEM0003'); // Key not active
NoErrors = *off; // Stay in dou NoErrors
endsl;
enddo;
// =======================================================
// === Adding a new Customer =============================
// =======================================================
when ( Function=ADDING);
clear CUSTMAST;
//Default status to active
ACTIVE = 'Y';
exsr FillScreenFields;
dou (NoErrors);
// Write/read screen until all data is valid,
// then re-display for confirmation to update.
//All fields can be keyed
exsr UnProtectAll;
exsr ScreenIO;
select;
when (Key = F12);
exsr CloseDownPgm;
return;
when (Key = F04);
exsr F04Prompt;
when (Key = F05);
clear CUSTMAST;
ACTIVE = 'Y';
exsr FillScreenFields;
when (Key = Enter);
exsr EditAddData;
if (NoErrors);
// Re-display field for confirmation
exsr ProtectAll;
SflMsgSnt = SndSflMsg('DEM0009'); // Enter to add ...
exsr FillScreenFields;
exsr ScreenIO;
select;
when (Key=F12);
exsr FillScreenFields;
when (Key = Enter);
exsr AddRecd;
if (NoErrors);
exsr CloseDownPgm;
return;
endif;
other;
SflMsgSnt = SndSflMsg('DEM0003'); // Key not active
NoErrors = *off;
endsl;
endif;
other;
SflMsgSnt = SndSflMsg('DEM0003'); // Key not active
endsl;
enddo;
other;
// =======================================================
//=== Goofed - Should ever happen ========================
// =======================================================
dump(a);
SflMsgSnt = SndSflMsg('DEM9999'); // Contact IT now ...
return;
endsl;
enddo;
exsr CloseDownPgm; // Should never happen
return;
//============================================================
//=== End of Main Program Loop ===============================
//============================================================
return;
//=== ReadRecd ===============================================
begsr ReadRecd;
exec sql
select
CUSTID
,NAME
,ADDR
,CITY
,STATE
,ZIP
,CORPPHONE
,ACCTMGR
,ACCTPHONE
,ACTIVE
,CHGTIME
,CHGUSER
into :CUSTMAST
from CUSTMAST
where CUSTID = :pID
;
if (SQLSTT <> SQLSUCCESS and SQLSTT <> SQLNODATA);
SQLProblem('ReadRecd');
endif;
Orig_CHGTIME = CHGTIME; // Save for update comparison
endsr;
//=== FillScreenFields =======================================
begsr FillScreenFields;
SD_CUSTID = CUSTID;
SD_NAME = NAME;
SD_ADDR = ADDR;
SD_CITY = CITY;
SD_STATE = STATE;
SD_ZIP = ZIP;
SD_ACTIVE = ACTIVE;
SD_ACCTPH = ACCTPHONE;
SD_ACCTMGR =ACCTMGR;
SD_CORPPH = CORPPHONE;
SD_CHGTIME = ' ';
SD_CHGUSER = ' ';
// Show Changed stamp info
if (CHGUSER <> '*SYSTEM*' and CHGUSER <> ' ');
exec sql VALUES
varchar_format(:CHGTIME, 'YYYY-Mon-DD')
concat ' at ' concat
varchar_format(:CHGTIME,'HH24:MI:SS')
into :SD_CHGTIME;
SD_CHGUSER = CHGUSER;
DSP_SD_STAMP = *on;
endif;
endsr;
//=== F04Prompt ==============================================
// CF04 reads the screen data. We then prompt and replace
// anything in the state field, then we redisplay and
// re-edit the screen data.
// Always sets NoError to *off to force re-edit
begsr F04Prompt;
select;
// --- Prompt for State Code
when (SD_PMT_FLD = 'SD_STATE');
PmtState(STATE);
SD_STATE = STATE;
PC_SD_STATE = *ON;
// --- Field not promptable
other;
// Use F4 only in field followed by + sign
SflMsgSnt= SndSflMsg('DEM0005');
endsl;
NoErrors = *off; // DOU Loop again
endsr;
//=== EditUpdData ============================================
// Edit the screen fields that can be changed on a update.
// Give up when the first error found.
// A valid screen field is moved to the database record.
begsr EditUpdData;
NoErrors = *on;
// ACTIVE Status
exsr Edit_SD_ACTIVE;
if (NoErrors = *off);
leavesr;
endif;
// Name
exsr Edit_SD_NAME;
if (NoErrors = *off);
leavesr;
endif;
// // Addr
// exsr Edit_SD_ADDR;
// if (NoErrors = *off);
// leavesr;
// endif;
// // City
// exsr Edit_SD_CITY;
// if (NoErrors = *off);
// leavesr;
// endif;
// // State
// exsr Edit_SD_STATE;
// if (NoErrors = *off);
// leavesr;
// endif;
// // ZIP
// exsr Edit_SD_ZIP;
// if (NoErrors = *off);
// leavesr;
// endif;
// Account Phone
exsr Edit_SD_ACCTPH;
if (NoErrors = *off);
leavesr;
endif;
// Account Manager
exsr Edit_SD_ACCTMGR;
if (NoErrors = *off);
leavesr;
endif;
// Corporate Phone
exsr Edit_SD_CORPPH;
if (NoErrors = *off);
leavesr;
endif;
// Address
exsr Edit_Address;
if (NoErrors = *off);
leavesr;
endif;
endsr;
//=== EditAddData ============================================
// Edit the screen fields needed to add a record.
// Give up when the first error found.
// A valid screen field is moved to the database record.
begsr EditAddData;
// For this program. same data for edit and add.
exsr EditUpdData;
endsr;
//=== Edit Address ===========================================
begsr Edit_Address;
clear AdrIn;
AdrIn.Address2 = SD_ADDR;
AdrIn.City = SD_CITY;
AdrIn.State = SD_STATE;
AdrIn.Zip5 = %subst(SD_ZIP :1 :5);
AdrOut = USAdrVal(AdrIn);
// Good address-copy from USPS data & return
if (AdrOut.City <> ' ');
ADDR = AdrOut.Address2;
CITY = AdrOut.City;
STATE = AdrOut.State;
if (AdrOut.Zip4 <> ' ');
ZIP = AdrOut.Zip5 + '-' + AdrOut.Zip4;
else;
ZIP = AdrOut.Zip5;
endif;
leavesr;
endif;
// Bad address-send USPS error message
SflMsgSnt = SndSflMsg('DEM9898' : AdrOut.Description);
NoErrors = *off;
PC_SD_ADDR = *ON;
RI_SD_ADDR = *ON;
RI_SD_CITY = *ON;
RI_SD_STATE= *ON;
RI_SD_ZIP= *ON;
endsr;
//=== Edit_SD_ACTIVE==========================================
begsr Edit_SD_ACTIVE;
if (SD_ACTIVE = 'Y' or SD_ACTIVE = 'N');
ACTIVE = SD_ACTIVE;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0501': 'Active Status');
NoErrors = *off;
RI_SD_ACTIVE = *on;
PC_SD_ACTIVE = *on;
endsr;
//=== Edit_SD_NAME ===========================================
begsr Edit_SD_NAME;
if (SD_NAME <> ' ');
NAME = SD_NAME;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Name');
NoErrors= *off;
RI_SD_NAME = *ON;
PC_SD_NAME = *ON;
endsr;
//=== Edit_SD_ADDR ===========================================
begsr Edit_SD_ADDR;
if (SD_ADDR <> ' ');
ADDR = SD_ADDR;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Address');
NoErrors= *off;
RI_SD_ADDR = *ON;
PC_SD_ADDR = *ON;
endsr;
//=== Edit_SD_CITY ===========================================
begsr Edit_SD_CITY;
if (SD_CITY <> ' ');
CITY = SD_CITY;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'City');
NoErrors= *off;
RI_SD_CITY = *ON;
PC_SD_CITY = *ON;
endsr;
//=== Edit_SD_STATE ==========================================
begsr Edit_SD_STATE;
exec sql select STATE into :STATE
from STATES
where STATE = :SD_STATE;
if (SQLSTT = SQLSUCCESS);
STATE = SD_STATE;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0503');
NoErrors= *off;
RI_SD_STATE= *ON;
PC_SD_STATE = *ON;
endsr;
//=== Edit_SD_ZIP ============================================
begsr Edit_SD_ZIP;
if (SD_ZIP <> ' ');
ZIP = SD_ZIP;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'ZIP');
NoErrors= *off;
RI_SD_ZIP= *ON;
PC_SD_ZIP = *ON;
endsr;
//=== Edit_SD_ACCTPH =========================================
begsr Edit_SD_ACCTPH;
if (SD_ACCTPH <> ' ');
ACCTPHONE = SD_ACCTPH;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Account Manager Phone');
NoErrors= *off;
RI_SD_ACCTPH= *ON;
PC_SD_ACCTPH = *ON;
endsr;
//=== Edit_SD_ACCTMGR =========================================
begsr Edit_SD_ACCTMGR;
if (SD_ACCTMGR <> ' ');
ACCTMGR = SD_ACCTMGR;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Account Manager Name');
NoErrors= *off;
RI_SD_ACCTMGR= *ON;
PC_SD_ACCTMGR = *ON;
endsr;
//=== Edit_SD_CORPPH =========================================
begsr Edit_SD_CORPPH;
if (SD_CORPPH <> ' ');
CORPPHONE = SD_CORPPH;
leavesr;
endif;
SflMsgSnt = SndSflMsg('DEM0502': 'Corporate Phone');
NoErrors= *off;
RI_SD_CORPPH= *ON;
PC_SD_CORPPH = *ON;
endsr;
//=== AddRecd ================================================
// Insert a record into the file.
// Returns: NoErrors = *on if the add was successful.
begsr AddRecd;
NoErrors = *on;
in *LOCK Cust_Next;
Cust_Next += 1;
Out Cust_Next;
CUSTID= Cust_Next;
CHGTIME = %timestamp();
CHGUSER = CURR_USER;
exec sql
insert into CUSTMAST
values(:CUSTMAST)
;
// There is no good reason why insert should fail.
if (SQLSTT <> SQLSUCCESS);
SQLProblem('Insert into CUSTMAST ...');
endif;
endsr;
//=== UpdateRecd =============================================
// Updates the record with the screen data.
// The SQL WHERE checks the last time stamp and if different,
// doesn't update because someone else updated the record.
// (This isn't the only way to avoid pessimistic locking.)
// SQLERRD(3) contains the actual number of records updated
// when the update is successful.
begsr UpdateRecd;
NoErrors = *on;
exec sql
update CUSTMAST
SET NAME = :SD_NAME,
ADDR = :SD_ADDR,
CITY = :SD_CITY,
STATE = :SD_STATE,
ZIP = :SD_ZIP,
CORPPHONE = :SD_CORPPH,
ACCTMGR = :SD_ACCTMGR,
ACCTPHONE = :SD_ACCTPH,
ACTIVE = :SD_ACTIVE,
CHGTIME = CURRENT TIMESTAMP,
CHGUSER = :CURR_USER
where CUSTID = :CUSTID
-- and compare timestamp
and CHGTIME = :Orig_CHGTIME;
select;
when (SQLSTT = SQLNODATA); // Update Failed
SflMsgSnt = SndSflMsg('DEM1002'); // Record changed, review.
NoErrors = *off;
// Show the changed data
exsr ReadRecd;
exsr FillScreenFields;
when (SQLSTT =SQLROWLOCKED); // Row locked
SflMsgSnt = SndSflMsg('DEM1001' : SQLERRMC);
NoErrors = *off;
when (SQLSTT = SQLSUCCESS);
other;
SQLProblem('Update CUSTMAST');
endsl;
endsr;
//=== ClearScreenData ========================================
begsr ClearScreenData;
clear DETAILS;
endsr;
//=== ProtectAll =============================================
begsr ProtectAll;
Protect_SD_ALL = *on;
endsr;
//=== UnProtectAll ===========================================
begsr UnProtectAll;
Protect_SD_ALL = *off;
endsr;
//=== ScreenIO ===============================================
// Writes and Reads the screen
begsr ScreenIO;
write SH_HDR;
write SFT_FKEY;
// Show any messages in the error subfile.
if (SflMsgSnt = *on);
write MSGCTL;
endif;
exfmt Details;
// Clear most display file indicators
clear dfIndClr;
// Clear any messages in the error subfile.
if (SflMsgSnt = *on);
SflMsgSnt = ClrMsgPgmQ(MainProc);
write MSGCTL;
endif;
endsr;
//=== BldFKeyText ============================================
// Build the Function key text for the bottom of the screen.
begsr BldFkeyText;
SFT_KEYS=' ';
SFT_KEYS = catB(SFT_KEYS : F4TEXT);
SFT_KEYS = catB(SFT_KEYS : F5TEXT);
SFT_KEYS = catB(SFT_KEYS : F12TEXT);
endsr;
//=== CloseDownPgm ===========================================
// Things to do before we issue a return to the caller
begsr CloseDownPgm;
// Closing the display file may cause any subfile display in
// the caller to blank out.
endsr;
//=== Init ===================================================
// Every time initialization logic
begsr Init;
//--- Analyse parameters ---
if (%parms() = 0); // Close down
if (%open(MTNCUSTD));
close MTNCUSTD;
endif;
*inlr = *on;
return;
endif;
select;
when ( %parms() = 1);
Function = DISPLAYING;
when ( %parms() >= 2);
select;
when ( pMaintain = ADDING);
Function = ADDING;
SH_FUNCT = CenterStr(H2TextA);
when (pMaintain = EDITING);
Function = EDITING;
SH_FUNCT = CenterStr(H2TextE);
other;
Function = DISPLAYING;
SH_FUNCT = CenterStr(H2TextD);
endsl;
other;
// Should never happen
endsl;
//--- Miscellaneous setup ---
MainProc = %proc();
MSGPGMQ = MainProc;
SH_PGM = PgmName;
clear CUSTMAST;
clear dfIndDS;
exsr BldFkeyText;
//--- Open display file ---
if (not %open(MTNCUSTD));
open MTNCUSTD;
endif;
endsr;
end-proc;
//============================================================
// S u b P r o c e d u r e s
//============================================================
//=== CatB ===================================================
// Concatenates a string to another string with a blank between.
// If the target string is all blank to start with it will not
// end up with a leading blank.
dcl-proc catB;
dcl-pi catB varchar(79);
ToStr varchar(79) value;
AddStr varchar(79) value;
end-pi;
if (ToStr=' ');
return AddStr;
else;
return %trimr(ToStr) + ' ' + AddStr;
endif;
end-proc;
//=== SQLProblem ===============================================
// For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by
// sending an *ESCAPE message of the supplied debugging text.
dcl-proc SQLProblem;
dcl-pi SQLProblem;
piSQLDebug varchar(1024) value;
end-pi;
//--- Local Variables ------------------------------------------
dcl-s wkSQLDebug varchar(1024);
wkSQLDebug = 'SQLSTT ' + SQLSTT
+ ' << Unexpected SQL Return Code: '
+ piSQLDebug;
dump(a);
SndEscMsg(wkSQLDebug);
return;
end-proc;
//--------------------------------------------------------------
// Procedure name: SndSflMsg
// Purpose: Send a message to the Error Subfile
// Returns: *ON
// Parameter: ErrMsgId => Msg Id to Send
// Parameter: ErrMsgData => Optional Error Message Data
// Parameter: ErrMsgFile => Optional Error Message File
// Defaults to CUSTMSGF
//--------------------------------------------------------------
dcl-proc SndSflMsg;
dcl-pi SndSflMsg ind;
ErrMsgId char(7) const;
ErrMsgData char(512) const options(*nopass:*varsize);
ErrMsgFile char(10) const options(*nopass);
end-pi;
// Local fields
dcl-s retField ind;
dcl-s wkMsgId char(7);
dcl-s wkMsgFile char(10);
dcl-s wkMsgData varchar(512);
if (%parms >2);
wkMsgFile = ErrMsgFile;
else;
wkMsgFile = 'CUSTMSGF';
ENDIF;
if (%parms > 1);
wkMsgData = ErrMsgData;
else;
wkMsgData = ' ';
ENDIF;
wkMsgId = ErrMsgId;
SNDMSGPGMQ(MainProc:
wkMsgId:
wkMsgFile:
wkMsgData);
retField = *on;
RETURN retField;
end-proc;
USPS_Address/Readme.md
+34
View File
@@ -0,0 +1,34 @@
# USPS_Address - QSYS2_HTTP_GET calling the US Post Office webtools API AddressValidateRequest
USADRVAL is a service program in RPG Free which uses the QSYS2.HTTP_GET SQL function to call the USPS AddressValidateRequest API. The API returns a validated and standarized address (or an error) in an XML document, which is then parsed with the SQL XMLPARSE function and returned to the caller.
To use the USADRVAL you need to obtain a User Id from the US Post Office. [Follow link here](https://www.usps.com/business/web-tools-apis/general-api-developer-guide.htm#_Toc24631952) to register for a free User Id,
Included is a demo interactive program which is a rewritten version of MNTCUSTR in the [5250_Subfile](https://github.com/SJLennon/IBM-i-RPG-Free-CLP-Code/tree/master/5250_Subfile) directory.
## CRTBNDDIR.CLLE
Simple program to create the ADRVAL binding directory.
### MTNCUSTR/MTNCUSTD
Demo program and display file to maintain a customer master. To use the program you must compile the objects in the [5250_Subfile](https://github.com/SJLennon/IBM-i-RPG-Free-CLP-Code/tree/master/5250_Subfile) directory, then compile these two objects.
This program uses a single address line, which is passed as ADDRESS2 to the API. If you decide to use an additional address line, pass it in ADDRESS1.
(This program needs some additional coding to allow you to ignore the USPS standardized address.)
### USADRVAL_T
A program to exercise USADRVAL with a some addresses, writing the input and output side by side to QSYSPRT.
### USADRVAL
The service program.
Input address and output address are passed in the USADRVALDS data structure, which is found in [Copy_Mbrs](https://github.com/SJLennon/IBM-i-RPG-Free-CLP-Code/commit/c875b751e3ea6055ca295f35caef498b9067f7bb)
A call looks like this:
``returned address = USAdrVal(input address);``
If ADDRESS2 is non blank, they you have a valid address. Otherwise find a description of the problem in the DESCRIPTION field.
USPS_Address/USADRVAL.SQLRPGLE
+128
View File
@@ -0,0 +1,128 @@
**free
//==============================================================
//=== USADRVAL: Service program to validate and standardize
//=== a USA address.
//=== Calls the USPS webtools API AddressValidateRequest.
//====================================================================
// See US Postal Service documentation:
// www.usps.com/business/web-tools-apis/address-information-api.htm#_Toc39492052
// www.usps.com/business/web-tools-apis/general-api-developer-guide.htm
//====================================================================
// CRTRPGMOD MODULE(USADRVAL)
// CRTSRVPGM SRVPGM(USADRVAL) EXPORT(*ALL)
// CRTBNDDIR BNDDIR(ADRVAL_BND) TEXT('Address Validation Binding Dir')
// ADDBNDDIRE BNDDIR(ADRVAL_BND) OBJ((USADRVAL *SRVPGM *DEFER))
// CRTDTAARA DTAARA(USPS_ID) TYPE(*CHAR) LEN(20) VALUE(your user id)
//====================================================================
// Input address information is passed in a data structure.
// The standardized address is returned, also in a data structure.
// For ease of use, the same data structure layout is used for
// input and output, but it doesn't have to be the same memory
// in the caller. Use copy member USAdrValDS.
//====================================================================
ctl-opt
nomain
bnddir('SQL_BND')
option(*nodebugio: *srcstmt)
;
//=== Prototypes =====================================================
/copy copy_mbrs,Srv_SQL_P
//=== Parameter Data Structure Template ==============================
/copy copy_mbrs,USAdrValDS
// === Data area containing your USPS supplied User id. ==============
// (The USPS supplied USER ID length is not clear, so I made it
// longer than the 12-char one supplied to me..)
dcl-ds USPS_ID dtaara len(20) qualified;
end-ds;
//=== USAdrVal =======================================================
dcl-proc USAdrVal export;
dcl-pi USAdrVal likeds(USAdrValDS);
pi likeds (USAdrValDS);
end-pi;
dcl-c SQLSUCCESS '00000';
dcl-c SQLNODATA '02000';
// XML returned from the USPS API
dcl-s retXML char(2048) ccsid(*UTF8);
// Returned outparm data structure
dcl-ds po likeds(USAdrValDS);
dcl-s ID varchar(20);
// Get USPS UserID.
in USPS_ID;
ID = %trim(USPS_ID);
clear po;
// Call USPS Address Validate API. It returns an XML document.
exec sql
values QSYS2.HTTP_GET(
'http://production.shippingapis.com/ShippingAPI.dll'
concat '?API=Verify&XML=' concat
url_encode(
'<AddressValidateRequest ' concat
'USERID="' concat :ID concat '">' concat
'<Revision>1</Revision>' concat
'<Address ID="0">' concat
'<Address1>' concat :pi.Address1 concat '</Address1>' concat
'<Address2>' concat :pi.Address2 concat '</Address2>' concat
'<City>' concat :pi.City concat '</City>' concat
'<State>' concat :pi.State concat '</State>' concat
'<Zip5>' concat :pi.Zip5 concat '</Zip5>' concat
'<Zip4>' concat :pi.Zip4 concat '</Zip4>' concat
'</Address>' concat
'</AddressValidateRequest>'
)
) into :retXML;
if (SQLSTATE <> SQLSUCCESS);
SQLProblem('USPS API Call');
endif;
// Parse the XML document into program variables. Even if the API
// returns an error the SQL should not fail since defaults are set
exec sql
select x.* into :po.Address1, :po.Address2, :po.City,
:po.State, :po.Zip5, :po.Zip4
from xmltable
('AddressValidateResponse/Address'
passing xmlparse(document :retXML)
columns
Address1 char(30) path 'Address1' default ' ',
Address2 char(30) path 'Address2' default ' ',
City Char(30) path 'City' default ' ',
State char(2) path 'State' default ' ',
zip5 char(5) path 'Zip5' default ' ',
Zip4 char(4) path 'Zip4' default ' '
) as x;
if (SQLSTATE <> SQLSUCCESS);
SQLProblem('XMLPARSE of Addr');
endif;
// If a city was returned, assume it worked.
if (po.City <> ' ');
return po;
endif;
// If no city, then parse the error XML
exec SQL
select x.* into :po.Number, :po.Source, :po.Description
from xmltable
('AddressValidateResponse/Address/Error'
passing xmlparse(document :retXML)
columns
Number integer path 'Number',
Source char(30) path 'Source',
Description varChar(512) path 'Description'
) as x;
if (SQLSTATE <> SQLSUCCESS);
SQLProblem('XMLPARSE of Error');
endif;
return po;
end-proc USAdrVal;
USPS_Address/USADRVAL_T.RPGLE
+174
View File
@@ -0,0 +1,174 @@
**free
ctl-opt debug option(*nodebugio: *srcstmt)
dftactgrp(*no) actgrp(*caller)
bnddir('UTIL_BND':'SQL_BND':'ADRVAL_BND')
main(Main);
//====================================================================
// Program to exercise USADRVAL.
// Results are printed to QSYSPPRT.
//====================================================================
/copy copy_mbrs,USAdrValDS
/copy copy_mbrs,Srv_Msg_P
/copy copy_mbrs,USAdrVal_p
dcl-f qsysprt printer(132) usropn;
dcl-proc Main;
dcl-ds pi likeds(USAdrValDS);
dcl-ds po likeds(USAdrValDS);
*inlr = *on;
open qsysprt;
pi.Address1 = 'Suite 2';
pi.Address2 = '8 Wildwood Drive';
pi.City = 'Old Lyme';
pi.State = 'CT';
pi.Zip5='';
pi.Zip4 ='';
po = USAdrVal(pi);
DspAdr(pi:po);
pi.Address1 = ' ';
po = USAdrVal(pi);
DspAdr(pi:po);
pi.Address2 = 'Suite 2 ' + pi.Address2;
po = USAdrVal(pi);
DspAdr(pi:po);
pi.Address2 = 'Wildwood Drive';
po = USAdrVal(pi);
DspAdr(pi:po);
pi.Address2 = '8 Wildwood Drive, Suite 2';
pi.City = ' ';
pi.Zip5 = '06371';
po = USAdrVal(pi);
DspAdr(pi:po);
pi.Address1 = '';
pi.Address2 = '300 west green street';
pi.City = 'pasadena';
pi.State = 'ca';
pi.Zip5='';
pi.Zip4 ='';
po = USAdrVal(pi);
DspAdr(pi:po);
pi.Address2 = '6802 rio grande blvd nw ';
pi.City = 'los ranchos de albuquerque';
pi.State = 'nm';
pi.Zip5='';
pi.Zip4 ='';
po = USAdrVal(pi);
DspAdr(pi:po);
pi.Address1 = 'Apt 22 ';
pi.Address2 = '13 SENDERO';
pi.City = 'Rancho Santa Margarita';
pi.State = 'ca';
pi.Zip5='';
pi.Zip4 ='';
po = USAdrVal(pi);
DspAdr(pi:po);
close qsysprt;
return;
end-proc Main;
//=== Routine to print input and outpur side by side =================
dcl-proc DspAdr;
dcl-pi DspAdr;
pi likeds(USAdrValDS);
po likeds(USAdrValDS);
end-pi;
dcl-c WLOC 1;
dcl-c ILOC 15;
dcl-c OLOC 46;
dcl-s tNum int(10) inz(1) static;
dcl-s l char(132);
%subst(l:ILOC) = 'INPUT';
%subst(l:OLOC) = 'OUTPUT';
writeln(l);
%subst(l:WLOC:11) = 'Address1';
%subst(l:ILOC) = pi.address1;
%subst(l:OLOC) = po.address1;
writeln(l);
%subst(l:WLOC:11) = 'Address2';
%subst(l:ILOC) = pi.address2;
%subst(l:OLOC) = po.address2;
writeln(l);
%subst(l:WLOC:11) = 'City';
%subst(l:ILOC) = pi.City;
%subst(l:OLOC) = po.City;
writeln(l);
%subst(l:WLOC:11) = 'State';
%subst(l:ILOC) = pi.State;
%subst(l:OLOC) = po.State;
writeln(l);
%subst(l:WLOC:11) = 'Zip5';
%subst(l:ILOC) = pi.Zip5;
%subst(l:OLOC) = po.ZIP5;
writeln(l);
%subst(l:WLOC:11) = 'Zip4';
%subst(l:ILOC) = pi.Zip4;
%subst(l:OLOC) = po.Zip4;
writeln(l);
if (po.Description <> ' ');
%subst(l:WLOC:11) = 'Number';
%subst(l:OLOC) = %char(po.Number);
writeln(l);
%subst(l:WLOC:11) = 'Source';
%subst(l:OLOC) = po.Source;
writeln(l);
%subst(l:WLOC:11) = 'Description';
%subst(l:OLOC) = po.Description;
writeln(l);
endif;
writeln('------------------------------------------------------------');
tNum += 1;
return;
end-proc DspAdr;
//=== WriteLn: Courtesy of Ted Hold and ITJungle.com =================
// https://www.itjungle.com/2021/10/25/guru-quick-and-handy-rpg-output-take-2/
dcl-proc writeln;
dcl-pi *n;
inString varchar(132) const;
inPosition uns(3) const options(*nopass);
end-pi;
dcl-ds prtLineDS qualified;
line char(132);
end-ds;
dcl-ds prtLine likeds(prtLineDS);
dcl-s Posn uns(3);
if (%parms() >= %ParmNum(inPosition));
Posn = inPosition;
else;
Posn = 1;
endif;
%subst(prtLine.line: Posn) = inString;
write qsysprt prtLine;
end-proc writeln;