Send email if customer item in JDE Table F4104 does not exsist

EXTOL RPGLE - 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:'[email protected]+' ITEM:'[email protected]
     C                   EVAL      @RCDD = %TRIMR(@RCDD) +' '[email protected]
     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)

By: on