SeanHoppe.com › Cleo CodeSamples › Inbound Exit Point using Short Parm List to Check Pricing in JDE Table:F4104
For additional EXTOL EDI Integrator RPGLE Examples: Sean Hoppe Consulting Group Coding Samples
H/TITLE Determine if pricing exists for uom/item
H DATEDIT(*YMD) OPTION(*DEBUGIO) DEBUG(*YES)
*
* MAPPING SETUP:
* FS: IMSRP2 FD: SZMCU Q:ITEM
* FS: IMITM FD: SZMCU Q:ITEM2
* FS: WWAN8 FD: SZURRF Q:TPID
*
* ELEMENT ATTACHMENT:
* SYURRF ST01 Q: CLEAR
* SYMCU SE01 Q: RETURN
*
*
FF4104_14 if e k Disk RENAME(F4104:F4104)
FF4101_1 if e k Disk RENAME(F4101:F4101)
FF03012_3 if e k Disk RENAME(F03012:F03012)
FF4094LC if e k Disk RENAME(F4094:F4094)
FF4106LD if e k Disk RENAME(F4106:F4106)
FF41002_4 if e k Disk RENAME(F41002:F41002)
* Parameter declarations
<--- SHORT PARM LIST HERE --->
*
*
D @LITM s Like(imlitm)
D @ITM s Like(imitm)
D @ITEM2 s 8a
D @UOM s 2
D @UOM1 s 2
D @UOM2 s 2
D @BP53 s 1s 0
D @BP54 s 1s 0
D @MCU s 3A
D @TPIDA s 8A
D*@TPID s 8s 0 Inz(241985)
D @TPID s 8s 0
D @AN8 s 8S 0
D @PODT8 s 8S 0
D @POS s 2S 0
D*@INDAT s 15S 5
D*@OUTDAT s 15S 5
D @EFTJ s Like(BPEFTJ)
D @EXDJ s Like(BPEXDJ)
D @XRT s 2 Inz('C')
D @TSTIND s 1S 0 Inz(0)
D @TSTERR s 1S 0 Inz(0)
/EJECT
*****************************************************************
* Entry parameters
C *ENTRY PLIST
<--- PARAMETER LIST HERE --->
*****************************************************************
*
* CASE: PAR.Code trans directions is Inward translation
C P1CDTT IFEQ 'I'
* Use Standard if non-blank; else use qualifier:
C* P4CDQD IFEQ 'TPID'
C* MOVEL *BLANKS @TPIDA
C* Z-ADD *ZEROS @TPID
C* MOVEL P3CDST @TPID
C* MOVEL @TPID @TPIDA
C* MOVEL P3CDST @TPIDA
C* MOVE @TPIDA @TPID
*
C P4CDQD IFEQ 'XXXXV'
C CLEAR @TPID
C MOVE 00241985 @TPID
C END
*
C P4CDQD IFEQ 'XXXXA'
C CLEAR @TPID
C MOVE 00336787 @TPID
C END
*
C P4CDQD IFEQ 'CLEAR'
C EXSR SRclear
C END
*
C P4CDQD IFEQ 'CLRDTL'
C EXSR SRclrdtl
C END
*
C P4CDQD IFEQ 'ITEM'
C MOVEL P3CDST @LITM
C EXSR SRitem
C END
*
* RETURN is called for each detail line. Formula: MSGQITMPRC
* calls routine to test for error. If error exists then formula
* remits message into MSGQ.
*
C P4CDQD IFEQ 'RETURN'
*
C IF %SUBST(IVLITM:1:4) ='3690' SCAN FOR ITEM CODES
C OR %SUBST(IVLITM:1:4) ='3694' WITH 3690 OR 3690
C MOVE 0 @TSTIND IN THE 4TH POSITION
C ENDIF
C*
C IF %SCAN('16 ':IVLITM) >0 IF LAST 2 CHARS = 16
C MOVE 0 @TSTIND THE @TSTIND = 0
C ENDIF
C*
C IF IVLITM = '840' IF ITEM IS PALLET
C MOVE 0 @TSTIND THE @TSTIND = 0
C ENDIF
C*
C @TSTIND IFNE 0
C MOVE 1 @TSTERR
C END
C MOVEL @TSTIND P5CDLC
C END
*
* CHKERR is called at the end of map. If any detail lines error'd
* then PO wil error.
*
C P4CDQD IFEQ 'CHKERR'
C @TSTERR IFNE 0
C MOVEL 'USR0034' P0RTN
C END
C END
*
C P4CDQD IFEQ 'UOM'
C MOVEL P3CDST @UOM
C END
*
C P4CDQD IFEQ 'PODAT'
C Z-ADD *ZEROS @INDAT 15 5
C Z-ADD *ZEROS @OUTDAT 15 5
C MOVEL P3CDST @PODT8
C MOVEL @PODT8 @INDATT 13 5
C MOVE @INDATT @INDAT
C CALL 'CVTFJULYMD'
C PARM @INDAT
C PARM @OUTDAT
C END
*
*
C ELSE else not "I"
* CASE: PAR.Code trans directions is Outward translation
C P1CDTT IFEQ 'O'
* Use Local if non-blank; else use qualifier:
C END
C END
C RETURN
*
* A "Return code" of non-blank will be logged as a translation error:
C* MOVEL *BLANK P5CDLC *Return code
C*
**************************************************************************
* Initialize variables
**************************************************************************
C SRclear BEGSR
C*
C MOVEL *ZEROS @AN8
C MOVEL *BLANKS @LITM
C MOVEL *ZEROS @ITM
C MOVEL *BLANKS @UOM
C MOVEL *BLANKS @UOM1
C MOVEL *BLANKS @UOM2
C MOVEL *ZERO @TSTIND
C MOVEL *ZERO @TSTERR
C*
* Key to the Code Table File
C KeyF4104 KLIST
C KFLD @LITM
C KFLD @XRT
C KFLD @TPID
C
* Key to item master file
C KeyF4101 KLIST
C KFLD IVITM
C*
C KeyF03012 KLIST
C KFLD @TPID
C*
C KeyF4094 KLIST
C KFLD AICPGP
C KFLD IMPRGR
C KFLD IMSRP7
C*
C KeyF4106 KLIST
C KFLD KIICID
C KFLD @UOM1
C*
C KeyF41002 KLIST
C KFLD IMITM
C KFLD @UOM1
C
C ENclear ENDSR
C*
**************************************************************************
* Initialize variables for detail line
**************************************************************************
C SRclrdtl BEGSR
C*
C MOVEL *BLANKS @LITM
C MOVEL *ZEROS @ITM
C MOVEL *BLANKS @UOM
C MOVEL *BLANKS @UOM1
C MOVEL *BLANKS @UOM2
C MOVEL *ZERO @TSTIND
C MOVEL *ZEROS @EFTJ
C MOVEL *ZEROS @EXDJ
C*
C ENclrdtl ENDSR
C*
**************************************************************************
* Chain to following files: F4104_14 -> F4101_2 -> F03012_3 -> F4094LC -> F4106LC
**************************************************************************
C SRitem BEGSR
C*
C KeyF4104 CHAIN F4104 91
IF01 C *IN91 IFEQ *OFF
C*
C KeyF4101 CHAIN F4101 92
IF02 C *IN92 IFEQ *OFF
C*
C KeyF03012 CHAIN F03012 93
IF03 C *IN93 IFEQ *OFF
C*
C KeyF4094 CHAIN F4094 94
IF04 C *IN94 IFEQ *OFF
C*
C* Check to see if UOM and CID value exists in PF:F4106
C*
C MOVEL @UOM @UOM1
C EXSR SR4106
C
C*
C* If record is not found in F4106 then check PF:F41002.
C* If cross reference is found for UOM (UMUM -> UMRUM)
C* then check to see if UMCONV = 10000000. If UMCONV = 10000000
C* then call subroutine: SR4106 to see if entry exists in F4106
C* using UMRUM. If record exists then @TSTIND = 0
C*
IF05 C @TSTIND IFNE 0
C KeyF41002 SETLL F41002
C KeyF41002 READE F41002 96
C MOVE 6 @TSTIND
DO06 C *IN96 DOWEQ *OFF
IF10 C @TSTIND IFNE 0
C*
C IF UMCONV = 10000000
C MOVEL UMRUM @UOM1
C EXSR SR4106
C ENDIF
END10C ENDIF
C*
C KeyF41002 READE F41002 96
END06C ENDDO
C*
END05C ENDIF
ELS04C ELSE
C MOVE 4 @TSTIND
END04C ENDIF
ELS03C ELSE
C MOVE 3 @TSTIND
END03C ENDIF
ELS02C ELSE
C MOVE 2 @TSTIND
END02C ENDIF
ELS01C ELSE
C MOVE 1 @TSTIND
END01C ENDIF
C*
C ENitem ENDSR
C*
**************************************************************************
* Using CID and UOM, check to see if record entry exists in F4106.
* If entry does exist check PO's date versus effective and expiration
* date.
**************************************************************************
C*
C SR4106 BEGSR
C*
C KeyF4106 SETLL F4106
C KeyF4106 READE F4106 95
C MOVE 5 @TSTIND
DO06 C *IN95 DOWEQ *OFF
IF07 C @TSTIND IFNE 0
C*
C MOVE 9 @TSTIND
C MOVE BPEFTJ @EFTJ
C MOVE BPEXDJ @EXDJ
C
IF08 C IF @OUTDAT<=@EXDJ AND @OUTDAT>=@EFTJ
C EVAL @TSTIND = 0
END08C ENDIF
ELS07C ELSE
C LEAVESR
END07C ENDIF
C*
C KeyF4106 READE F4106 95
END05C ENDDO
C EN1406 ENDSR
* Exit program
