RPGLE - Program writes to
source physical file then uses CPYTOSTMF
|
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*=============================================================
|
Subscribe to:
Post Comments
(
Atom
)
No comments