SeanHoppe.com › Cleo CodeSamples › Create JDE customer item records in F4104
h Debug(*Yes) Datedit(*Ymd)
h/Title INSERT F4104 RECORD IF NOT ALREADY THERE.
**************************************************************************
*
* Warning: This program does not set on LR.
*
**************************************************************************
* SYNOPSIS :
* External call program which uses the "long
* parameter list" program will populate F4104 with customer item number
* if value does not exist.
*
**************************************************************************
* Maintenance : Manually modified Synon program.
**************************************************************************
* BMR Date Description
* ---- ---------- ----------------------------------------------------------------
**************************************************************************
FF4104_14 IF A E K DISK RENAME(F4104:I4104)
FF4101_2 IF E K DISK RENAME(F4101:I4101)
D*
* Data structures:
* Parameter declarations
<--- LONG PARM LIST HERE --->
d Wp0053 DS 9900
d W0rtn s Like(P0rtn)
d @XRT S 2A INZ('C') Xref type code
d @LITM S 25A Long item number
d @CITM S 25A Long item number
d @TSTL S 1 0 Location test val
d @CHK S 1 0 Check tem number
d @DATE S D INZ(*SYS) DATFMT(*JUL)
d @DATEJ S 6S 0
d @TIME S 6S 0
**************************************************************************
* Mainline Program.
**************************************************************************
*
**************************************************************************
* Srdefn - Definitions
**************************************************************************
c* Srdefn Begsr
*
* Entry parameters
c *Entry Plist
<--- LONG PARM LIST HERE --->
*
* Key to F4104_14 - JDE Item cross-reference
c KeyF4104 Klist
c Kfld @LITM
c Kfld @XRT
c Kfld @AN8
*
* Key to F4101_2 - JDE Item master
c KeyF4101 Klist
c Kfld @CITM
*
c* Endefn Endsr
*
C EXSR Srinit
*
C P1CDTT IFEQ 'I'
*
C P2CDQD IFEQ 'CLEAR'
C MOVE *BLANKS @AN8 8 0
C MOVE *BLANKS @SHAN 8 0
C MOVE *BLANKS @LITM
C MOVE *ZEROS @CHK
C MOVE *ZEROS @TSTI 1 0
C MOVE *BLANKS P0RTN
C END
*
*
* Receive ship-to number (SHAN) and parent number (AN8)
* 1st: Receive ship-to. If @SHAN = *ZEROS then seton 99. *in99 will be tested
* to move @SHAN to @AN8 and if trans error should occur.
*
* 2nd: Receive parent number and run test to see if parent number is populated.
* If parent number is NOT populated, then move @SHAN to @AN8
*
C P2CDQD IFEQ 'SHAN'
C MOVEL P2CDST @SHAN 8 0
C IF @SHAN= *ZEROS
C MOVEL 1 @TSTL
C END
C IF @SHAN<> *ZEROS
C MOVEL 0 @TSTL
C END
C END
*
C P2CDQD IFEQ 'AN8'
C MOVEL P2CDST @AN8 8 0
C @AN8 IFEQ *ZEROS
C @TSTL ANDNE 1
C MOVEL @SHAN @AN8
C END
C END
*
C P2CDQD IFEQ 'CHK'
C @CHK IFEQ 1
C MOVEL '1' P2CDLC
C END
C END
*
* Capture customer item number
C P2CDQD IFEQ 'CITEM'
C MOVE *BLANKS @CITM
C MOVEL P2CDST @CITM
C END
C*
*
* Receive item number
* 1. Mod1s1: Test for item in F4104
* 2. If item number does not exist in F4104, check F4101
* 3. If item number does not exist in F4101, ERROR
C P2CDQD IFEQ 'ITEM'
C Eval @CHK = 0
C MOVEL P2CDST @LITM
C EXSR Mod1S1
C END
C*
* Test for @SHAN value. If value does not exist:
* 1. Return USR0031 in P0RTN -> cause trans error
* 2. Return '1' to calling pgm. Formula will write out error to MSGQ
C P2CDQD IFEQ 'TSTL'
C @TSTL IFEQ 1
C Movel 'USR0031' P0RTN
C MOVEL *BLANKS P2CDLC
C ELSE
C MOVEL *BLANK P0RTN
C MOVEL *BLANKS P2CDLC
C END
C END
*
* Test for @LITM value. If value does not exist:
* 1. Return USR0030 in P0RTN -> cause trans error
* 2. Return '1' to calling pgm. Formula will write out error to MSGQ
C P2CDQD IFEQ 'TSTI'
C @TSTI IFEQ 1
C Movel 'USR0030' P0RTN
C MOVEL *BLANKS P2CDLC
C ELSE
C MOVEL *BLANKS P0RTN
C MOVEL *BLANKS P2CDLC
C END
C END
*
C ELSE
* CASE: PAR.Code trans directions is Outward translation
C P1CDTT IFEQ 'O'
* Use Local if non-blank; else use qualifier:
C* P5CDLC IFNE *BLANKS
C* MOVEL P2CDLC OUT80
C* ELSE
C* MOVEL P2CDQD OUT80
C* END
C END
C END
*
* Exit program
C RETURN
**************************************************************************
* Srinit - Initialization.
**************************************************************************
c Srinit Begsr
*
c Eval P0Rtn = *Blanks
c Eval W0Rtn = *Blanks
*
* Initialise indicators for re-entry
c Move '0' *In
c Eninit Endsr
**************************************************************************
* Mod1s1 - Chain out to F4104 to see if cross reference exists
**************************************************************************
c Mod1s1 Begsr
*
C @AN8 IFEQ *ZEROS
C @TSTL ANDNE 1
C MOVEL @SHAN @AN8
C END
c dump
c KeyF4104 Chain F4104_14 98
c If Not *In98
C Return
C Else
C IF @AN8 <> *ZEROS
C EXSR Mod1s2
C Else
C Return
C Endif
C Endif
*
c Endsr
**************************************************************************
* Mod1s2 - Chain out to F4101 to see if item exists in item master
**************************************************************************
c Mod1s2 Begsr
*
c KeyF4101 Chain F4101_2 97
c If *In97
C MOVEL 1 @TSTI 1 0
C Return
C Else
*
C EVAL @DATEJ= %DEC(%DATE:*JUL)
C EVAL @DATEJ = @DATEJ+100000
*
C EVAL IVAN8 = @AN8
C EVAL IVXRT = 'C'
C EVAL IVITM = IMITM
C EVAL IVEXDJ= 120365
C EVAL IVEFTJ= @DATEJ
C EVAL IVCITM= @LITM
C EVAL IVDSC1= IMDSC1
C EVAL IVDSC2= IMDSC2
C EVAL IVALN = IMALN
C EVAL IVLITM= @CITM
C EVAL IVAITM= IMAITM
C EVAL IVUSER= 'EXTOLOWN'
C EVAL IVPID = 'EXT045'
C EVAL IVJOBN= 'EXT045'
C EVAL IVUPMJ= @DATEJ
C EVAL IVTDAY= 1200
C EXCEPT UPF4104
C Eval @CHK = 1
C Endif
*
c Endsr
*
oI4104 EADD UpF4104
o *ALL
