SeanHoppe.com › Cleo CodeSamples › Send email if customer item in JDE Table F4104 does not exsist
H DATEDIT(*YMD) DEBUG(*YES)
*
* Warning: This program does not set on the LR.
*
**************************************************************************
* SYNOPSIS :
* External call program which uses the "long
* parameter list"
* PGM identifies 'bad' items in order. If bad items are identified then an
* email is sent to internal email addresses plus 1 email address in the actual 850.
**************************************************************************
* Maintenance :
**************************************************************************
* BMR Date Description
* ---- ---------- ----------------------------------------------------------------
* XXX XX/XX/XXXX Original Compile.
**************************************************************************
fExmmtrl0 if e k Disk
FF4104_14 if e k Disk RENAME(F4104:F4104)
* 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
* Parameter declarations
<--- LONG PARM LIST HERE --->
*
* CL Commands to Perform
d Command s 100 Dim(13) Ctdata Perrcd(1) Commands
*
d @@Cmd s 3000
d @@Cmdlength s 15 5 Inz(3000)
d @IND s 1A Inz(' ')
d @IND2 s 1A Inz(' ')
d @FILEN s 20A Inz(' ')
d @RCDD s 80A Inz(' ')
d @PO s 15A Inz(' ')
d @CHECK s 15A Inz(' ')
d @CHECKP s 15A Inz(' ')
d @BODY s 205A Inz(' ')
d @SUB s 50A Inz(' ')
d @TPID s 8A Inz(' ')
d @LINN s 4A Inz(' ')
d @DESC s 40A Inz(' ')
d @ITEM s LIKE(IVCITM) Inz(' ')
d @EMAIL s 35A Inz(' ')
d @EMAILPO s 35A Inz(' ')
d @BUYER s 35A Inz(' ')
d @TOFIL s 8A Inz('EMAIL850')
d @LIB s 5A Inz('QTEMP')
d @XRT s 2A Inz('C ')
d @AN8 s LIKE(IVAN8)
d @Const s 5 INZ('ADD') Msgclss const
d @times s 26z Msgclss const
d @timesa s 35a Msgclss const
d @timesa2 s 4a Msgclss const
**************************************************************************
* Mainline Program.
**************************************************************************
C EXSR Srinit
*
* External Code process P1
C MOVE *BLANKS W0RTN 7 *Return code
C Eval W0Rtn = *Blanks *Return code
*
* CASE: PAR.Code trans directions is Inward translation
C P1Cdtt Caseq 'I' Srstlc *CS
*
* CASE: PAR.Code trans directions is Outward translation
C P1Cdtt Caseq 'O' Srlcst *CS
C Endcs *EC
*
* A "Return code" of non-blank will be logged as a translation error:
C* Eval P0Rtn = W0Rtn *Return code
C Return
**************************************************************************
* Srdefn - Definitions
**************************************************************************
C Srdefn Begsr
*
* Entry parameters
C *Entry Plist
<--- PARAMETER LIST HERE --->
*
* Parameters for 'QCMDEXC'
c Qcmd Plist
c Parm @@Cmd
c Parm 3000 @@Cmdlength
C*
* Key to the EXMMTRL0 - Message class constants
c KeyExmmtrl0 Klist
c Kfld P3MSID
c Kfld P3MSCL
c Kfld @CONST
C
* Key to the F4104_14
C KeyF4104 KLIST
C KFLD @ITEM
C KFLD @XRT
C KFLD @AN8
C Endefn Endsr
**************************************************************************
* 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
**************************************************************************
* SRLCST - Local to Standard Routine.
*
* Incoming ("I") - Standard -> Application translation.
*
**************************************************************************
C Srlcst Begsr
C*
*
C Enlcst Endsr
**************************************************************************
* Srstlc - Local to Standard Routine.
*
* Outgoing ("O") - Application -> Standard translation.
*
**************************************************************************
C Srstlc Begsr
*
C P2Cdqd IFEQ 'CLEAR'
C MOVEL *BLANKS @IND
C MOVEL *BLANKS @CHECKP
C MOVEL *BLANKS @IND2
C MOVEL *BLANKS @EMAILPO
C MOVEL *BLANKS @BUYER
C MOVEL *BLANKS @FILEN
c Clear @@Cmd
c* Eval @@Cmd = Command(1)
c* Call 'QCMDEXC' QCmd 96
c Clear @@Cmd
c Eval @@Cmd = Command(2)
c Call 'QCMDEXC' QCmd 96
*
C P3TPCD IFEQ 'XXXXV'
C CLEAR @AN8
C MOVE 00241985 @AN8
C END
*
C P3TPCD IFEQ 'XXXXA'
C CLEAR @AN8
C MOVE 00336787 @AN8
C END
C END
*
C P2Cdqd IFEQ 'CLRDTL'
C MOVEL *BLANKS @IND2
C MOVEL *BLANKS @CHECK
C END
C*
C* Set-up email variables: BODY,SUB,EMAIL
C*
C* Capture PO #
C P2Cdqd IFEQ 'PO'
C MOVEL *ZEROS @PO
C MOVEL P2CDST @PO
C END
C*
C* Capture name of buyer
C P2Cdqd IFEQ 'BUYER'
C MOVEL *BLANKS @BUYER
C MOVEL P2CDST @BUYER
C END
C*
C* Capture email address of buyer
C P2Cdqd IFEQ 'EMAIL'
C MOVEL *BLANKS @EMAILPO
C* MOVEL P2CDST @EMAILPO
C
C P3Tpcd IFEQ 'XXXXA'
C MOVEL *BLANKS @TPID
C MOVEL 'AHE' @TPID
C ENDIF
C
C P3Tpcd IFEQ 'XXXXV'
C*
C MOVEL *BLANKS @TPID
C MOVEL 'Customer' @TPID
C ENDIF
C
C EVAL @SUB = @TPID + ' ' + 'PO ERROR: '
C EVAL @SUB = %TRIMR(@SUB) + @PO
C EVAL @BODY = 'Buyer:'
C EVAL @BODY = %TRIMR(@BODY) + @BUYER
C EVAL @BODY = %TRIMR(@BODY) + '. Errors in PO: '
C EVAL @BODY = %TRIMR(@BODY) + @PO
C EVAL @BODY = %TRIMR(@BODY) + '. Unable to find'
C EVAL @BODY = %TRIMR(@BODY) + ' item(s) in cross'
C EVAL @BODY = %TRIMR(@BODY) + ' reference file'
C EVAL @BODY = %TRIMR(@BODY) + '. See attached file'
C EVAL @BODY = %TRIMR(@BODY) + '. For technical'
C EVAL @BODY = %TRIMR(@BODY) + ' issues contact'
C EVAL @BODY = %TRIMR(@BODY) + ' [email protected].'
C EVAL @BODY = %TRIMR(@BODY) + ' For order issues'
C P3Tpcd IFEQ 'XXXXV'
C EVAL @BODY = %TRIMR(@BODY) + ' contact XXXXXX.Xxx'
C EVAL @BODY = %TRIMR(@BODY) + '[email protected]'
C ENDIF
C P3Tpcd IFEQ 'XXXXA'
C EVAL @BODY = %TRIMR(@BODY) + ' contact Xxxx.Xxxxx'
C EVAL @BODY = %TRIMR(@BODY) + '[email protected]'
C ENDIF
C*
C END
C*
C P2Cdqd IFEQ 'ITEM'
C MOVEL P2CDST @ITEM
C END
C*
C*
C P2Cdqd IFEQ 'LINN'
C MOVEL P2CDST @LINN
C END
C*
C P2Cdqd IFEQ 'DESC'
C MOVEL P2CDST @DESC
C MOVEL *BLANKS @RCDD
C EVAL @RCDD = 'LINE NUMBER:'+@LINN+' ITEM:'+@ITEM
C EVAL @RCDD = %TRIMR(@RCDD) +' '+@DESC
C*
C*
C* Check to see if item exists in F4104. If item does not exist, move
C* 'Y' into @IND and @IND2
C*
C KeyF4104 CHAIN F4104 91
C *IN91 IFEQ *ON
C
C MOVEL 'Y' @IND
C MOVEL 'Y' @IND2
C END
C* MOVEL *BLANKS @CHECKP
C* MOVEL P2CDST @CHECKP
C
C* If @IND2 = 'Y', then write out record to *LIBL/EMAIL850
C*
C @IND2 IFEQ 'Y'
C CALL 'WRITEREC'
C PARM @RCDD
C PARM @TOFIL
C PARM @LIB
C MOVEL *BLANKS @IND2
C END
C*
C END
C*
C*
C P2Cdqd IFEQ 'SEND'
C @IND ANDEQ 'Y'
C*
C*
C* Create @FILEN - /EXTOL/ABCDCO/usedbyABCDococl.TXT
C MOVEL P3MSLN @P3MSLN 11
C EVAL @FILEN = 'ABCD' + @P3MSLN
C*
C* CALL CPYTOIMF to copy QTEMP/EMAIL850 to /extol/ABCDco/ABCDxxxxxxxxxxxxx
c Clear @@Cmd
c Eval @@Cmd = Command(4)
c Eval %Subst(@@Cmd:58:15) = @FILEN
c Eval %Subst(@@Cmd:80:80) = Command(5)
c Call 'QCMDEXC' QCmd 96
C
* Chain out to message class constant file
* PGM will retrieve all constant values from ADD1 thru ADD9
* Note: If > 9 ADDx constants are utilized, then increase size of @COUNT var
C MOVE 1 @COUNT 1 0
C MOVEL @COUNT @COUNTA 1
c Eval %Subst(@CONST:4:1) = @COUNTA
c KeyExmmtrl0 Chain Exmmtrl0 95
*
* If constants:ADDx exsist in respective message class
* Message class is determined by parms passed from extol, in long parm list
C DOW *in95 = *off
*
* Clear To-email address variable. Move MTCDAT from EXMMTRL0 to @TO var.
C CLEAR @EMAIL
C MOVEL MTCDAT @EMAIL
C*
C* Copy /EXTOL/ABCDCO/usedbyABCDococl.TXT to /extol
c Clear @@Cmd
c Eval @@Cmd = Command(3)
c Call 'QCMDEXC' QCmd 96
C*
C* Rename /EXTOL/usedbyABCDococl.TXT
c Clear @@Cmd
c Eval @@Cmd = Command(13)
c Eval @times = %timestamp
c Eval @timesa = %char(@times)
c Eval @timesa2= %Subst(@timesa:21:4) capture nanosecs
c Eval %Subst(@@Cmd:57:4) = @timesa2 Add time stamp
c Call 'QCMDEXC' QCmd 96
C*
C*
C* CALL EXEMAIL to copy QTEMP/EMAIL850 to /extol/ABCDco/ABCDxxxxxxxxxxxxx
c Clear @@Cmd
c Eval @@Cmd = Command(6)
c Eval %Subst(@@Cmd:37:4) = @timesa2 Add time stamp
c Eval %Subst(@@Cmd:54:35) = @EMAIL ADD EMAIL ADDRESS
c Eval %Subst(@@Cmd:91:73) = Command(7)
c Eval %Subst(@@Cmd:137:15) = @FILEN ADD FILENAME
c Eval %Subst(@@Cmd:160:61) = Command(8)
c Eval %Subst(@@Cmd:169:50) = @SUB ADD SUBJECT
c Eval %Subst(@@Cmd:223:89) = Command(9) ADD MSG1 LINE
c* Eval %Subst(@@Cmd:312:82) = Command(10) ADD MSG2 LINE
c* Eval %Subst(@@Cmd:232:160) = @BODY ADD BODY
c* Eval %Subst(@@Cmd:395:27) = Command(11) ADD FROM EMAIL
c Eval %Subst(@@Cmd:232:205) = @BODY ADD BODY
c Eval %Subst(@@Cmd:437:2) = Command(10) ADD MSG2 LINE
c Eval %Subst(@@Cmd:440:27) = Command(11) ADD FROM EMAIL
c Call 'QCMDEXC' QCmd 96
C*
C ADD 1 @COUNT
C MOVEL @COUNT @COUNTA 1
c Eval %Subst(@CONST:4:1) = @COUNTA
C*
C*
c KeyExmmtrl0 Chain Exmmtrl0 95
C enddo
*
* Clear To-email address variable. Move @EMILPO (from actual PO) to @TO var.
C CLEAR @EMAIL
C MOVEL @EMAILPO @EMAIL
C*
C* Copy /EXTOL/ABCDCO/usedbyABCDococl.TXT to /extol
c Clear @@Cmd
c Eval @@Cmd = Command(3)
c Call 'QCMDEXC' QCmd 96
C*
C* Rename /EXTOL/usedbyABCDococl.TXT
c Clear @@Cmd
c Eval @@Cmd = Command(13)
c Eval @times = %timestamp
c Eval @timesa = %char(@times)
c Eval @timesa2= %Subst(@timesa:21:4) capture nanosecs
c Eval %Subst(@@Cmd:57:4) = @timesa2 Add time stamp
c Call 'QCMDEXC' QCmd 96
C*
C* CALL EXEMAIL to copy QTEMP/EMAIL850 to /extol/ABCDco/ABCDxxxxxxxxxxxxx
c Clear @@Cmd
c Eval @@Cmd = Command(6)
c Eval %Subst(@@Cmd:37:4) = @timesa2 Add time stamp
c Eval %Subst(@@Cmd:54:35) = @EMAIL ADD EMAIL ADDRESS
c Eval %Subst(@@Cmd:91:73) = Command(7)
c Eval %Subst(@@Cmd:137:15) = @FILEN ADD FILENAME
c Eval %Subst(@@Cmd:160:61) = Command(8)
c Eval %Subst(@@Cmd:169:50) = @SUB ADD SUBJECT
c Eval %Subst(@@Cmd:223:89) = Command(9) ADD MSG1 LINE
c* Eval %Subst(@@Cmd:312:82) = Command(10) ADD MSG2 LINE
c* Eval %Subst(@@Cmd:232:160) = @BODY ADD BODY
c* Eval %Subst(@@Cmd:395:27) = Command(11) ADD FROM EMAIL
c Eval %Subst(@@Cmd:232:205) = @BODY ADD BODY
c Eval %Subst(@@Cmd:437:2) = Command(10) ADD MSG2 LINE
c Eval %Subst(@@Cmd:440:27) = Command(11) ADD FROM EMAIL
c Call 'QCMDEXC' QCmd 96
C*
C* Delete /extol/ABCDco/ABCDxxxxxxxxxxxxx
c Clear @@Cmd
c Eval @@Cmd = Command(12)
c Eval %Subst(@@Cmd:27:15) = @FILEN
c Call 'QCMDEXC' QCmd 96
C*
C ENDIF
C Enstlc Endsr
** Command Override DBF Array
DLTF FILE(QTEMP/EMAIL850)
CRTPF FILE(QTEMP/EMAIL850) RCDLEN(80)
CPY OBJ('/EXTOL/ABCDCO/usedbyABCDococl.TXT') TODIR('/EXTOL')
CPYTOIMPF FROMFILE(QTEMP/EMAIL850) TOSTMF('/EXTOL/ABCDCO/ABCD12345678901.txt')
MBROPT(*REPLACE) DTAFMT(*FIXED) STRDLM(*NONE) STRESCCHR(*NONE) RCDDLM(*CRLF)
EXEMAIL FILELINK('/extol/usedbyABCDococl.txt') TOADR( )
FROMADR([email protected]) ATTACH('/EXTOL/ABCDCO/ABCD12345678901.txt')
SUBJECT('&@SUB ')
MESSAGE('&@BODY ')
')
FROMNAME('ABCDEF EDI TEAM')
DEL OBJLNK('/EXTOL/ABCDCO/ABCD12345678901.txt')
REN OBJ('/extol/usedbyABCDococl.txt') NEWOBJ(usedbyABCDococl.txt)
