Read S2K Table to Determine 856 Line Status

EXTOL RPGLE - External Call / Short Parm List -- Read S2K Table to Determine 856 Line Status

 
     H/TITLE Program queries VCODETL at header and detail levels of x12 856 (ASN)
     H DATEDIT(*YMD)
     F* CRTRPGPGM
     F* OPTION(*NOXREF) GENOPT(*OPTIMIZE)
      *
     F* Warning: This program does not set on the LR indicator
      *
     H* SYNOPSIS :
     H*  Program queries VCODETL at header and detail levels of 855.
     H*  At header level,all VCODETL records are reviewed to see if
     H*  any lines were backordered or partially shipped.
     H*
     H*  At detail level,specific VCODETL is queried to determine if
     H*  detail record is backordered or partially shipped.
      *
      *  Program was created for outbound Amazon 856
      *
      * SHIPPED QUANTITY WILL USE FIELDS @QUAN, @QUAN2
      * BACK ORDERED QUANTITY WILL USE FIELDS @QUAN3, @QUAN4
      * TO RETURN PROPERLY FORMATTED SHIPPED QUANTITY WE USE @QUANA. THIS ALLOWS
      * US TO RETURN QUANTITY AS ALPHA INSTEAD OF NUMERIC.
      *
      * Inputs Order Level:
      *        OBCMP
      *        OBORD
      *        OBCUST
      * Inputs Detail Level:
      *        OBBOCD
      *        OBLINE
      *        OBUPC
      * Output Qualifiers: -- Placed in SN1 segment
      *        RTNAMT -- Return shipped quantity
      *                  This qualifier needs to be called before RTNSTS and RTNBCK
      *        RTNSTS -- Return item status code
      *        RTNBCK -- Return backordered amount (if applicable)
      *
     H* Company       : ABC Inc
     H* System        : ExtoL EDI Integrator
     H* User name     : S.Hoppe
     H* Date generated: 11/20/14
      *
      *================================================================
     F* Maintenance   :
      *================================================================
     FVCODET15  IF   E           K DISK    RENAME(CODETLR:VCODTL1)
     FVCODET9   IF   E           K DISK    RENAME(CODETLR:VCODTL9)
      *
      /EJECT
      * Data structures:
      * Program data structure
     D JBDTTM          DS
      * Job date/time
     D  ##JDT                  1      6  0
     D  ##JYY                  1      2  0
     D  ##JMM                  3      4  0
     D  ##JDD                  5      6  0
     D  ##JTM                  7     12  0
     D  ##JHH                  7      8  0
     D  ##JNN                  9     10  0
     D  ##JSS                 11     12  0
      /EJECT
      * Parameter declarations
     D P1PARM          DS
      * I :  Code trans directions
     D  P1CDTT                 1      1
     D P2PARM          DS
      * I :  Code table reference
     D  P2TABL                 1     10
     D P3PARM          DS
      * B :  Code in standard form
     D  P3CDST                 1     80
     D P4PARM          DS
      * B :  Code qualifier data
     D  P4CDQD                 1     80
     D P5PARM          DS
      * B :  Code in local form
     D  P5CDLC                 1     80
      * RSQ : Code table detail         Resequence by local code
      *
     D  @OBCMP                             LIKE(OBCMP)
     D  @OBORD                             LIKE(OBORD)
     D  @OBBOCD                            LIKE(OBBOCD)
     D  @OBLINE                            LIKE(OBLINE)
     D  @OBLINET                     20A
     D  @OBCUST                            LIKE(OBCUST)
     D  @OBUPC                             LIKE(OBUPC)
     D  @QUAN                              LIKE(OBQSHP)
     D  @QUAN3                             LIKE(OBQSHP)
      /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                   MOVEL     W0RTN         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
      *
      *================================================================
     CSR   SAEXIT        ENDSR
      /EJECT
     CSR   SBRVGN        BEGSR
      *================================================================
      *        Outgoing ("O") - Application -> Standard translation.
      *
      *================================================================
      * Rtv code table dtl by loc - Code table detail  * 
      *================================================================
     C                   MOVEL     *BLANK        W0RTN             7
      *
      * Move fields to key list
     C     P4CDQD        IFEQ      'OBCMP'
     C                   MOVE      *BLANKS       @OBCMP
     C                   MOVEL     P5CDLC        @OBCMP
     C                   ENDIF
      *
     C     P4CDQD        IFEQ      'OBORD'
     C                   MOVE      *BLANKS       @OBORD
     C                   MOVEL     P5CDLC        @OBORD
     C                   ENDIF
      *
     C     P4CDQD        IFEQ      'OBBOCD'
     C                   MOVE      *BLANKS       @OBBOCD
     C                   MOVEL     P5CDLC        @OBBOCD
     C                   ENDIF
      *
     C     P4CDQD        IFEQ      'OBLINE'
     C                   MOVE      *BLANKS       @OBLINET
     C                   MOVE      *ZEROS        @OBLINE
     C                   MOVEL     P5CDLC        @OBLINE
     C*                  MOVE      @OBLINET      @OBLINE
     C                   ENDIF
      *
     C     P4CDQD        IFEQ      'OBCUST'
     C                   MOVE      *BLANKS       @OBCUST
     C                   MOVEL     P5CDLC        @OBCUST
     C                   ENDIF
      *
     C     P4CDQD        IFEQ      'OBUPC'
     C                   MOVE      *BLANKS       @OBUPC
     C                   MOVEL     P5CDLC        @OBUPC
     C                   ENDIF
      *
      *
      * RETRIEVE SPECIFIC DETAIL LINE (FIELD:OBLINE) TO DETERMINE IF LINE IS BACKORDERED.
      * FOR 'RTNAMT' WE WILL DETERMINE ITEM STATUS BUT IT WILL NOT BE RETURNED IL 'RTNSTS'
      *
      * IF OBQBKO > 0 THEN MOVE '1'->FLAG2
      * IF OBQBKO > 0 AND OBQSHP > 0 THEN MOVE '2'->FLAG2
      * IF OBQBKO = 0 AND OBQSHP > 0 THEN MOVE '3'->FLAG2
      *
      * SHIPPED QUANTITY WILL USE VARS:@QUAN, @QUAN2
      * BACK ORDERED QUANTITY WILL USE VARS:@QUAN3, @QUAN4
      *
      * 'BP' = BackOrdered;Not Shipped -- FLAG2 = '1'
      * 'BP' = Partil Fill -- FLAG2 = '2'
      * 'AC' = Shipped -- FLAG2 = '3'
      *
     C     P4CDQD        IFEQ      'RTNAMT'
     C                   MOVE      *ZEROS        @QUAN
     C                   MOVE      *ZEROS        @QUAN3
     C                   MOVE      *BLANKS       FLAG2             1
     C                   MOVE      *BLANKS       @TEMP
     C                   MOVEL     P5CDLC        @TEMP            80
      *
     C                   MOVE      *OFF          *IN92
     C     KYVCODTL15    SETLL     VCODTL1
     C     KYVCODTL15    READE     VCODTL1                                92
     C     *IN92         DOWEQ     *OFF
     C*
     C*  CHECK FOR DETAIL LINE TO BE BACKORDERED
     C*
     C     OBQBKO        IFGT      0
     C                   MOVE      '1'           FLAG2
     C                   MOVE      OBQBKO        @QUAN3
     C                   ENDIF
     C*
     C*  CHECK FOR DETAIL LINE TO BE PARTIALLY FILLED
     C*
     C     OBQBKO        IFGT      0
     C     OBQSHP        ANDGT     0
     C                   MOVE      '2'           FLAG2
     C                   MOVE      OBQSHP        @QUAN
     C                   ENDIF
     C*
     C*  CHECK FOR DETAIL LINE TO BE FULL SHIPPED
     C*
     C     OBQBKO        IFEQ      0
     C     OBQSHP        ANDGT     0
     C                   MOVE      '3'           FLAG2
     C                   MOVE      OBQSHP        @QUAN
     C                   ENDIF
     C*
     C     KYVCODTL15    READE     VCODTL1                                92
     C                   ENDDO
     C*
     C* IF ITEM IS CANCELED AND REPLACED, VCODETL RECORD WILL NOT BE LOCATED CORRRECTLY.
     C* IN QUERY BELOW WE USE UPC CODE TO LOCATE CORRECT VCODETL RECORD TO DETERMINE
     C* IF ITEM IS BACKORDERED/CANCELED/PARTIAL SHIPPED
     C*
     C* THIS SECTION OF CODE WILL BE USED IF VARIABLE: FLAG2 IS *BLANKS
     C     FLAG2         IFEQ      *BLANKS
     C*
     C                   MOVE      *OFF          *IN91
     C     KYVCODTL9     SETLL     VCODTL9
     C     KYVCODTL9     READE     VCODTL9                                91
     C     *IN91         DOWEQ     *OFF
     C     @OBUPC        IFEQ      OBUPC
     C*
     C*  CHECK FOR DETAIL LINE TO BE BACKORDERED
     C*
     C     OBQBKO        IFGT      0
     C                   MOVE      '1'           FLAG2
     C                   MOVE      OBQBKO        @QUAN3
     C                   ENDIF
     C*
     C*  CHECK FOR DETAIL LINE TO BE PARTIALLY FILLED
     C*
     C     OBQBKO        IFGT      0
     C     OBQSHP        ANDGT     0
     C                   MOVE      '2'           FLAG2
     C                   MOVE      OBQSHP        @QUAN
     C                   ENDIF
     C*
     C*  CHECK FOR DETAIL LINE TO BE FULL SHIPPED
     C*
     C     OBQBKO        IFEQ      0
     C     OBQSHP        ANDGT     0
     C                   MOVE      '3'           FLAG2
     C                   MOVE      OBQSHP        @QUAN
     C                   ENDIF
     C*
     C                   ENDIF
     C     KYVCODTL9     READE     VCODTL9                                91
     C                   ENDDO
END  C*
     C                   ENDIF
     C*
      * RETURN @QUAN VALUE (SHIPPED QUANTITY)
     C     @QUAN         DIV       100           @QUAN2            9 2
     C     @QUAN         IFEQ      0
     C                   MOVEL     '0'           P3CDST
     C                   ELSE
     C                   MOVE      @QUAN2        @QUANA            9
     C                   EVAL      @QUANA=%subst(@QUANA:%check('0':@QUANA))
     C                   MOVEL     @QUANA        P3CDST
     C                   ENDIF
     C                   ENDIF
     C*
     C     P4CDQD        IFEQ      'RTNSTS'
      * 'BP' = BackOrdered;Not Shipped -- FLAG2 = '1'
      * 'BP' = Partil Fill -- FLAG2 = '2'
      * 'AC' = Shipped -- FLAG2 = '3'
     C*
     C     FLAG2         IFEQ      '1'
     C                   MOVEL     'IB'          P3CDST                         backordered/accepted
     C                   ENDIF
     C     FLAG2         IFEQ      '2'
     C                   MOVEL     'IB'          P3CDST                         backordered/partial
     C                   ENDIF
     C     FLAG2         IFEQ      '3'
     C                   MOVEL     'AC'          P3CDST                         accepted
     C                   ENDIF
     C*
     C                   ENDIF
      *
      *  Return backordered amount for detail line
     C     P4CDQD        IFEQ      'RTNBCK'
     C*
      * FORMAT BACKORDERED AMOUNT TO BE RETURNED IN SN1 ELEMENT.
     C                   MOVE      @QUAN3        @QUAN4            9 2
     C                   MOVEL     @QUAN4        P3CDST
     C*
     C                   ENDIF
     C*
      * +++++ (Any additional processing on "not found" can be done here)
     C                   GOTO      SBEXIT
      *
      * USER: Exit processing
      * (This point is also a "not found" due to the "*QUIT" above)
     C                   MOVEL     *BLANKS       W0RTN                          *Return code
      *================================================================
     CSR   SBEXIT        ENDSR
      /EJECT
     CSR   ZYEXPG        BEGSR
      *================================================================
      * Exit program: Direct
      *================================================================
      * Exit program
     C                   RETURN
      *
      *================================================================
     CSR   ZYEXIT        ENDSR
      /EJECT
     CSR   ZZINIT        BEGSR
      *================================================================
      * Initialization
      *================================================================
     C                   MOVE      *BLANK        P0RTN
     C                   MOVE      *BLANK        W0RTN             7
      * Initialise indicators for re-entry
     C                   MOVE      '0'           *IN
      * Setup job date/time
      *
     C                   Z-ADD     UDATE         ##JDT
     C                   TIME                    ##JTM
      * Update screen time
     C                   TIME                    ##TME             6 0
      * Define keylists
     C     KYVCODTL15    KLIST
     C                   KFLD                    @OBCMP
     C                   KFLD                    @OBORD
     C                   KFLD                    @OBBOCD
     C                   KFLD                    @OBLINE
     C     KYVCODTL9     KLIST
     C                   KFLD                    @OBCMP
     C                   KFLD                    @OBCUST
     C                   KFLD                    @OBORD
      *================================================================
     CSR   ZZEXIT        ENDSR

     



By: on