SeanHoppe.com › Cleo CodeSamples › EXTOL 850 x12 Inbound RPGLE Report
For additional EXTOL EDI Integrator RPGLE Examples: Sean Hoppe Consulting Group Coding Samples
H* Note:
*-------------------------------------------------------------------------
FEXLLMRL1 IF E K DISK Msg log file
FEXDINRL0 IF E K DISK EXTMBR(MBRNAM) USROPN unwrap data
FEDI850RPT O F 132 PRINTER OFLIND(*INOF) USROPN
*-------------------------------------------------------------------------
* Print fields
D PONUM S 22
D POTYP S 12
D PODAT S 10
D PCDAT S 10
D ORDTYP S 10
D BDNAM S 40
D OCNAM S 40
D BDNUM S 20
D OCNUM S 20
D FOB S 28
D ITD03 S 6
D ITD05 S 3
D ITD07 S 3
D BYNAM S 58
D BYADR S 58
D BYCSZ S 58
D SENAM S 58
D SEADR S 58
D SECSZ S 58
D LINE# S 7
D QTY S 10
D QTYSCH S 10
D UOM S 2
D PRICE S 6
D PER S 10
D PART# S 10
D RQDLDT S 8
D RQDSCH S 8
D RQSHDT S 8
D RQSSCH S 8
D ROUTING S 8
D PACK S 10
D CHGDAT S 8
D CHANGE S 22
D SHPNEW DS
D SFNAM 57
D SFADR 57
D SFCSZ 57
D STNAM 57
D STADR 57
D STCSZ 57
D SHPSAV S 342
D LINE132 S 132 INZ(*ALL'-')
* work variables
D DS
D INNWDT
D SEG 1 3
D DATA S 132 DIM(50)
D MSG S 132 DIM(99)
D PID S 80 DIM(99)
D N101 S 2
D A S 3 0
D X S 3 0
D Y S 3 0
D Z S 3 0
D MDYY S D DATFMT(*USA)
D DS
D LMINDL
D MBRNAM 11 20
*-------------------------------------------------------------------------
C *ENTRY PLIST
C PARM MLOG 11
C MOVE MLOG MSGLOG 11 0
*
* get msg log rec
C MSGLOG CHAIN @LLMRL1 LR
C LR RETURN
* open unwrapped data member
C OPEN EXDINRL0
C OPEN EDI850RPT
* read first unwrapped (ST) record & save element seperator
C LMNWRS CHAIN @DINRL0 01
C 1 SUBST INNWDT:3 SEP 1
* read header segments
C EXSR GETHEADER
* read header message segments
C IF SEG = ('N9' + SEP)
C EXSR GETMSGS
C ENDIF
* read header buyer/seller segments
C IF SEG = ('N1' + SEP)
C EXSR GETNAMADR
C ENDIF
* print header section
C EXCEPT HEADER
* print header messages saved in array
C MSG(1) CASNE *BLANK PRINTMSG
C ENDCS
* read detail segments until end of order or eof
C DOW (SEG = 'PO1' OR SEG = 'POC')
C AND *INLR = *OFF
C EXSR GETDETAIL
* read next detail rec
C READ @DINRL0 LR
C ENDDO
* print totals
C EXCEPT TOTALS
C CLOSE EXDINRL0
C CLOSE EDI850RPT
* send email
C EVAL CMD = 'CHGSPLFA FILE(EDI850RPT) +
C SPLNBR(*LAST) OUTQ(QUSRSYS/KMLOUTQ) +
C USRDFNDTA(''¬Email KMLEDI/' + LMMSCL +
C ' ¬Subj PO ' + %TRIM(PONUM) +
C ' recvd from ' + %TRIM(LMTRNM) +
C ' ¬Temp TP Name ¬Trans 6'')'
C CALL 'QCMDEXC' 13
C PARM CMD 256
C PARM 256 LEN 15 5
* end pgm
C MOVE *ON *INLR
C RETURN
*-------------------------------------------------------------------------
C GETHEADER BEGSR
*-------------------------------------------------------------------------
C DOW SEG <> ('N9' + SEP) AND SEG <> ('N1' + SEP)
C AND INNWRC < LMNWRE
C SELECT
* get PO data from BEG segment
C WHEN SEG = 'BEG' OR SEG = 'BCH'
C EXSR GETDATA
* move element data into print fields
C SELECT
C WHEN DATA(2) = 'BK'
C MOVEL 'Blanket' POTYP
C WHEN DATA(2) = 'SA'
C MOVEL 'Stand-Alone' POTYP
C ENDSL
C MOVEL DATA(3) PONUM
C IF SEG = 'BEG'
C EVAL PODAT = %SUBST(DATA(5):5:2) + '/' +
C %SUBST(DATA(5):7:2) + '/' +
C %SUBST(DATA(5):1:4)
C EVAL ORDTYP = 'ORIGINAL'
C ELSE
C EVAL PODAT = %SUBST(DATA(6):5:2) + '/' +
C %SUBST(DATA(6):7:2) + '/' +
C %SUBST(DATA(6):1:4)
C EVAL PCDAT = %SUBST(DATA(11):5:2) + '/' +
C %SUBST(DATA(11):7:2) + '/' +
C %SUBST(DATA(11):1:4)
C EVAL ORDTYP = 'CHANGE'
C MOVE *ON *IN60
C ENDIF
* get BUYER data from PER segment(s)
C WHEN SEG = 'PER'
C EXSR GETDATA
* move element data into print fields
C SELECT
C WHEN DATA(1) = 'BD'
C MOVEL DATA(2) BDNAM
C MOVEL DATA(4) BDNUM
C WHEN DATA(1) = 'OC'
C MOVEL DATA(2) OCNAM
C MOVEL DATA(4) OCNUM
C ENDSL
* get CARRIER PAYMT data from FOB segment & remove segment terminator
C WHEN SEG = 'FOB'
C EVAL FOB = %SUBST(INNWDT:11:
C (%CHECKR(' ':INNWDT) - 11))
* get TERMS data from ITD segment(s)
C WHEN SEG = 'ITD'
C EXSR GETDATA
C IF ITD03 = *BLANKS
C MOVEL DATA(3) ITD03
C MOVEL DATA(5) ITD05
C ELSE
C MOVEL DATA(7) ITD07
C ENDIF
C ENDSL
* get next header level rec
C READ @DINRL0 01
C ENDDO
C ENDSR
*-------------------------------------------------------------------------
C GETDATA BEGSR
*-------------------------------------------------------------------------
* initialize array
C CLEAR DATA
C Z-ADD 1 A
C Z-ADD 0 Z
* find first element seperator
C EVAL X = %SCAN(SEP:INNWDT) + 1
C DOW Z >= 0
* find next element seperator
C EVAL Y = %SCAN(SEP:INNWDT:X)
* calculate element data length
C Y SUB X Z
* extract element data into array
C SELECT
C WHEN Z = 0
C EVAL DATA(A) = *BLANKS
C WHEN Z > 1
C EVAL DATA(A) = %SUBST(INNWDT:X:Z)
C WHEN Z < 0
C EVAL Y = %LEN(%TRIM(INNWDT)) - X
C EVAL DATA(A) = %SUBST(INNWDT:X:Y)
C ENDSL
* increment starting position & counter
C Y ADD 1 X
C ADD 1 A
C ENDDO
C ENDSR
*-------------------------------------------------------------------------
C GETMSGS BEGSR
*-------------------------------------------------------------------------
C CLEAR MSG
C Z-ADD 1 X
* get all MESSAGE data from N9 & MSG segments
C DOW SEG = ('N9' + SEP) OR SEG = 'MSG'
* load MESSAGE data from MSG segments
C IF SEG = 'MSG'
C EVAL MSG(X) = %SUBST(INNWDT:5:
C (%LEN(%TRIM(INNWDT)) - 5))
* load MESSAGE REF data from N9 segment
C ELSE
C MOVE LINE132 MSG(X)
C ADD 1 X
C EVAL MSG(X) = %SUBST(INNWDT:9:
C (%CHECKR(' ':INNWDT) - 9))
C ENDIF
C READ @DINRL0
C ADD 1 X
C ENDDO
C ENDSR
*-------------------------------------------------------------------------
C GETNAMADR BEGSR
*-------------------------------------------------------------------------
C DOW SEG >= ('N1' + SEP) AND SEG <= ('N4' + SEP)
C SELECT
* get element data from N1 segment
C WHEN SEG = ('N1' + SEP)
C EXSR GETDATA
* move N1 info into print fields
C SELECT
C WHEN DATA(1) = 'BY'
C EVAL BYNAM = %TRIM(DATA(2)) + ' ' + DATA(4)
C MOVE 'BY' N101
C WHEN DATA(1) = 'SE'
C EVAL SENAM = %TRIM(DATA(2)) + ' ' + DATA(4)
C MOVE 'SE' N101
C WHEN DATA(1) = 'SF'
C EVAL SFNAM = %TRIM(DATA(2)) + ' ' + DATA(4)
C MOVE 'SF' N101
C WHEN DATA(1) = 'ST'
C EVAL STNAM = %TRIM(DATA(2)) + ' ' + DATA(4)
C MOVE 'ST' N101
C ENDSL
* move N3 info to print fields
C WHEN SEG = ('N3' + SEP)
C SELECT
C WHEN N101 = 'BY'
C EVAL BYADR = %SUBST(INNWDT:4:
C (%CHECKR(' ':INNWDT) - 4))
C WHEN N101 = 'SE'
C EVAL SEADR = %SUBST(INNWDT:4:
C (%CHECKR(' ':INNWDT) - 4))
C WHEN N101 = 'SF'
C EVAL SFADR = %SUBST(INNWDT:4:
C (%CHECKR(' ':INNWDT) - 4))
C WHEN N101 = 'ST'
C EVAL STADR = %SUBST(INNWDT:4:
C (%CHECKR(' ':INNWDT) - 4))
C ENDSL
* move N4 data into print fields
C WHEN SEG = ('N4' + SEP)
C EXSR GETDATA
C SELECT
C WHEN N101 = 'BY'
C EVAL BYCSZ = %TRIM(DATA(1)) + ', ' +
C %TRIM(DATA(2)) + ' ' + DATA(3)
C WHEN N101 = 'SE'
C EVAL SECSZ = %TRIM(DATA(1)) + ', ' +
C %TRIM(DATA(2)) + ' ' + DATA(3)
C WHEN N101 = 'SF'
C EVAL SFCSZ = %TRIM(DATA(1)) + ', ' +
C %TRIM(DATA(2)) + ' ' + DATA(3)
C WHEN N101 = 'ST'
C EVAL STCSZ = %TRIM(DATA(1)) + ', ' +
C %TRIM(DATA(2)) + ' ' + DATA(3)
C LEAVESR
C ENDSL
C ENDSL
* get next rec
C READ @DINRL0
C ENDDO
C ENDSR
*-------------------------------------------------------------------------
C GETDETAIL BEGSR
*-------------------------------------------------------------------------
C Z-ADD 1 X
C DOW INNWRC < LMNWRE AND *INLR = *OFF
C SELECT
* get detail line data from PO1/POC segment
C WHEN SEG = 'PO1' OR SEG = 'POC'
C EXSR GETDATA
C MOVEL DATA(1) LINE#
C SELECT
C WHEN DATA(2) = 'AI'
C EVAL CHANGE = 'Add Additional Item(s)'
C WHEN DATA(2) = 'DI'
C EVAL CHANGE = 'Delete Item(s)'
C WHEN DATA(2) = 'NC'
C EVAL CHANGE = 'Concurrent (No Change)'
C WHEN DATA(2) = 'PC'
C EVAL CHANGE = 'Price Change '
C WHEN DATA(2) = 'PQ'
C EVAL CHANGE = 'Unit Price/Qty Change '
C WHEN DATA(2) = 'RQ'
C EVAL CHANGE = 'Reschedule/Qty Change '
C WHEN DATA(2) = 'RS'
C EVAL CHANGE = 'Reschedule'
C WHEN DATA(2) = 'RZ'
C EVAL CHANGE = 'Replace All Values'
C OTHER
C MOVEL DATA(2) QTY
C ENDSL
C IF SEG = 'PO1'
C MOVEL DATA(3) UOM
C MOVEL DATA(4) PRICE
C MOVEL DATA(5) PER
C MOVEL DATA(7) PART#
C ELSE
C MOVEL DATA(3) QTY
C MOVEL DATA(5) UOM
C MOVEL DATA(6) PRICE
C MOVEL DATA(7) PER
C MOVEL DATA(9) PART#
C ENDIF
C SELECT
C WHEN PER = 'ES'
C EVAL PER = 'Estimate'
C WHEN PER = 'HP'
C EVAL PER = 'Hundred'
C WHEN PER = 'PE'
C EVAL PER = 'Each'
C WHEN PER = 'PN'
C EVAL PER = 'Tens'
C WHEN PER = 'TP'
C EVAL PER = 'Thousand'
C ENDSL
* insert decimal points
C EVAL QTY=%REPLACE('.':QTY:(%LEN(%TRIM(QTY))-1):0)
C EVAL PRICE=
C %REPLACE('.':PRICE:(%LEN(%TRIM(PRICE))-1):0)
* get ITEM DESCRIPTIONS from PID segment (loop)
C WHEN SEG = 'PID'
C EVAL PID(X) = %SUBST(INNWDT:5:
C (%CHECKR(' ':INNWDT) - 5))
C ADD 1 X
* get REQUESTED DELV/SHIP DATES from DTM segment
C WHEN SEG = 'DTM' AND %SUBST(INNWDT:5:3) = '002'
C EVAL RQDLDT = %SUBST(INNWDT:13:2) + '/' +
C %SUBST(INNWDT:15:2)+'/'+%SUBST(INNWDT:11:2)
C WHEN SEG = 'DTM' AND %SUBST(INNWDT:5:3) = '010'
C EVAL RQSHDT = %SUBST(INNWDT:13:2) + '/' +
C %SUBST(INNWDT:15:2)+'/'+%SUBST(INNWDT:11:2)
* get CARRIER line data from TD5 segment
C WHEN SEG = 'TD5' AND %SUBST(INNWDT:8:1) = 'H'
C EVAL ROUTING = 'PickUp'
C WHEN SEG = 'TD5' AND %SUBST(INNWDT:8:1) = 'M'
C EVAL ROUTING = 'Motor'
* get MARKING line data from PKG segment
C WHEN SEG = 'PKG'
C EVAL PACK = %SUBST(INNWDT:12:
C (%CHECKR(' ':INNWDT) - 12))
* get SCHEDULE line data from SCH segment
C WHEN SEG = 'SCH'
C EXSR GETDATA
C MOVEL DATA(1) QTYSCH
C MOVEL DATA(6) RQDSCH
C MOVEL DATA(9) RQSSCH
C IF QTY <> QTYSCH OR RQDLDT <> RQDSCH OR
C RQSHDT <> RQSSCH
C MOVE *ON *IN50
C QTY COMP QTYSCH 51
C RQDLDT COMP RQDSCH 56
C RQSHDT COMP RQSSCH 59
C ENDIF
* read line MESSAGE segments
C WHEN SEG = ('N9' + SEP)
C EXSR GETMSGS
* read header SHIP FROM/TO segments
C WHEN SEG = ('N1' + SEP)
C EXSR GETNAMADR
* print detail line column headings
C IF *IN01 = *OFF
C EXCEPT SHIPPING
C EXCEPT COLUMNS
C MOVE SHPNEW SHPSAV
C MOVE *ON *IN01
C ENDIF
* print line item DETAILS
C EXCEPT DETAILS
C OF EXCEPT COLUMNS
* print line item DESCRIPTIONS
C Z-ADD 1 Y
C DOW PID(Y) <> *BLANKS
C EXCEPT DESCRIPT
C OF EXCEPT COLUMNS
C ADD 1 Y
C CLEAR PID
C ENDDO
* print SHIPPING info
C IF SHPNEW <> SHPSAV
C EXCEPT SHIPPING
C ENDIF
C MOVE SHPNEW SHPSAV
C OF EXCEPT COLUMNS
* print line item MESSAGES
C MSG(X) CASNE *BLANK PRINTMSG
C ENDCS
C ENDSL
* get next detail level rec
C MOVE *OFF *IN50
C READ @DINRL0 LR
C ENDDO
C ENDSR
*-------------------------------------------------------------------------
C PRINTMSG BEGSR
*-------------------------------------------------------------------------
* print line messages saved in array
C Z-ADD 1 Y
C DOW MSG(Y) <> *BLANKS
C EXCEPT MESSAGES
C OF EXCEPT COLUMNS
C ADD 1 Y
C ENDDO
C EXCEPT UNDERLINE
C CLEAR MSG
C ENDSR
*-------------------------------------------------------------------------
OEDI850RPT E HEADER 1
O 78 '========================='
O E HEADER 1 --------------------
O 78 'EDI PURCHASE ORDER REPORT'
O E HEADER 1 --------------------
O 78 '========================='
O E HEADER 2 --------------------
O 'CUSTOMER......: '
O LMTRNM
O 74 'BUYER NAME....: '
O BDNAM
O E HEADER 1 --------------------
O 'PURCHASE ORDER: '
O PONUM
O 74 'BUYER PHONE...: '
O BDNUM
O E HEADER 1 --------------------
O 'PO TYPE.......: '
O POTYP
O 74 'CONTACT NAME..: '
O OCNAM
O E HEADER 1 --------------------
O 'PO DATE.......: '
O PODAT
O 74 'CONTACT PHONE.: '
O OCNUM
O E HEADER 1 --------------------
O 'ORDER TYPE....: '
O ORDTYP
O 74 'BUYING OFFICE.: '
O BYNAM
O E HEADER 1 --------------------
O 'CHANGE DATE...: '
O PCDAT
O BYADR 132
O E HEADER 1 --------------------
O 'TERMS DISCOUNT: '
O ITD03
O 22 '%'
O BYCSZ 132
O E HEADER 1 --------------------
O 'DISCOUNT DAYS.: '
O ITD05
O 74 'SELLING OFFICE: '
O SENAM
O E HEADER 1 --------------------
O 'TERMS DAYS....: '
O ITD07
O SEADR 132
O E HEADER 1 --------------------
O 'PAYMENT METHOD: '
O FOB
O SECSZ 132
*-------------------------------------------------------------------------
O EF MESSAGES 1
O MSG(Y)
*-------------------------------------------------------------------------
O E OF COLUMNS 1
O LINE132
O E NOF COLUMNS 1 --------------------
O LINE132
O E COLUMNS 1 --------------------
O 'LINE# QUANTITY UOM PR'
O 'ICE PRICE-PER BUYERS PAR'
O 'T# REQ-DELV REQ-SHIP RO'
O 'UTING PALLET '
O 60 'CHG-DATE CHANGED'
O E COLUMNS 1 --------------------
O LINE132
*-------------------------------------------------------------------------
O EF DETAILS 1
O LINE#
O QTY 19
O UOM 21
O PRICE 30
O PER 42
O PART# 53
O RQDLDT 64
O RQSHDT 74
O ROUTING 84
O PACK 95
O CHGDAT 112
O CHANGE 129
O EF 50 DETAILS 1
O 'SCHEDULE'
O 51 QTYSCH 19
O 56 RQDSCH 64
O 59 RQSSCH 74
*-------------------------------------------------------------------------
O EF DESCRIPT 1
O PID(Y)
*-------------------------------------------------------------------------
O EF SHIPPING 1
O 'SHIP-FROM: '
O SFNAM
O 75 'SHIP-TO: '
O STNAM
O EF SHIPPING 1 --------------------
O SFADR 68
O STADR 132
O EF SHIPPING 1 1 --------------------
O SFCSZ 68
O STCSZ 132
*-------------------------------------------------------------------------
O E UNDERLINE 1
O LINE132
*-------------------------------------------------------------------------
O E TOTALS 1
O LINE132
O E TOTALS 1
O '**END OF REPORT**'