SeanHoppe.com › EXTOL EDI Examples › EXTOL External Call RPG Programs › EXTOL RPG Program: EXCTDFT
H/TITLE Return value from code table in qual. if not found return input
H Y
Z* CRTRPGPGM
Z* OPTION(*NOXREF) GENOPT(*OPTIMIZE)
*
W* Warning: This program does not set on the LR indicator
*
H* SYNOPSIS :
H* Example of external call code translation using the "short"
H* parameter list. This program uses the EXCCDxxx files; this
H* program uses the code in local form parameter (P5CDLC) and searches
H* for a corresponding entry in the code table named in the qualifier
H* parameter (P4CDQD. If no entry is found, the code in local form is
H* placed into the code in standard form parameter (P3CDST).
*
H* NOTE: This program is a modification of example program EXCDP11 and
H* is only intended for use with OUTWARD translation;
*
*
H* Generated by : Synon/2E Version: 9062
H* Function type : Execute external function
*
H* Company : ExtoL, Inc.
H* System : ExtoL EDI Integrator
H* User name : EXTOLOWN
H* (C) Copyright : ExtoL, Inc. 1988,1994
*
*================================================================
M* Maintenance : Manually modified Synon program for demonstration.
*================================================================
FEXXCDRL0IF E K DISK
* RTV : Code table detail Retrieval index
*
FEXXCDQL0IF E K DISK
* RSQ : Code table detail Resequence by local code
*
* Renamed input format fields
*
*
I@XCDQL0
* Code table detail Resequence by local code
I CDTABL WATABL
I CDCDST WACDST
I CDCDSN WACDSN
I CDCDLC WACDLC
*
/EJECT
* Data structures:
IPGMDS ESDSEXPGSDS
* Program data structure
IJBDTTM DS
* Job date/time
I 1 60##JDT
I 1 20##JYY
I 3 40##JMM
I 5 60##JDD
I 7 120##JTM
I 7 80##JHH
I 9 100##JNN
I 11 120##JSS
/EJECT
* Parameter declarations
IP1PARM DS
* I : Code trans directions
I 1 1 P1CDTT
IP2PARM DS
* I : Code table reference
I 1 10 P2TABL
IP3PARM DS
* B : Code in standard form
I 1 80 P3CDST
IP4PARM DS
* B : Code qualifier data
I 1 80 P4CDQD
IP5PARM DS
* B : Code in local form
I 1 80 P5CDLC
/EJECT
*****************************************************************
* Entry parameters
C *ENTRY PLIST
C PARM P0RTN 7
C P1CDTT PARM WP0001 1 Code trans dire
C P2TABL PARM WP0002 10 Code table refe
C P3CDST PARM P3CDST WP0003 80 Code in standar
C P4CDQD PARM P4CDQD WP0004 80 Code qualifier
C P5CDLC PARM P5CDLC WP0005 80 Code in local f
*****************************************************************
* Initialise
C EXSR ZZINIT
*
* External code process P1
C MOVEL*BLANK W0RTN *Return code
* CASE: PAR.Code trans directions is Inward translation
C P1CDTT IFEQ 'I' *IF
* Rtv code table dtl by std - Code table detail *#
C EXSR SARVGN
C ELSE
* CASE: PAR.Code trans directions is Outward translation
C P1CDTT IFEQ 'O' *IF
* Rtv code table dtl by loc - Code table detail *#
C EXSR SBRVGN
C END *FI
C END *FI
* A "Return code" of non-blank will be logged as a translation error:
C MOVELW0RTN P0RTN *Return code
C EXSR ZYEXPG
*----------------------------------------------------------------
* Exit program
C AAEXIT TAG
C MOVEL*BLANK P0RTN
C EXSR ZYEXPG
*================================================================
/EJECT
CSR SARVGN BEGSR
*================================================================
* Incoming ("I") - Standard -> Application translation.
*
* Note: This subroutine should be replaced by whatever is
* actually required. For demonstration purposes, this
* does the same thing as a direct code lookup (method "D")
* into the standard ExtoL code table detail files.
*
* If the required function is a lookup into some other
* file, replace the key lists, field names, and format
* names accordingly.
*
* Returning with field W0RTN non-blank will cause the
* translator to send a "Code table entry not found"
* message and flag the EDI message as having translated
* with errors.
*
*================================================================
* Rtv code table dtl by std - Code table detail *#
*================================================================
C MOVEL*BLANK W0RTN 7
* Declare restrictor key work fields
C *LIKE DEFN CDTABL WQSA01 Code table refe
C *LIKE DEFN CDCDST WQSA02 Code in standar
* Define keylist
C KRSSA KLIST
C KFLD WQSA01 Code table refe
C KFLD WQSA02 Code in standar
* Move fields to key list
C MOVELP2TABL WQSA01 Code table refe
C MOVELP3CDST WQSA02 Code in standar
C KRSSA SETLL@XCDRL0 *
C KRSSA READE@XCDRL0 90*
C *IN90 IFEQ '1'
* DBF record not found
C* MOVEL'UEX0009' W0RTN 7
C MOVELP3CDST P5CDLC
* USER: Processing if DBF record not found
* +++++ (Any additional processing on "not found" can be done here)
C GOTO SAEXIT
C END
*
C *IN90 DOWEQ'0'
* USER: Process DBF record
* If the record is found, pass back the return value and *QUIT loop:
* PAR = DB1 By name
C MOVELCDCDLC P5CDLC Code in local f
C GOTO SAEXIT *QUIT
C KRSSA READE@XCDRL0 90*
C END
* USER: Exit processing
* (This point is also a "not found" due to the "*QUIT" above)
C MOVEL'UEX0009' W0RTN *Return code
*================================================================
CSR SAEXIT ENDSR
/EJECT
CSR SBRVGN BEGSR
*================================================================
* Outgoing ("O") - Application -> Standard translation.
*
* Note: This subroutine should be replaced by whatever is
* actually required. For demonstration purposes, this
* does the same thing as a direct code lookup (method "D")
* into the standard ExtoL code table detail files.
*
* If the required function is a lookup into some other
* file, replace the key lists, field names, and format
* names accordingly.
*
* Returning with field W0RTN non-blank will cause the
* translator to send a "Code table entry not found"
* message and flag the EDI message as having translated
* with errors.
*
*================================================================
* Rtv code table dtl by loc - Code table detail *#
*================================================================
C MOVEL*BLANK W0RTN 7
* Declare restrictor key work fields
C *LIKE DEFN WATABL WQSB01 Code table refe
C *LIKE DEFN WACDLC WQSB02 Code in local f
* Define keylist
C KRSSB KLIST
C KFLD WQSB01 Code table refe
C KFLD WQSB02 Code in local f
* Move fields to key list
C MOVELP2TABL WQSB01 Code table refe
C MOVELP5CDLC WQSB02 Code in local f
C KRSSB SETLL@XCDQL0 *
C KRSSB READE@XCDQL0 90*
C *IN90 IFEQ '1'
* DBF record not found
* USER: Processing if DBF record not found
C MOVELP5CDLC P3CDST
C GOTO SBEXIT
C END
*
C *IN90 DOWEQ'0'
* USER: Process DBF record
* If the record is found, pass back the return value and *QUIT loop:
* PAR = DB1 By name
C MOVELWACDST P3CDST Code in standar
C GOTO SBEXIT *QUIT
C KRSSB READE@XCDQL0 90*
C END
* USER: Exit processing
* (This point is also a "not found" due to the "*QUIT" above)
C MOVEL'UEX0009' W0RTN *Return code
*================================================================
CSR SBEXIT ENDSR
/EJECT
CSR ZYEXPG BEGSR
*================================================================
* Exit program: Direct
*================================================================
* Exit program
C RETRN
*
*================================================================
CSR ZYEXIT ENDSR
/EJECT
CSR ZZINIT BEGSR
*================================================================
* Initialisation
*================================================================
C MOVE *BLANK P0RTN
C MOVE *BLANK W0RTN 7
C MOVEL*BLANK W0RSL 1
C MOVEL*BLANK W0RSF 1
* Initialise indicators for re-entry
C MOVE '0' *IN
* Setup job date/time
*
C Z-ADDUDATE ##JDT
C TIME ##JTM
* Update screen time
C TIME ##TME 60
*================================================================
CSR ZZEXIT ENDSR