SeanHoppe.com › Cleo CodeSamples › BAK02 Acknowledgement Status Code for Outbound 855
h Debug(*Yes) Datedit(*Ymd)
h/Title BAK02 Acknowledgement Status Code for Outbound 855
**************************************************************************
*
* Warning: This program does not set on LR.
*
**************************************************************************
* SYNOPSIS :
* External call program will query F47027 (PO Ack detail table to determine Acknowledgement Type
* BAK02 element. Program will compare 3 items to see if order matches PO
* 1. Ordering Price vs. Sales Price
* 2. Ordering UOM vs. Sales UOM
* 3. Ordering Quantity vs. Shipped Quantity
*
* System : Integrator 400
* User name : SRH
* Date CREATED : 06/07/15
**************************************************************************
* Maintenance : Manually modified Synon program.
**************************************************************************
* Date Description
* ---- ---------- ----------------------------------------------------------------
*
**************************************************************************
FF47027_1 IF E K DISK RENAME(F47027:F47027)
D*
* Data structures:
* Parameter declarations
d P1Parm DS
* I : Code trans directions
d P1Cdtt 1 1
d P2Parm DS
* : Code Table reference
d P2Tabl 1 10
* B : Code in standard form
d P2Cdst 11 90
* B : Code qualifier data
d P2Cdqd 91 170
* B : Code in local form
d P2Cdlc 171 250
d P3Parm DS
* FLD: XLT msg Parm structure
* I : Connection log number
d P3Cnln 1 4P 0
* I : Network ID
d P3Nwid 5 19
* I : Date/time start of call
d P3Dtm1 20 27P 0
* I : Interchange log number
d P3Inln 28 32P 0
* I : Trading partner code
d P3Tpcd 33 38
* I : Interchange date
d P3Indt 39 44
* I : Interchange time
d P3Intm 45 48
* : Test indicator
d P3Tsti 49 49
* I : Group log number
d P3Gpln 50 54P 0
* I : Message log number
d P3Msln 55 60P 0
* I : Message ID
d P3Msid 61 66
* I : Message class
d P3Mscl 67 76
* I : Message direction
d P3Msdi 77 77
* I : Application file name
d P3Gfil 78 87
* I : Record format name
d P3Rcfm 88 97
* I : V-R Log of message
d P3Vrlm 98 103
* I : Industry group ID log msg
d P3Igim 104 109
* I : Application data log #
d P3Apln 110 114P 0
* I : Application file set
d P3Gfsn 115 124
* I : Msg queue - translation
d P3Msqt 125 134
* I : Trans job master control
d P3Tjmc 135 140P 0
* I : Segment position in msg
d P3Sgps 141 144P 0
* I : Segment ID
d P3Sgid 145 147
* I : Element pos in segment
d P3Elps 148 149P 0
* I : Component position
d P3Cpos 150 151P 0
* I : Element ID
d P3Elid 152 155
* I : Field name
d P3Flnm 156 165
* I : Field length
d P3Flln 166 168P 0
* I : Field number of digits
d P3Fldd 169 170P 0
* I : Field decimal positions
d P3Fldc 171 172P 0
* I : Field type
d P3Flty 173 173
* I : Field Null value type
d P3Nult 174 174
* I : Field Null value length
d P3Null 175 177P 0
* I : Field Null value
d P3Nulv 178 187
* I : Message area
d P3Sgar 188 188
* I : Segment sequence
d P3Sgsq 189 192
* I : Segment instance number
d P3Sgnm 193 194P 0
* I : Element mapping sequence
d P3Mpsq 195 196P 0
* I : Nonwrapped record number
d P3Nwrc 197 201P 0
d P4Parm DS
* FLD: XLT misc field Parm str
* I : Field mapping sequence
d P4Fmsq 1 2P 0
* I : #XLT Line counter 1 7.0P
d P4N1 3 6P 0
* I : #XLT Line counter 2 7.0P
d P4N2 7 10P 0
* I : #XLT Segment length 5.0P
d P4Gdlp 11 13P 0
* I : #XLT Last element 3.0P
d P4Max 14 15P 0
* I : Sub-element delimiter
d P4Sedm 16 16
* I : Element delimiter
d P4Eldm 17 17
* I : Decimal notation
d P4Dcnt 18 18
* I : Release indicator char
d P4Rlin 19 19
* I : Reserved space in UNA
d P4Rssp 20 20
* I : Segment delimiter
d P4Sgdm 21 21
d P4Scf DS
* FLD: XLT misc field Parm str
* I : #XLT Sg counters 10x15.0P
d SC 1 80P 0
d DIM(10) Segment counters
d P4Elnf DS
* FLD: XLT misc field Parm str
* I : #XLT Elem lengths 99x3.0P
d Eln 1 198P 0
d DIM(99) 99 el.lengths 3.0
d P4Sgf DS
* FLD: XLT misc field Parm str
* I : #XLT Segment buffer 2006A
d SG 1 2006
d DIM(2006) segment buffer
d Wp0052 DS 2006
d P4ELF DS
* FLD: XLT misc field Parm str
* I : #XLT Elem data 99x100
d EL 1 9900
d DIM(99) 99 elements x 100
d Wp0053 DS 9900
d W0rtn s Like(P0rtn)
d @URAT S LIKE(SZURAT) Xref type code
d @URAB S LIKE(SZURAB) Xref type code
d @LITM S 25A Long item number
d @TSTL S 1 0 Location test val
**************************************************************************
* Mainline Program.
**************************************************************************
*
**************************************************************************
* Srdefn - Definitions
**************************************************************************
c* Srdefn Begsr
*
* 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 P2Cdst Parm P2Cdst Wp0003 80 Code in standar
c P2Cdqd Parm P2Cdqd Wp0004 80 Code qualifier
c P2Cdlc Parm P2Cdlc Wp0005 80 Code in local f
c P3Cnln Parm Wp0006 7 0 Connection log
c P3Nwid Parm Wp0007 15 Network ID
c P3Dtm1 Parm Wp0008 15 0 Date/time start
c P3Inln Parm Wp0009 9 0 Interchange log
c P3Tpcd Parm Wp0010 6 Trading partner
c P3Indt Parm Wp0011 6 Interchange dat
c P3Intm Parm Wp0012 4 Interchange tim
c P3Tsti Parm Wp0013 1 Test indicator
c P3Gpln Parm Wp0014 9 0 Group log numbe
c P3Msln Parm Wp0015 11 0 Message log num
c P3Msid Parm Wp0016 6 Message ID
c P3Mscl Parm Wp0017 10 Message class
c P3Msdi Parm Wp0018 1 Message directi
c P3Gfil Parm Wp0019 10 Application fil
c P3Rcfm Parm Wp0020 10 Record format n
c P3Vrlm Parm Wp0021 6 V-R Log of mess
c P3Igim Parm Wp0022 6 Industry group
c P3Apln Parm Wp0023 9 0 Application dat
c P3Gfsn Parm Wp0024 10 Application fil
c P3Msqt Parm Wp0025 10 Msg queue - tra
c P3Tjmc Parm Wp0026 11 0 Trans job maste
c P3Sgps Parm Wp0027 7 0 Segment positio
c P3Sgid Parm Wp0028 3 Segment ID
c P3Elps Parm Wp0029 3 0 Element pos in
c P3CPOS Parm Wp0030 3 0 Component posit
c P3Elid Parm Wp0031 4 Element ID
c P3Flnm Parm Wp0032 10 Field name
c P3Flln Parm Wp0033 5 0 Field length
c P3Fldd Parm Wp0034 2 0 Field number o
c P3Fldc Parm Wp0035 2 0 Field decimal
c P3Flty Parm Wp0036 1 Field type
c P3Nult Parm Wp0037 1 Field Null val
c P3Null Parm Wp0038 5 0 Field Null val
c P3Nulv Parm Wp0039 10 Field Null val
c P3Sgar Parm Wp0040 1 Message area
c P3Sgsq Parm Wp0041 4 Segment sequen
c P3Sgnm Parm Wp0042 3 0 Segment instan
c P3Mpsq Parm Wp0043 3 0 Element mappin
c P3Nwrc Parm Wp0044 9 0 Nonwrapped rec
c P4Fmsq Parm Wp0045 3 0 Field mapping
c P4N1 Parm P4N1 Wp0046 7 0 #XLT Line coun
c P4N2 Parm P4N2 Wp0047 7 0 #XLT Line coun
c P4Scf Parm Wp0048 80 #XLT Sg counte
c P4Gdlp Parm Wp0049 5 0 #XLT Segment l
c P4Max Parm Wp0050 3 0 #XLT Last elem
c P4Elnf Parm Wp0051 198 #XLT Elem leng
c P4Sgf Parm Wp0052 #XLT Segment b
c P4ELF Parm Wp0053 #XLT Elem data
c P4Sedm Parm Wp0054 1 Sub-element de
c P4Eldm Parm Wp0055 1 Element delimi
c P4Dcnt Parm Wp0056 1 Decimal notati
c P4Rlin Parm Wp0057 1 Release indica
c P4Rssp Parm Wp0058 1 Reserved space
c P4Sgdm Parm Wp0059 1 Segment delimi
*
* Key to the invoice detail lines
C KeyF47027 KLIST
C KFLD SZEDOC
C KFLD SZEDCT
C KFLD SZEKCO
*
c* Endefn Endsr
*
C EXSR Srinit
*
C P1CDTT IFEQ 'I'
*
*
C ELSE
* CASE: PAR.Code trans directions is Outward translation
C P1CDTT IFEQ 'O'
C*
C P2Cdqd IFEQ 'EDOC'
C MOVEL *ZEROS WK_EDOC 9 0
C MOVEL P2CDLC WK_EDOC
C END
C*
C P2Cdqd IFEQ 'EKCO'
C MOVEL *BLANKS WK_EKCO 5
C MOVEL P2CDLC WK_EKCO
C END
C*
C P2Cdqd IFEQ 'EDLN'
C MOVEL *ZEROS WK_EDLN 7 0
C MOVEL P2CDLC WK_EDLN
C END
C*
C P2Cdqd IFEQ 'EDCT'
C MOVEL *BLANKS WK_EDCT 2
C MOVEL P2CDLC WK_EDCT
C END
*
C*
C P2Cdqd IFEQ 'BAK01'
C*
C Z-ADD WK_EDOC SZEDOC
C MOVEL WK_EDCT SZEDCT
C MOVEL WK_EKCO SZEKCO
C*
C MOVE *OFF *IN91
C KEYF47027 SETLL F47027
C KEYF47027 READE F47027 91
C *IN91 DOWEQ *OFF
C*
C* Check to see if F47027 record was received via 850
C SZURAB IFGT 0
C*
C* Compare Sales Price to Ordering Price
C SZURAT DIV 10000 @URAT
C @URAT IFNE SZUPRC
C MOVE '1' FLAG1 1
C ENDIF
C*
C* Compare Shipped Quantity to Ordering Quantity
C SZSQOR IFNE SZPQOR
C MOVE '1' FLAG1 1
C ENDIF
C*
C* Compare Sales UOM to Ordering UOM
C SZUOM1 IFNE SZURCD
C MOVE '1' FLAG1 1
C ENDIF
C ENDIF
C KEYF47027 READE F47027 91
C ENDDO
C*
C* If there are changes to original order, pass back '05', else
C* pass back '00'. This value will be populated in BAK01 of 855
C*
C FLAG1 IFEQ '1'
C MOVEL '05' P2Cdst
C ELSE
C MOVEL '00' P2Cdst
C ENDIF
C*
C ENDIF
C*
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
*
