VistA-WorldVistAEHR/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHLO4.m

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