source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHLO4A.m@ 1582

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1PRCHLO4A ;WOIFO/RLL/DAP-EXTRACT ROUTINE CLO REPORT SERVER ; 9/26/06 11:33am
2V ;;5.1;IFCAP;**83,104,98**; Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ; Continuation of PRCHLO4
5 ;
6 ; PRCHLO4A routines are used to Write out the Header and data
7 ;
8 Q
9GETDIR ; Get directory from PRCPLO EXTRACT DIRECTORY system parameter for CLRS
10 N FILEDIR,STID
11 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
12 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
13 ;
14 Q
15 ;
16CRTWIN ; Create CLRSxxxWFTP.TXT file to transfer file(s)
17 ;*98 Modified to work with PRC CLRS ADDRESS parameter
18 N FILEDIR,POP,STID,OUTFLL1,ADDR
19 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
20 S POP="" ; POP is returned by OPEN^%ZISH
21 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
22 ; RLL/PRC*5.1*104 change logic to create separate FTP
23 ; transfer files (1 for each file for Windows/Cache)
24 S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
25 I ADDR="" S PRCPMSG(1)="There is no address identified in the CLRS Adress Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
26 ;
27 I CLRSERR'=3 D
28 . N PONN ; File number for File type
29 . S PONN=1
30 . F PONN=1:1:19 D
31 . . N FTY ; File type F=Po Activity , G=GIP
32 . . ;
33 . . S FTY="F"
34 . . S OUTFLL1="CLRS"_STID_FTY_PONN_"WFTP.TXT"
35 . . D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
36 . . I POP D
37 . . . S CLRSERR=3
38 . . . Q
39 . . D USE^%ZISUTL("FILE1")
40 . . D BLDF1
41 . . D CLOSE^%ZISH("FILE1")
42 . . Q
43 . Q
44 ;
45 I CLRSERR'=3 D
46 . ; RLL/PRC*5.1*104 change logic to create separate FTP
47 . ; tranfer files (1 for each file for Windows/Cache)
48 . N PONN ; File number for file type
49 . S PONN=1
50 . F PONN=1:1:2 D
51 . . N FTY ; File type F=Po Activity , G=GIP
52 . . S FTY="G"
53 . . S OUTFLL1="CLRS"_STID_FTY_PONN_"WFTP.TXT"
54 . . D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL1,"W")
55 . . I POP D
56 . . . S CLRSERR=3
57 . . . Q
58 . . D USE^%ZISUTL("FILE1")
59 . . D BLDF1
60 . . D CLOSE^%ZISH("FILE1")
61 . . Q
62 . Q
63 Q
64BLDF1 ; RLL/PRC*5.1*104 added logic to create separate FTP
65 ; transfers (1 for each file)
66 ;
67 W "open "_ADDR,! ;Connect to the Report Server
68 W "clrsadmin",! ; Enter user name for Report Server Login
69 W "1025clrs",! ;pw=1025clrs Enter P/W for Report Server Login
70 W "PUT "_FILEDIR_"IFCP"_STID_FTY_PONN_".TXT",!
71 W "bye",! ; Exit FTP
72 ;
73 Q
74CKRPTSV ; Check for availability of report server
75 ; Several steps need to be performed
76 ; 1. Set up script to perform PING
77 ; 2. Capture log file during PING
78 ; 3. Read logfile into working global
79 ; 4. Determine Success/Failure of PING to server
80 ; 5. If successful, continue processing (CLRSERR=0)
81 ; 6. If problem occurs, S CLRSERR=3 and generate message
82 ;
83 I CKOS["VMS" D VMSPING ; CKOS set in PRCHLO5
84 I CKOS["NT" D WINPING ; CKOS set in PRCHLO5
85 Q
86VMSPING ; need to PING report server to make sure it is available
87 ;
88 ; 1. Create .COM file to execute
89 ;*98 Modified to work with PRC CLRS ADDRESS parameter
90 N FILEDIR,STID,OUTFLL2,ADDR
91 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
92 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
93 S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
94 I ADDR="" S PRCPMSG(1)="There is no address identified in the CLRS Address Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
95 ;
96 S OUTFLL2="CLRS"_STID_"PING.COM"
97 D OPEN^%ZISH("FILE1",FILEDIR,OUTFLL2,"W")
98 D USE^%ZISUTL("FILE1")
99 W "$ SET VERIFY=(PROCEDURE,IMAGE)",!
100 W "$ SET DEFAULT "_FILEDIR,!
101 W "$ TCPIP",!
102 W "PING "_ADDR,!
103 W "EXIT",!
104 W "$ EXIT 3",!
105 D CLOSE^%ZISH("FILE1")
106 ;
107 ; 2. Execute .COM file, create logfile
108 S XPV1="S PV=$ZF(-1,""@"_FILEDIR_"CLRS"_STID_"PING.COM/OUTPUT="_FILEDIR_"CLRS"_STID_"PING.LOG"")"
109 X XPV1 ; Run the .com file
110 ;
111 ; 3. Read Logfile into working global
112 N FNAME,XLOG
113 S FNAME="CLRS"_STID_"PING.LOG"
114 S XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("CLRSLOG",$J,1)),3)
115 ; Check global for %SYSTEM or 0 packets received
116 N PNG,PNG1,PNG2,PNG3
117 S PNG=0,PNG1=0,PNG2=0
118 F S PNG=$O(^TMP("CLRSLOG",$J,PNG)) Q:PNG="" D
119 . S PNG1=$G(^TMP("CLRSLOG",$J,PNG))
120 . I PNG1["0 packets received" S CLRSERR=3
121 . I PNG1["%SYSTEM" S CLRSERR=3
122 . Q
123 Q
124WINPING ; PING report server to make sure it is available
125 ;*98 Modified to work with PRC CLRS ADDRESS parameter
126 N PV,XPV1,FILEDIR,STID,XLOG,ADDR
127 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
128 S ADDR=$$GET^XPAR("SYS","PRC CLRS ADDRESS",1,"Q")
129 I ADDR="" S PRCPMSG(1)="There is no address identified in the CLRS Adress Parameter.",PRCPMSG(2)="Please correct and retry." D MAILFTP S CLRSERR=1 Q
130 ;
131 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
132 S XPV1="S PV=$ZF(-1,""PING "_ADDR_">"_FILEDIR_"CLRS"_STID_"PING.LOG"")"
133 X XPV1
134 S FNAME="CLRS"_STID_"PING.LOG"
135 S XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("CLRSLOG",$J,1)),3)
136 N PNG,PNG1,PNG2,PNG3
137 S PNG=0,PNG1=0,PNG2=0
138 F S PNG=$O(^TMP("CLRSLOG",$J,PNG)) Q:PNG="" D
139 . S PNG1=$G(^TMP("CLRSLOG",$J,PNG))
140 . I PNG1["Received = 0" S CLRSERR=3
141 . Q
142 Q
143 ;
144LOG2FILE ; Set logfile to global, add to mail message
145 ;
146 ;
147 N FILEDIR,STID,FNAME,XLOG
148 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
149 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
150 I CKOS["VMS" S FNAME="CLRS"_STID_"FTP1.LOG"
151 I CKOS["NT" S FNAME="CLRS"_STID_"F1FTP1.LOG"
152 S XLOG=$$FTG^%ZISH(FILEDIR,FNAME,$NAME(^TMP("PRCHLOG",$J,1)),3)
153 ; Log file is in the global ^TMP("PRCHLOG", lets put it in
154 ; the message beginning at PRCPMSG(11)
155 ;
156 N LG1,LG2,LG3,LG4,LGCNT
157 S LG1=0,LG2=0,LG3=0,LG4=0,LGCNT=11
158 F S LG1=$O(^TMP("PRCHLOG",$J,LG1)) Q:LG1="" D
159 . S LG3=$G(^TMP("PRCHLOG",$J,LG1))
160 . S PRCPMSG(LGCNT)=LG3
161 . S LGCNT=LGCNT+1
162 . Q
163 D MAILFTP
164 Q
165FTPCOM ; Issue the FTP command after CLRSxxxWFTP.TXT file is built
166 ; remain in CACHE during FTP Process using
167 ; $ZF(-1) call
168 ;
169 ; rll/ 8/30/2006 Change logic to initiate transfer one file
170 ; at a time to the report server for Windows/Cache stations
171 ; This was done after a hang was observed between transfers.
172 ;
173 N LPP1,LPP2
174 S LPP1=0,LPP2="F"
175 F LPP1=1:1:19 D ; run the FTP command for the 19 PO files
176 . D RUNFTPT
177 . Q
178 S LPP1=0,LPP2="G"
179 F LPP1=1:1:2 D ; run the FTP command for the 2 GIP files
180 . D RUNFTPT
181 . Q
182 Q
183 ;
184RUNFTPT ; Run the FTP transfer for Windows
185 N PV,XPV1,FILEDIR,STID
186 ;
187 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
188 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
189 ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
190 ; See IFCAP Technical Manual
191 S XPV1="S PV=$ZF(-1,""ftp -s:"_FILEDIR_"CLRS"_STID_LPP2_LPP1_"WFTP.TXT>"_FILEDIR_"CLRS"_STID_LPP2_LPP1_"FTP1.LOG"")"
192 X XPV1 ; FTP the files, Comment out for testing
193 ;
194 ; error flag logic
195 I PV=-1 D ; Note, this error is logged on system error during xfer
196 . S CLRSERR=1
197 . Q
198 Q
199DELWIN ; Delete windows files
200 ;
201 ;
202 I CKOS["NT" D
203 . N LPP1,LPP2
204 . S LPP1=0,LPP2="F"
205 . F LPP1=1:1:19 D ; run the FTP command for the 19 PO files
206 . . D DELFTPF
207 . . Q
208 . Q
209 S LPP1=0,LPP2="G"
210 F LPP1=1:1:2 D
211 . D DELFTPF ; Delete the GIP files
212 . Q
213 Q
214DELFTPF ; Delete the FTP files, logs , and .TXT files
215 ;
216 N FILEDIR,STID,XPV
217 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
218 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
219 ; delete previous extract
220 S XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"IFCP"_STID_LPP2_LPP1_".TXT"")"
221 X XPV ; comment out for testing
222 ; delete previous logfile
223 ;
224 S XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"CLRS"_STID_LPP2_LPP1_"FTP1.LOG"")"
225 X XPV ; comment out for testing
226 ; delete previous ftp file for transfer
227 ;
228 S XPV="S PV=$ZF(-1,""DEL "_FILEDIR_"CLRS"_STID_LPP2_LPP1_"WFTP.TXT"")"
229 X XPV
230 Q
231 ;
232MAIL ;Builds mail messages to a defined mail group to notify users of the
233 ;success or failure of the TaskMan scheduling for the CLO Procurement
234 ;Reports
235 ;
236 ;*98 Modified code to work with PRC CLRS OUTLOOK MAILGROUP parameter
237 N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCPMG,PRCPMG2
238 S XMSUB="CLO Procurement Report Status for "_$$HTE^XLFDT($H)
239 S XMDUZ="Clinical Logistics Report Server"
240 S XMTEXT="PRCPMSG("
241 S XMY("G.PRCPLO CLRS NOTIFICATIONS")=""
242 S PRCPMG=$$GET^XPAR("SYS","PRC CLRS OUTLOOK MAILGROUP",1,"Q")
243 S:$G(PRCPMG)'="" PRCPMG2="S XMY("""_PRCPMG_""")=""""" X PRCPMG2
244 ;
245 D ^XMD
246 Q
247 ;
248MAILFTP ;Builds mail messages to a defined mail group to notify users of
249 ;the success or failure of issues pertaining to FTP Transfer and
250 ;file permissions/protections associated with VMS Directories
251 ;
252 ;*98 Modified code to work with PRC CLRS OUTLOOK MAILGROUP parameter
253 N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ,PRCPMG,PRCPMG2
254 S XMSUB="CLO Environment Check & Data Transfer for OS / FTP , "_$$HTE^XLFDT($H)
255 S XMDUZ="Clinical Logistics Report Server"
256 S XMTEXT="PRCPMSG("
257 S XMY("G.PRCPLO CLRS NOTIFICATIONS")=""
258 S PRCPMG=$$GET^XPAR("SYS","PRC CLRS OUTLOOK MAILGROUP",1,"Q")
259 S:$G(PRCPMG)'="" PRCPMG2="S XMY("""_PRCPMG_""")=""""" X PRCPMG2
260 ;
261 D ^XMD
262 Q
Note: See TracBrowser for help on using the repository browser.