Inbound Exit Point using Short Parm List to Check Pricing in JDE Table:F4104

EXTOL/RPGLE - 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<[email protected] AND @OUTDAT>[email protected]
     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

By: on