SeanHoppe.com › Cleo CodeSamples › Call 864, 824, 830 report program from TPMC Exit Point › EXTOL RPG - Create Readable Inbound 824 Report
FEXLLMQLT IF E K DISK
FEXDINUL0 IF E K DISK USROPN EXTMBR(MBR)
FQPRINT O F 132 PRINTER OFLIND(*INOF) FORMLEN(66) FORMOFL(64)
*-------------------------------------------------------------------------
D X S 3 0
D Y S 3 0
D Z S 3 0
D DATA S 132 VARYING
D SEG S 80 DIM(20) VARYING
D CODE S 2 DIM(12) CTDATA PERRCD(12)
D DESC S 50 DIM(12) CTDATA
D TODAY S D INZ(*SYS)
D USADAT S D DATFMT(*USA)
D TYPE S 10 VARYING
D EC C '352 ENGINEERING CHANGE ERROR: 00'
D DS
D LMINDL
D MBR 11 20
*-------------------------------------------------------------------------
C *DTAARA DEFINE *LDA LDA 11
C IN LDA
C MOVE LDA MSGLOG 11 0
C KML PLIST
C PARM CMD 256
C PARM 256 LEN 15 5
C MSGLOG CHAIN @LLMQLT LR
C IF *INLR = *OFF
* open printer file & specific file member for current doc
C OPEN EXDINUL0
C EXCEPT #HEADER
* print sender code, date & time of advice
C *YMD0 MOVE LMINDT USADAT
C EVAL DATA = 'Sender Code: ' + %TRIM(LMASID) +
C ' Sent: ' + %CHAR(USADAT) + ' at ' +
C %SUBST(LMINTM:1:2) + ':' + %SUBST(LMINTM:3:2)
C EXCEPT #DETAIL
* read starting rec for current doc within nonwrapped data
C LMNWRS CHAIN @DINUL0 20
C DOW *IN20 = *OFF AND INNWRC < LMNWRE
* populate element data array
C EXSR GETSEGS
C SELECT
* get transaction info
C WHEN SEG(1) = 'OTI'
C EVAL X = %LOOKUP(%TRIM(SEG(2)):CODE)
C EVAL Y = %LOOKUP(%TRIM(SEG(3)):CODE)
C EVAL DATA = %TRIM(DESC(X)) + ': ' + %TRIM(DESC(Y))
C + ' ' + %TRIM(SEG(4))
C IF SEG(11) = '810'
C EVAL TYPE = '(INVOICE)'
C ENDIF
C IF SEG(11) = '856'
C EVAL TYPE = '(SHIPMENT)'
C ENDIF
* get reference info
C WHEN SEG(1) = 'REF'
C EVAL X = %LOOKUP(%TRIM(SEG(2)):CODE)
C EVAL DATA = %TRIM(DESC(X)) + ': ' + SEG(3)
* get error description text
C WHEN SEG(1) = 'TED'
C EVAL DATA = %TRIM(SEG(3)) + ': ' + %TRIM(SEG(8))
* set indicator for engineering change error
C EC SCAN DATA 86
* clear print field if not populated above
C OTHER
C EVAL DATA = ' '
C ENDSL
* print text
C IF DATA <> ' '
C EXCEPT #DETAIL
C ENDIF
* get next record & check if last rec for current doc
C READ @DINUL0 20
C ENDDO
* close spoolfile & send as email
C EXCEPT #FOOTER
C MOVE *ON *INLR
C ENDIF
* delete splf if engineering change error
C IF *IN86
C EVAL CMD = 'DLTSPLF FILE(QPRINT) SPLNBR(*LAST)'
C ELSE
* override splf for Keyesmail
C EVAL CMD = 'CHGSPLFA FILE(QPRINT) +
C SPLNBR(*LAST) OUTQ(QUSRSYS/KMLOUTQ) +
C USRDFNDTA(''¬Email KMLEDI/' + %TRIM(LMMSCL)
C + ' ¬Subj EDI 824 ' + TYPE + ' ACCEPTANCE/RE+
C JECTION DOC RECVD FROM ' + %TRIM(LMTRNM) +
C ' ¬Temp *HTML'')'
C ENDIF
C CALL 'QCMDEXC' KML 13
C RETURN
*-------------------------------------------------------------------------
C GETSEGS BEGSR
*-------------------------------------------------------------------------
* initialize variable & clear array
C Z-ADD 1 X
C CLEAR SEG
* find each element start & end position
C 1 DO 20 Z
C LMELDM SCAN INNWDT:X Y 1310
C SELECT
* extract element data into array
C WHEN Y > X
C EVAL SEG(Z) = %SUBST(INNWDT:X:(Y-X))
C WHEN Y = 0 AND *IN10 = *OFF
C N10 EVAL Y = %SCAN(LMSGDM:INNWDT)
C EVAL SEG(Z) =
C %SUBST(INNWDT:X:(%LEN(%TRIM(INNWDT))-X))
C LEAVESR
* leave loop if no more delimiters found or if unneeded segment found
C WHEN (SEG(1) <> 'GS' AND SEG(1) <> 'OTI' AND
C SEG(1) <> 'REF' AND SEG(1) <> 'TED')
C LEAVESR
C ENDSL
* increment starting pos
C EVAL X = Y + 1
C ENDDO
C ENDSR
*-------------------------------------------------------------------------
OQPRINT E #HEADER 1
O '<font face="Courier">'
O E #HEADER 1 1
O LMTRNM
O E #DETAIL 1
O DATA
O E #FOOTER 2
O '*** END OF REPORT***'
O '</font> '
** *-------------------------------------------------------------------------
GRIEIRTRIVSITNLIP7PKPMPO
**
Functional Group Rejected
Item Accept with Error
Item Rejected
Transaction Set Rejected
Seller's Invoice Number
Shipper's Identifying Number for Shipment (SID)
Transaction Reference Number
Line Item Identifier (Seller's)
Product Line Number
Packing List Number
Part Number
Purchase Order Number
