SeanHoppe.com › Cleo CodeSamples › 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
