Create JDE customer item records in F4104

EXTOL RPGLE - 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

By: on