RPGLE - Program writes to source physical file then uses CPYTOSTMF
F*
FZZPOOUTD CF E WORKSTN
F*
FSOURCE O E DISK Rename(SOURCE:FMT1) Prefix(X)
F UsrOpn
FSRBPOH IF E K DISK
FSRBPOL IF E K DISK
FSRBPRG IF E K DISK
FXABMAIL IF E K DISK
F*
D*=======================================================
D* Commands for QCMDEXC
D*=======================================================
D*
D* CLRPFM FILE(QGPL/SOURCE) MBR(XXXX)
D*
D CLRPFM DS
D Text1 1 25 Inz('CLRPFM FILE(QGPL/SOURCE) ')
D Text2 26 31 Inz(' MBR(')
D Member1 32 42
D*
D* CRTSRCPF FILE(QGPL/SOURCE) RCDLEN(112) MBR(XXXX)
D*
D CRTSRCPF DS
D Text2A 1 27 Inz('CRTSRCPF FILE(QGPL/SOURCE)')
D Text2B 28 44 Inz(' RCDLEN(112) MBR(')
D Member2 45 55
D*
D* ADDPFM FILE(QGPL/SOURCE) MBR(JAMIEF)
D*
D ADDPFM DS
D Text2C 1 29 Inz('ADDPFM FILE(QGPL/SOURCE) MBR(')
D Member3 30 41
D*
D* OVRDBF FILE(MODELS) TOFILE(QGPL/SOURCE) MBR(XXXX)
D*
D OVRDBF DS
D Text3 1 27 Inz('OVRDBF FILE(SOURCE) TOFILE')
D Text4 27 44 Inz('(QGPL/SOURCE) MBR(')
D Member4 45 55
D*
D* CPYTOSTMF FROMMBR('/QSYS.LIB/QGPL.LIB/SOURCE.FILE/OUTP.MBR')
D* TOSTMF('/RJAPO/%%%%%%%%%%/#########.###')
D* STMFOPT(*REPLACE)
D*
D CPYTOSTMF DS
D Text5 1 25 Inz('CPYTOSTMF FROMMBR(''/QSYS')
D Text6 25 44 Inz('.LIB/QGPL.LIB/SOURCE')
D Text7 45 50 Inz('.FILE/')
D Member5 51 70
D Text8 71 79 Inz(' TOSTMF(''')
D TheRest 80 256
D*
D* del 'RJAPO/&USER/#######.###'
D*
D DEL DS
D Text13 1 11 Inz('Del ''RJAPO/')
D TheRest2 12 256
D*
D*
D MD DS
D Text14 1 11 Inz('md ''RJAPO/')
D Directory 11 40
D*
D ADDLIBLE DS
D Text15 1 22 Inz('addlible busintl *Last')
D*
D ISODate S D
D InPO S 7
D DecPO S 7 0
D*
D Str S 3 0
D End S 4 0
D Len S 4 0
D Count S 4 0
D Loop S 4 0
D #Fnd S 4 0
D InCode S 10
D @Scrn1 S 01 Inz('Y')
D CURRENTMO S 2 0
D X S 2 0
D Dec12 S 12 0
D Chr12 S 12
D OutDsm S 03 Inz('HAN')
D OutAddress S 40
D OutLoc S 50
D Name S 09
D Chr1 S 01
D ScreenError S 1
D MONTH S 2
D CURRENTYR S 4 0
D YEAR S 4
D PYear1 S 4
D PYear2 S 4
D PYear3 S 4
D FlagNo S 1 Inz('N')
D CmdString S 256
D CmdLength S 15 5
D*
D* Program Info
D*
D SDS
D @PGM 001 010
D @PARMS 037 039 0
D @JOB 244 253
D @USER 254 263
D @JOB# 264 269 0
C*============================================================
C* M A I N L I N E
C*============================================================
C*
C @User Chain XABMAIL
C If %Found(XABMAIL)
C Eval W1EMAIL = %Trim(W1EMAIL) +
C %trim(XAEADR) +
C %trim('@Code400.com')
C Else
C Eval W1EMAIL = 'SomeOne@Code400.com'
C Endif
C*
C Reset @Scrn1
C*
C Dow @Scrn1 = 'Y'
C Exfmt WIN1
C Select
C When *In03 Or *In12
C Clear @Scrn1
C Other
C*
C Exsr $Valid
C If ScreenError = *Blanks
C Exsr $ReadIt
C Exsr $Email
C Eval W1MSG = 'File sent to Folder & Emailed'
C Clear W1PO
C Endif
C*
C Endsl
C Enddo
C Eval *INLR = *On
C*=============================================================
C* $ReadIt - Read the PO data
C*=============================================================
CSR $ReadIt Begsr
C*
C Exsr $Open
C*
C Move W1PO DecPO
C PoKey01 Chain SRBPOH
C If %Found(SRBPOH)
C PoKey01 Setll SRBPOL
C PoKey01 Reade SRBPOL
C Dow Not%Eof(SRBPOL)
C*
C If OLSTAT <> 'D'
C*
C Z-add OLOQTY Dec12
C Move Dec12 Chr12
C*
C Do 12 X
C Eval Chr1 = %Subst(Chr12:X:1)
C If Chr1 <> '0'
C Leave
C Endif
C Enddo
C*
C OLPRDC Chain SRBPRG
C If %Found(SRBPRG)
C*
C Eval XSRCDTA = %Trim(XSRCDTA) +
C %Trim('"') + %Trim(PGPRDCS2) +
C %Trim('",')
C + %Trim(%Subst(Chr12:X))
C*
C Write FMT1
C Clear XSRCDTA
C*
C Endif
C Endif
C*
C PoKey01 Reade SRBPOL
C Enddo
C Endif
C*
C EXSR $StreamIt
C Endsr
C*
C*=============================================================
C* $Open - reset the overides for each DSM to build
C*=============================================================
CSR $Open Begsr
C*
C* Setup member name(s)
C*
C Eval Member1 = %Trim(NAME) + %Trim(')')
C Eval Member2 = %Trim(NAME) + %Trim(')')
C Eval Member3 = %Trim(NAME) + %Trim(')')
C Eval Member4 = %Trim(NAME) + %Trim(')')
C Eval Member5 = %Trim(NAME) + %Trim('.MBR/'')' )
C*
C If %Open(SOURCE)
C Close SOURCE
C Endif
C*
C*
C* Clear the source file and do data base override
C*
C Movel(p) CRTSRCPF CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C* Add member that is the name
C*
C Movel(p) ADDPFM CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C Movel(p) CLRPFM CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C Movel(p) OVRDBF CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C If Not%Open(SOURCE)
C Open SOURCE
C Endif
C*
C* Create the IFS folder by user profile
C*
C Eval Directory = %Trim(name) +
C %Trim('''')
C Movel(p) MD CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C Endsr
C*
C*=============================================================
C* $StreamIt - Streamfile the data.
C*=============================================================
C $StreamIt Begsr
C*
C If %Open(SOURCE)
C Close SOURCE
C Endif
C*
C*
C* Delete old one by same PO Number
C*
C Eval TheRest2 = %Trim(NAME)
C +%Trim('/') + %Trim('PO') +
C %Trim(W1PO) + %Trim('.csv')
C + %Trim('''')
C*
C Movel(p) DEL CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C* Build the stream file command 'RJAPO/&USER/#######.###'
C*
C*
C Eval TheRest = %Trim('RJAPO/') +
C %Trim(NAME) +
C %Trim('/') +
C %Trim('PO') + %Trim(W1PO) +
C %Trim('.csv') + %Trim(''')')
C + ' STMFOPT(*REPLACE)'
C + ' STMFCODPAG(*PCASCII)'
C*
C Eval OutLoc =
C %Trim('RJAPO/') +
C %Trim(NAME) +
C %Trim('/') +
C %Trim('PO') + %Trim(W1PO) +
C %Trim('.csv')
C*
C Movel(p) CPYTOSTMF CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C*
C Endsr
C*=============================================================
C* $Valid - Check screen entries
C*=============================================================
CSR $Valid Begsr
C*
C Clear ScreenError
C Clear W1MSG
C*
C If W1PO = *Blanks Or W1PO = '0000000'
C Eval W1MSG = 'Invalid PO Entered.'
C Eval ScreenError = 'Y'
C Else
C Move W1PO DecPO
C PoKey01 Chain SRBPOH
C If Not%Found(SRBPOH)
C Eval W1MSG = 'Invalid PO Entered.'
C Eval ScreenError = 'Y'
C Endif
C Endif
C*
C Eval Name = %Trim('PO') + %Trim(W1PO)
C*
C Endsr
C*
C*=============================================================
C* $Email - Email this to someone
C*=============================================================
CSR $Email Begsr
C*
C Call 'BICTL02C'
C Parm OutDsm
C Parm W1Email OutAddress
C Parm OutLoc
C*
C Endsr
C*=============================================================
C* *Inzsr - Initial one time run subroutine.
C*=============================================================
C *Inzsr Begsr
C*
C*
C* Klist(s)
C*
C PoKey01 Klist
C Kfld FlagNo
C Kfld DecPO
C*
C *MDY Move UDATE ISODate
C*
C Movel(p) ADDLIBLE CmdString
C Eval Len = %Len(%Trim(CmdString))
C Call 'QCMDEXC' 99
C Parm CmdString
C Parm Len CmdLength
C*
C Endsr
C*=============================================================
No comments:
Post a Comment