source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHLO4.m@ 1639

Last change on this file since 1639 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1PRCHLO4 ;WOIFO/RLL/DAP-EXTRACT ROUTINE CLO REPORT SERVER ; 10/16/06 2:10pm
2V ;;5.1;IFCAP;**83,98**; Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ; Continuation of PRCHLO3
5 ;
6 ; PRCHLO3 routines are used to Write out the Header and data
7 ; associated with each of the 19 tables created for the Clinical
8 ; logistics Report Server. The files are built from the extracts
9 ; located in the ^TMP($J) global.
10 ;
11 Q
12GETDIR ; Get directory from System parameter for CLRS
13 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
14 ;
15 Q
16CLRSFIL ; Create output files for CLRS
17 N FILEDIR
18 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
19 ; GET station id
20 N STID
21 ; S STID=$G(^DD("SITE",1)) Old call
22 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
23TSTFIL ; Test entry point
24 ;
25 D POMASTF ; Po Master Data
26 D POOBF ; Po Obligation Data
27 D POMETHF ; PO Method of Purchase Data
28 D PODISCF ; PO Discount Data
29 D POITMF ; Po Item Data
30 D POITIVF ; PO Item Inventory Point Data
31 D POITDRF ; PO Item Desc Data
32 D PODSCF ; PO Description
33 D POPRTF ; PO Partial Data
34 D PO2237F ; PO 2237 data
35 D POBOCF ; PO BOC Data
36 D POCOMF ; PO Comments data
37 D POREMF ; PO Remarks data
38 D POPPTF ; PO Prompt Payment Terms data
39 D POAMTF ; PO Amount data
40 D POAMDF ; PO Amendment Data
41 D POAMDCF ; PO Amendment Changes Data
42 D POAMDDF ; PO Amendment Description Data
43 D POAMBKF ; PO Amount Breakout Code Data
44GIPBL1 ; GIP REPORTS
45 D BLDGP1^PRCPLO3
46 D BLDGP2^PRCPLO3
47 Q
48POMASTF ; Save PO Master table data to a file to FTP to report Server
49 ; build file name
50 N OUTFIL1
51 S OUTFIL1="IFCP"_STID_"F1.TXT"
52 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL1,"W") ; Open the file
53 D USE^%ZISUTL("FILE1") ; Use the file as the output device
54 D POMASTH^PRCHLO3 ; Write the Header to the file
55 D POMASTW^PRCHLO3 ; Write the data to the file
56 D CLOSE^%ZISH("FILE1") ; Close the file
57 Q
58POOBF ; Create flat file for PO OBLIGATION DATA
59 N OUTFIL2
60 S OUTFIL2="IFCP"_STID_"F2.TXT"
61 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL2,"W") ; Open the file
62 D USE^%ZISUTL("FILE1") ; Use the file as the output device
63 D POOBHD^PRCHLO3
64 D POOBW^PRCHLO3
65 D CLOSE^%ZISH("FILE1") ; Close the file
66 Q
67POMETHF ; Create flat for for Purchase Order Method
68 N OUTFIL3
69 S OUTFIL3="IFCP"_STID_"F3.TXT"
70 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL3,"W") ; Open the file
71 D USE^%ZISUTL("FILE1") ; Use the file as the output device
72 D POPMEH^PRCHLO3
73 D POPMEW^PRCHLO3
74 D CLOSE^%ZISH("FILE1") ; Close the file
75 Q
76PODISCF ; Create flat file for Purchase Order Discount
77 N OUTFIL4
78 S OUTFIL4="IFCP"_STID_"F4.TXT"
79 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL4,"W") ; Open the file
80 D USE^%ZISUTL("FILE1")
81 D PODISCH^PRCHLO1
82 D PODISCW^PRCHLO1
83 D CLOSE^%ZISH("FILE1")
84 Q
85POITMF ; Create flat file for PO Item data
86 N OUTFIL5
87 S OUTFIL5="IFCP"_STID_"F5.TXT"
88 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL5,"W") ; Open the file
89 D USE^%ZISUTL("FILE1")
90 D POITEMH^PRCHLO2
91 D POITEMW^PRCHLO2
92 D CLOSE^%ZISH("FILE1")
93 Q
94POITIVF ; Create flat file for PO Item inv. point data
95 N OUTFIL6
96 S OUTFIL6="IFCP"_STID_"F6.TXT"
97 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL6,"W") ; Open the file
98 D USE^%ZISUTL("FILE1")
99 D POITLNH^PRCHLO2
100 D POITLNW^PRCHLO2
101 D CLOSE^%ZISH("FILE1")
102 Q
103POITDRF ; Create flat file for PO Item date received
104 N OUTFIL7
105 S OUTFIL7="IFCP"_STID_"F7.TXT"
106 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL7,"W") ; Open the file
107 D USE^%ZISUTL("FILE1")
108 D POITDRCH^PRCHLO2
109 D POITDRCW^PRCHLO2
110 D CLOSE^%ZISH("FILE1")
111 Q
112PODSCF ; Create flat file for PO item description
113 N OUTFIL8
114 S OUTFIL8="IFCP"_STID_"F8.TXT"
115 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL8,"W") ; Open the file
116 D USE^%ZISUTL("FILE1")
117 D POITDSH^PRCHLO2
118 D POITDSW^PRCHLO2
119 D CLOSE^%ZISH("FILE1")
120 Q
121POPRTF ; Create flat file for PO Partial data
122 N OUTFIL9
123 S OUTFIL9="IFCP"_STID_"F9.TXT"
124 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL9,"W") ; Open the file
125 D USE^%ZISUTL("FILE1")
126 D POPART^PRCHLO3
127 D POPARTW^PRCHLO3
128 D CLOSE^%ZISH("FILE1")
129 Q
130PO2237F ; Create flat file for 2237 data
131 N OUTFIL10
132 S OUTFIL10="IFCP"_STID_"F10.TXT"
133 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL10,"W") ; Open the file
134 D USE^%ZISUTL("FILE1")
135 D PO2237H^PRCHLO3
136 D PO2237W^PRCHLO3
137 D CLOSE^%ZISH("FILE1")
138 Q
139POBOCF ; Create flat file for PO BOC data
140 N OUTFIL11
141 S OUTFIL11="IFCP"_STID_"F11.TXT"
142 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL11,"W")
143 D USE^%ZISUTL("FILE1")
144 D POBOCH^PRCHLO3
145 D POBOCW^PRCHLO3
146 D CLOSE^%ZISH("FILE1")
147 Q
148POCOMF ; Create flat file for PO Comments
149 N OUTFIL12
150 S OUTFIL12="IFCP"_STID_"F12.TXT"
151 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL12,"W")
152 D USE^%ZISUTL("FILE1")
153 D POCMTSH^PRCHLO3
154 D POCMTSW^PRCHLO3
155 D CLOSE^%ZISH("FILE1")
156 Q
157POREMF ; Create flat file for PO Remarks
158 N OUTFIL13
159 S OUTFIL13="IFCP"_STID_"F13.TXT"
160 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL13,"W")
161 D USE^%ZISUTL("FILE1")
162 D PORMKH^PRCHLO3
163 D PORMKW^PRCHLO3
164 D CLOSE^%ZISH("FILE1")
165 Q
166POPPTF ; Create flat file for PO Prompt payment terms data
167 N OUTFIL14
168 S OUTFIL14="IFCP"_STID_"F14.TXT"
169 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL14,"W")
170 D USE^%ZISUTL("FILE1")
171 D POPPTH^PRCHLO3
172 D POPPTW^PRCHLO3
173 D CLOSE^%ZISH("FILE1")
174 Q
175POAMTF ; Create flat file for PO Amount data
176 N OUTFIL15
177 S OUTFIL15="IFCP"_STID_"F15.TXT"
178 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL15,"W")
179 D USE^%ZISUTL("FILE1")
180 D POAMTH^PRCHLO3
181 D POAMTW^PRCHLO3
182 D CLOSE^%ZISH("FILE1")
183 Q
184POAMDF ; Create flat file for PO Amendment data
185 N OUTFIL16
186 S OUTFIL16="IFCP"_STID_"F16.TXT"
187 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL16,"W")
188 D USE^%ZISUTL("FILE1")
189 D POAMDH^PRCHLO3
190 D POAMDW^PRCHLO3
191 D CLOSE^%ZISH("FILE1")
192 Q
193POAMDCF ; Create flat file for PO Amendment changes
194 N OUTFIL17
195 S OUTFIL17="IFCP"_STID_"F17.TXT"
196 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL17,"W")
197 D USE^%ZISUTL("FILE1")
198 D POAMDCH^PRCHLO3
199 D POAMDCW^PRCHLO3
200 D CLOSE^%ZISH("FILE1")
201 Q
202POAMDDF ; Create flat file for PO Amendment Desc data
203 N OUTFIL18
204 S OUTFIL18="IFCP"_STID_"F18.TXT"
205 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL18,"W")
206 D USE^%ZISUTL("FILE1")
207 D PAMDDH^PRCHLO3
208 D PAMDDW^PRCHLO3
209 D CLOSE^%ZISH("FILE1")
210 Q
211POAMBKF ; Create flat file for PO amount breakout code
212 N OUTFIL19
213 S OUTFIL19="IFCP"_STID_"F19.TXT"
214 D OPEN^%ZISH("FILE1",FILEDIR,OUTFIL19,"W")
215 D USE^%ZISUTL("FILE1")
216 D PAMTBKH^PRCHLO3
217 D PAMTBKW^PRCHLO3
218 D CLOSE^%ZISH("FILE1")
219 Q
220TSTF ; Test directory for file creation
221 N FILEDIR,TFILE,OUTFILT,POP,STID
222 ; POP is returned by OPEN^%ZISH if file cannot be created.
223 S POP=""
224 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
225 S OUTFILT="CLRSREADME"_STID_".TXT"
226 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
227 D OPEN^%ZISH("TFILE",FILEDIR,OUTFILT,"W")
228 I POP D
229 . S CLRSERR=2
230 . Q
231 I CLRSERR'=2 D
232 . D USE^%ZISUTL("TFILE")
233 . W !,"$ ! This directory is used to store PO activity"
234 . W !,"$ ! extracts and GIP Extracts which are transmitted"
235 . W !,"$ ! to the Clinical Logistics Report Server on a monthly"
236 . W !,"$ ! basis. There are 21 extract files IFCPXXXF1 through"
237 . W !,"$ ! IFCPXXXF19, IFCPXXXG1 and IFCPXXXG2. In addition, there"
238 . W !,"$ ! are 2 working files used for the FTP Transfer:"
239 . W !,"$ ! CLRSxxx.DAT and CLRS1xxx.COM. CLRSREADMExxx.TXT is also present"
240 . W !,"$ EXIT"
241 . D CLOSE^%ZISH("TFILE")
242 . Q
243 Q
244 ;
245CRTCOM ; Create .DAT file to transfer file(s)
246 N FILEDIR,POP,STID,OUTFLL1
247 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
248 S POP="" ; POP is returned by OPEN^%ZISH
249 ; S FILEDIR="$1$DGA2:[ANONYMOUS.CLRS]" ;set dir for outpt files.
250 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
251 S OUTFLL1="CLRS"_STID_"FTP.DAT"
252 D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
253 I POP D
254 . S CLRSERR=3
255 . Q
256 I CLRSERR'=3 D
257 . D USE^%ZISUTL("FILE1")
258 . W "clrsadmin",! ; Enter user name for Report Server Login
259 . W "1025clrs",! ;pw=1025clrs Enter P/W for Report Server Login
260 . ; W "SET DEFAULT /LOCAL $1$DGA2:[ANONYMOUS.CLRS]",!
261 . W "SET DEFAULT /LOCAL "_FILEDIR,!
262 . W "PUT IFCP"_STID_"*.*;*",! ; new code to issue PUT command
263 . W "EXIT",! ; Exit FTP
264 . D CLOSE^%ZISH("FILE1")
265 . Q
266 Q
267CRTCOM1 ; Run CLRSFTP1.COM as com file for exception handling
268 ;
269 ;*98 Modified code to work with PRC CLRS ADDRESS parameter
270 ;
271 N FILEDIR,STID,OUTFLL2,ADDR
272 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
273 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
274 S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
275 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
276 S OUTFLL2="CLRS"_STID_"FTP1.COM"
277 D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
278 D USE^%ZISUTL("FILE1")
279 W "$ SET VERIFY=(PROCEDURE,IMAGE)",!
280 W "$ SET DEFAULT "_FILEDIR,!
281 W "$ FTP "_ADDR_" /INPUT="_FILEDIR_"CLRS"_STID_"FTP.DAT",!
282 ;
283 W "$ EXIT 3",!
284 D CLOSE^%ZISH("FILE1")
285 Q
286FTPCOM ; Issue the FTP command after CLRS1.TXT file is built
287 ; remain in CACHE during FTP Process using
288 ; $ZF(-1) call
289 ; ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
290 ; See IFCAP technical manual
291 ;
292 ; commented out for testing
293 ; add hook to mailman messaging for ftp, check variable PV
294 N PV,XPV1,FILEDIR,STID
295 ;
296 ;
297 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
298 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
299 S XPV1="S PV=$ZF(-1,""@"_FILEDIR_"CLRS"_STID_"FTP1.COM/OUTPUT="_FILEDIR_"CLRS"_STID_"FTP1.LOG"")"
300 X XPV1 ; Run the .COM file to transfer files
301 ;
302 ; Error flag logic
303 I PV=-1 D ; This error is generated if failure during xfer occurs
304 . S CLRSERR=1
305 . Q
306 Q
Note: See TracBrowser for help on using the repository browser.