307 lines
9.2 KiB
Mathematica
307 lines
9.2 KiB
Mathematica
PRCHLO4 ;WOIFO/RLL/DAP-EXTRACT ROUTINE CLO REPORT SERVER ; 10/16/06 2:10pm
|
|
V ;;5.1;IFCAP;**83,98**; Oct 20, 2000;Build 37
|
|
;Per VHA Directive 2004-038, this routine should not be modified.
|
|
; Continuation of PRCHLO3
|
|
;
|
|
; PRCHLO3 routines are used to Write out the Header and data
|
|
; associated with each of the 19 tables created for the Clinical
|
|
; logistics Report Server. The files are built from the extracts
|
|
; located in the ^TMP($J) global.
|
|
;
|
|
Q
|
|
GETDIR ; Get directory from System parameter for CLRS
|
|
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
|
|
;
|
|
Q
|
|
CLRSFIL ; Create output files for CLRS
|
|
N FILEDIR
|
|
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
|
|
; GET station id
|
|
N STID
|
|
; S STID=$G(^DD("SITE",1)) Old call
|
|
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
|
|
TSTFIL ; Test entry point
|
|
;
|
|
D POMASTF ; Po Master Data
|
|
D POOBF ; Po Obligation Data
|
|
D POMETHF ; PO Method of Purchase Data
|
|
D PODISCF ; PO Discount Data
|
|
D POITMF ; Po Item Data
|
|
D POITIVF ; PO Item Inventory Point Data
|
|
D POITDRF ; PO Item Desc Data
|
|
D PODSCF ; PO Description
|
|
D POPRTF ; PO Partial Data
|
|
D PO2237F ; PO 2237 data
|
|
D POBOCF ; PO BOC Data
|
|
D POCOMF ; PO Comments data
|
|
D POREMF ; PO Remarks data
|
|
D POPPTF ; PO Prompt Payment Terms data
|
|
D POAMTF ; PO Amount data
|
|
D POAMDF ; PO Amendment Data
|
|
D POAMDCF ; PO Amendment Changes Data
|
|
D POAMDDF ; PO Amendment Description Data
|
|
D POAMBKF ; PO Amount Breakout Code Data
|
|
GIPBL1 ; GIP REPORTS
|
|
D BLDGP1^PRCPLO3
|
|
D BLDGP2^PRCPLO3
|
|
Q
|
|
POMASTF ; Save PO Master table data to a file to FTP to report Server
|
|
; build file name
|
|
N OUTFIL1
|
|
S OUTFIL1="IFCP"_STID_"F1.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL1,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1") ; Use the file as the output device
|
|
D POMASTH^PRCHLO3 ; Write the Header to the file
|
|
D POMASTW^PRCHLO3 ; Write the data to the file
|
|
D CLOSE^%ZISH("FILE1") ; Close the file
|
|
Q
|
|
POOBF ; Create flat file for PO OBLIGATION DATA
|
|
N OUTFIL2
|
|
S OUTFIL2="IFCP"_STID_"F2.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL2,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1") ; Use the file as the output device
|
|
D POOBHD^PRCHLO3
|
|
D POOBW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1") ; Close the file
|
|
Q
|
|
POMETHF ; Create flat for for Purchase Order Method
|
|
N OUTFIL3
|
|
S OUTFIL3="IFCP"_STID_"F3.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL3,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1") ; Use the file as the output device
|
|
D POPMEH^PRCHLO3
|
|
D POPMEW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1") ; Close the file
|
|
Q
|
|
PODISCF ; Create flat file for Purchase Order Discount
|
|
N OUTFIL4
|
|
S OUTFIL4="IFCP"_STID_"F4.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL4,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1")
|
|
D PODISCH^PRCHLO1
|
|
D PODISCW^PRCHLO1
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POITMF ; Create flat file for PO Item data
|
|
N OUTFIL5
|
|
S OUTFIL5="IFCP"_STID_"F5.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL5,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1")
|
|
D POITEMH^PRCHLO2
|
|
D POITEMW^PRCHLO2
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POITIVF ; Create flat file for PO Item inv. point data
|
|
N OUTFIL6
|
|
S OUTFIL6="IFCP"_STID_"F6.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL6,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1")
|
|
D POITLNH^PRCHLO2
|
|
D POITLNW^PRCHLO2
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POITDRF ; Create flat file for PO Item date received
|
|
N OUTFIL7
|
|
S OUTFIL7="IFCP"_STID_"F7.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL7,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1")
|
|
D POITDRCH^PRCHLO2
|
|
D POITDRCW^PRCHLO2
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
PODSCF ; Create flat file for PO item description
|
|
N OUTFIL8
|
|
S OUTFIL8="IFCP"_STID_"F8.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL8,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1")
|
|
D POITDSH^PRCHLO2
|
|
D POITDSW^PRCHLO2
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POPRTF ; Create flat file for PO Partial data
|
|
N OUTFIL9
|
|
S OUTFIL9="IFCP"_STID_"F9.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL9,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1")
|
|
D POPART^PRCHLO3
|
|
D POPARTW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
PO2237F ; Create flat file for 2237 data
|
|
N OUTFIL10
|
|
S OUTFIL10="IFCP"_STID_"F10.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL10,"W") ; Open the file
|
|
D USE^%ZISUTL("FILE1")
|
|
D PO2237H^PRCHLO3
|
|
D PO2237W^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POBOCF ; Create flat file for PO BOC data
|
|
N OUTFIL11
|
|
S OUTFIL11="IFCP"_STID_"F11.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL11,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D POBOCH^PRCHLO3
|
|
D POBOCW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POCOMF ; Create flat file for PO Comments
|
|
N OUTFIL12
|
|
S OUTFIL12="IFCP"_STID_"F12.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL12,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D POCMTSH^PRCHLO3
|
|
D POCMTSW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POREMF ; Create flat file for PO Remarks
|
|
N OUTFIL13
|
|
S OUTFIL13="IFCP"_STID_"F13.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL13,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D PORMKH^PRCHLO3
|
|
D PORMKW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POPPTF ; Create flat file for PO Prompt payment terms data
|
|
N OUTFIL14
|
|
S OUTFIL14="IFCP"_STID_"F14.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL14,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D POPPTH^PRCHLO3
|
|
D POPPTW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POAMTF ; Create flat file for PO Amount data
|
|
N OUTFIL15
|
|
S OUTFIL15="IFCP"_STID_"F15.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL15,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D POAMTH^PRCHLO3
|
|
D POAMTW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POAMDF ; Create flat file for PO Amendment data
|
|
N OUTFIL16
|
|
S OUTFIL16="IFCP"_STID_"F16.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL16,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D POAMDH^PRCHLO3
|
|
D POAMDW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POAMDCF ; Create flat file for PO Amendment changes
|
|
N OUTFIL17
|
|
S OUTFIL17="IFCP"_STID_"F17.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL17,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D POAMDCH^PRCHLO3
|
|
D POAMDCW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POAMDDF ; Create flat file for PO Amendment Desc data
|
|
N OUTFIL18
|
|
S OUTFIL18="IFCP"_STID_"F18.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL18,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D PAMDDH^PRCHLO3
|
|
D PAMDDW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
POAMBKF ; Create flat file for PO amount breakout code
|
|
N OUTFIL19
|
|
S OUTFIL19="IFCP"_STID_"F19.TXT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL19,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
D PAMTBKH^PRCHLO3
|
|
D PAMTBKW^PRCHLO3
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
TSTF ; Test directory for file creation
|
|
N FILEDIR,TFILE,OUTFILT,POP,STID
|
|
; POP is returned by OPEN^%ZISH if file cannot be created.
|
|
S POP=""
|
|
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
|
|
S OUTFILT="CLRSREADME"_STID_".TXT"
|
|
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
|
|
D OPEN^%ZISH("TFILE",FILEDIR,OUTFILT,"W")
|
|
I POP D
|
|
. S CLRSERR=2
|
|
. Q
|
|
I CLRSERR'=2 D
|
|
. D USE^%ZISUTL("TFILE")
|
|
. W !,"$ ! This directory is used to store PO activity"
|
|
. W !,"$ ! extracts and GIP Extracts which are transmitted"
|
|
. W !,"$ ! to the Clinical Logistics Report Server on a monthly"
|
|
. W !,"$ ! basis. There are 21 extract files IFCPXXXF1 through"
|
|
. W !,"$ ! IFCPXXXF19, IFCPXXXG1 and IFCPXXXG2. In addition, there"
|
|
. W !,"$ ! are 2 working files used for the FTP Transfer:"
|
|
. W !,"$ ! CLRSxxx.DAT and CLRS1xxx.COM. CLRSREADMExxx.TXT is also present"
|
|
. W !,"$ EXIT"
|
|
. D CLOSE^%ZISH("TFILE")
|
|
. Q
|
|
Q
|
|
;
|
|
CRTCOM ; Create .DAT file to transfer file(s)
|
|
N FILEDIR,POP,STID,OUTFLL1
|
|
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
|
|
S POP="" ; POP is returned by OPEN^%ZISH
|
|
; S FILEDIR="$1$DGA2:[ANONYMOUS.CLRS]" ;set dir for outpt files.
|
|
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
|
|
S OUTFLL1="CLRS"_STID_"FTP.DAT"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
|
|
I POP D
|
|
. S CLRSERR=3
|
|
. Q
|
|
I CLRSERR'=3 D
|
|
. D USE^%ZISUTL("FILE1")
|
|
. W "clrsadmin",! ; Enter user name for Report Server Login
|
|
. W "1025clrs",! ;pw=1025clrs Enter P/W for Report Server Login
|
|
. ; W "SET DEFAULT /LOCAL $1$DGA2:[ANONYMOUS.CLRS]",!
|
|
. W "SET DEFAULT /LOCAL "_FILEDIR,!
|
|
. W "PUT IFCP"_STID_"*.*;*",! ; new code to issue PUT command
|
|
. W "EXIT",! ; Exit FTP
|
|
. D CLOSE^%ZISH("FILE1")
|
|
. Q
|
|
Q
|
|
CRTCOM1 ; Run CLRSFTP1.COM as com file for exception handling
|
|
;
|
|
;*98 Modified code to work with PRC CLRS ADDRESS parameter
|
|
;
|
|
N FILEDIR,STID,OUTFLL2,ADDR
|
|
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
|
|
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
|
|
S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
|
|
I ADDR="" S PRCPMSG(1)="There is no address identified in the CLRS Address Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP^PRCHLO4A S CLRSERR=1 Q
|
|
S OUTFLL2="CLRS"_STID_"FTP1.COM"
|
|
D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
|
|
D USE^%ZISUTL("FILE1")
|
|
W "$ SET VERIFY=(PROCEDURE,IMAGE)",!
|
|
W "$ SET DEFAULT "_FILEDIR,!
|
|
W "$ FTP "_ADDR_" /INPUT="_FILEDIR_"CLRS"_STID_"FTP.DAT",!
|
|
;
|
|
W "$ EXIT 3",!
|
|
D CLOSE^%ZISH("FILE1")
|
|
Q
|
|
FTPCOM ; Issue the FTP command after CLRS1.TXT file is built
|
|
; remain in CACHE during FTP Process using
|
|
; $ZF(-1) call
|
|
; ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
|
|
; See IFCAP technical manual
|
|
;
|
|
; commented out for testing
|
|
; add hook to mailman messaging for ftp, check variable PV
|
|
N PV,XPV1,FILEDIR,STID
|
|
;
|
|
;
|
|
S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
|
|
S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
|
|
S XPV1="S PV=$ZF(-1,""@"_FILEDIR_"CLRS"_STID_"FTP1.COM/OUTPUT="_FILEDIR_"CLRS"_STID_"FTP1.LOG"")"
|
|
X XPV1 ; Run the .COM file to transfer files
|
|
;
|
|
; Error flag logic
|
|
I PV=-1 D ; This error is generated if failure during xfer occurs
|
|
. S CLRSERR=1
|
|
. Q
|
|
Q
|