source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHLO5.m@ 1420

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

initial load of WorldVistAEHR
File size: 8.7 KB
RevLine 
[613]1PRCHLO5 ;WOIFO/DAP/RLL-manual run for procurement reports ; 10/16/06 2:12pm
2V ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ENT ;This routine tasks out the execution of the procurement extract
6 ;reports associated with PRC*5.1*83 (CLRS).
7 ;
8 N ZTRTN,ZTDESC,ZTDTH,ZTIO,PRCHPRO,ZTSK,ZTREQ,PRCPMSG
9 S ZTRTN="RUNEXT^PRCHLO5"
10 S ZTDESC="PRCPLO CLO Procurement Reports CLRS"
11 S ZTDTH=$H
12 S ZTREQ="@"
13 S ZTIO=""
14 D ^%ZTLOAD
15 S PRCHPRO=ZTSK
16 ;Calls mail group message generation and screen display with success
17 ;or exception notification
18 I $D(PRCHPRO)[0 S PRCPMSG(1)="A task could not be created for the CLO Procurement Reports - please contact IRM." W ! D EN^DDIOL(PRCPMSG(1)) D MAIL^PRCHLO4A Q
19 ;
20 S PRCPMSG(1)="Task # "_PRCHPRO_" entered for Procurement Reports."
21 W !
22 D EN^DDIOL(PRCPMSG(1))
23 ;
24 ;*98 Modified to move MAIL and MAILFTP tags to routine PRCHLO4A
25 ;
26 D MAIL^PRCHLO4A
27 ;
28 Q
29PRCPCMP ; Notification of completion of building Procurement Report Data
30 N PRCPMSG
31 S PRCPMSG(1)="PO Procurement Data extract complete."
32 D EN^DDIOL(PRCPMSG(1))
33 D MAIL^PRCHLO4A
34 Q
35 ;
36RUNEXT ; Run extract reports for PO Activity
37 N CLRSERR,CLRSTST1 ; error flag for exception handling,tst entry pt.
38 ; CLRSERR will be set for the following conditions:
39 ; 0 - Success, status message for completion is sent.
40 ; 1 - Error creating ^TMP($J) data (i.e. disk full)
41 ; 2 - Error creating Files(i.e. directory patch, VMS Space, etc.)
42 ; 3 - Error creating .Com file for FTP transfer, permissions issue
43 ; 4 - Error with FTP Transfer,ntwk/permissions, Report Server issue
44 ; 5 - Error with file deletion/cleanup prior to processing
45 ; 6 - Error, lock is present. Process already running
46 S CLRSERR=0
47TSTMSG ; This entry point is used to test the messaging framework
48 ; S SLRSTST1=1
49 S CLRSERR=0
50 ; Check for O/S version
51 N CKOS
52 S CKOS=$$OS^%ZOSV()
53 ; use lock to prevent mult. runs
54 L +^PRCP(446.7,"STATUS"):3 I $T=0 S CLRSERR=6
55 I CLRSERR=0 D DELRUN^PRCHLO5
56 I CLRSERR=5 D
57 . N PRCPMSG
58 . S PRCPMSG(1)="Error with file deletion/cleanup prior to processing. Please contact IRM."
59 . S PRCPMSG(2)=" "
60 . S PRCPMSG(3)="This error indicates the CLRS EXTRACT DIRECTORY has not"
61 . S PRCPMSG(4)="been properly set up during the installation of this patch."
62 . S PRCPMSG(5)=" "
63 . S PRCPMSG(6)="(Please refer to the pre installation instructions for PRC*5.1*83)"
64 . S PRCPMSG(7)=" "
65 . S PRCPMSG(8)="A valid directory must be set up with the"
66 . S PRCPMSG(9)="proper read/write/execute/delete privileges."
67 . S PRCPMSG(10)=" "
68 . S PRCPMSG(11)="In addition, the directory name which you create"
69 . S PRCPMSG(12)="must be added as the CLRS EXTRACT DIRECTORY"
70 . S PRCPMSG(13)="through the CLO System Parameters Option."
71 . S PRCPMSG(14)="If the field is blank, you will generate this error."
72 . S PRCPMSG(15)=" "
73 . S PRCPMSG(16)="Please confirm all steps have been performed"
74 . S PRCPMSG(17)="according to the pre installation instructions for patch PRC*5.1*83."
75 . D MAILFTP^PRCHLO4A
76 . Q
77 ; Begin to build files
78 I CLRSERR=0 D INIT^PRCHLO
79 I CLRSERR=0 D PRCPCMP^PRCHLO5 ; PO activity Extract logic completed
80 I $D(CLRSTST1) D ; test point to generate message 1
81 . Q:CLRSTST1'=1
82 . S CLRSERR=1
83 . Q
84 I CLRSERR=1 D
85 . N PRCPMSG ; error building ^TMP($J)
86 . S PRCPMSG(1)="Error, No Data for PO Activity Files, contact IRM"
87 . D MAILFTP^PRCHLO4A
88 . Q
89CRFILE ; Create .txt file to confirm write privileges to directory
90 I CLRSERR=0 D TSTF^PRCHLO4 ; will return CLRSERR=2 on error
91 I CLRSERR=0 D CLRSFIL^PRCHLO4
92 I CLRSERR=2 D
93 . N PRCPMSG
94 . S PRCPMSG(1)="Error, Problem with FTP File Creation, contact IRM"
95 . D MAILFTP^PRCHLO4A
96 . Q
97 I CLRSERR=0 D
98 . N PRCPMSG
99 . S PRCPMSG(1)="Built PO Activity Extracts and GIP Extracts for transfer"
100 . D MAILFTP^PRCHLO4A
101 . Q
102 I CKOS["VMS" D
103 . I CLRSERR=0 D CRTCOM^PRCHLO4
104 . Q
105 I CKOS["NT" D
106 . I CLRSERR=0 D CRTWIN^PRCHLO4A
107 . Q
108 I CLRSERR=6 D
109 . N PRCPMSG
110 . S PRCPMSG(1)="Error encountered when attempting to run CLO PO"
111 . S PRCPMSG(2)="activity reports due to other CLRS extracts in"
112 . S PRCPMSG(3)="progress. Please try again later."
113 . D MAILFTP^PRCHLO4A
114 . Q
115 I $D(CLRSTST1) D ; test point to generate message 3
116 . Q:CLRSTST1'=3
117 . S CLRSERR=3
118 . Q
119 I CLRSERR=0 D CKRPTSV^PRCHLO4A ;ping report server for availability
120 I CLRSERR=3 D
121 . N PRCPMSG
122 . S PRCPMSG(1)="Error, problem creating SETUP file for FTP Transfer, contact IRM."
123 . S PRCPMSG(2)="The Report Server may be unavailable for processing."
124 . D MAILFTP^PRCHLO4A
125 . Q
126 I CLRSERR=0 D
127 . N PRCPMSG,FILEDIR
128 . S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
129 . S PRCPMSG(1)="Final FTP Setup complete, beginning FTP Transfer"
130 . S PRCPMSG(2)=" "
131 . S PRCPMSG(3)="The file transfer to the report server has been initiated."
132 . S PRCPMSG(4)="You will be receiving a notification that the FTP"
133 . S PRCPMSG(5)="process has completed. The notification message"
134 . S PRCPMSG(6)="should be received within the hour. If you do not"
135 . S PRCPMSG(7)="receive the FTP process has completed message,"
136 . S PRCPMSG(8)="please contact IRM. IRM can confirm the process"
137 . S PRCPMSG(9)="is still running by performing the following"
138 . S PRCPMSG(10)="command:"
139 . S PRCPMSG(11)=" "
140 . S PRCPMSG(12)="At the MUMPS Programmer prompt, type D ^%SS"
141 . S PRCPMSG(13)=" "
142 . S PRCPMSG(14)="See if there are any PRCHLO* routines running."
143 . S PRCPMSG(15)=" "
144 . S PRCPMSG(16)="If these routines are present, the process is still"
145 . S PRCPMSG(17)="running. If you waited one hour, and did not get the"
146 . S PRCPMSG(18)="FTP process has completed message, a problem"
147 . S PRCPMSG(19)="was encountered. Further troubleshooting can be"
148 . S PRCPMSG(20)="performed by examining the LOGFILE CLRSxxxFTP1.LOG"
149 . S PRCPMSG(21)="where xxx is your station ID#. The logfile is"
150 . S PRCPMSG(22)="located in the following directory: "_FILEDIR
151 . S PRCPMSG(23)=" "
152 . D MAILFTP^PRCHLO4A
153 . Q
154 I CKOS["VMS" D
155 . I CLRSERR=0 D
156 . . D CRTCOM1^PRCHLO4
157 . . D FTPCOM^PRCHLO4
158 . . Q
159 . Q
160 I CKOS["NT" D
161 . I CLRSERR=0 D
162 . . D CRTWIN^PRCHLO4A
163 . . D FTPCOM^PRCHLO4A
164 . . Q
165 . Q
166 ; release the lock
167 L -^PRCP(446.7,"STATUS")
168 I CLRSERR=4 D
169 . N PRCPMSG,FILEDIR
170 . S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
171 . S PRCPMSG(1)="An Error occurred during the FTP Transfer "_$$HTE^XLFDT($H)
172 . S PRCPMSG(2)="Contact IRM to perform troubleshooting steps"
173 . S PRCPMSG(3)="by examining the logfile CLRSxxxFTP1.LOG where"
174 . S PRCPMSG(4)="xxx is your station number. The logfile is located"
175 . S PRCPMSG(5)="the FTP directory "_FILEDIR
176 . S PRCPMSG(6)=" "
177 . D MAILFTP^PRCHLO4A
178 . Q
179 I CLRSERR=0 D
180 . N PRCPMSG,FILEDIR
181 . S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
182 . S PRCPMSG(1)="The FTP Transfer process completed, "_$$HTE^XLFDT($H)
183 . S PRCPMSG(2)=" "
184 . S PRCPMSG(3)="The Clinical Logistics 0ffice should examine the Report Server"
185 . S PRCPMSG(4)="FTP directory for your files. If the files from your"
186 . S PRCPMSG(5)="station are not found, IRM can provide additional"
187 . S PRCPMSG(6)="troubleshooting steps by examining the LOGFILE"
188 . S PRCPMSG(7)="CLRSxxxFTP1.LOG where xxx is your station number."
189 . S PRCPMSG(8)="The logfile is located in the directory: "_FILEDIR
190 . S PRCPMSG(9)=" "
191 . S PRCPMSG(10)="The contents of the logfile are listed below:"
192 . D LOG2FILE^PRCHLO4A
193 . Q
194 ; CLEAN UP
195 K ^TMP($J)
196 K ^TMP("PRCHLOG",$J)
197 Q
198DELRUN ; delete previous run at the beginning of the program
199 ;
200 N FILCK,FILDEL,TFILE1,TFILE2,OUTFL1,OUTFL2,POP,STID
201 ; create, delete, then create files to clean up and confirm
202 ; write / delete privileges to directory
203 S POP=""
204 S STID=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
205 S OUTFL1="CLRS"_STID_"TST.TXT"
206 S OUTFL2="IFCP"_STID_"TST.TXT"
207 S FILEDIR=$$GET^XPAR("SYS","PRCPLO EXTRACT DIRECTORY",1,"Q")
208 I FILEDIR="" D
209 . S CLRSERR=5
210 . Q
211 I FILEDIR=" " D
212 . S CLRSERR=5
213 . Q
214 I CLRSERR=0 D OPEN^%ZISH("TFILE1",FILEDIR,OUTFL1,"W")
215 I POP D
216 . S CLRSERR=5
217 . Q
218 I CLRSERR=0 D
219 . D USE^%ZISUTL("TFILE1")
220 . W !,"$ ! This is a test file to confirm write/delete access"
221 . W !,"$ ! once file access is confirmed, file is deleted"
222 . W !,"$ EXIT"
223 . D CLOSE^%ZISH("TFILE1")
224 . D OPEN^%ZISH("TFILE2",FILEDIR,OUTFL2,"W")
225 . D USE^%ZISUTL("TFILE2")
226 . W !,"$ ! This is a test file to confirm write/delete access"
227 . W !,"$ ! once file access is confirmed, file is deleted"
228 . W !,"$ EXIT"
229 . D CLOSE^%ZISH("TFILE2")
230 . Q
231 ;
232DELWIN ; DELETE windows files, need to handle 1 file at a time
233 ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
234 ; See IFCAP technical manual.
235 I CKOS["NT" D DELWIN^PRCHLO4A
236DELFILS ; Delete the files / clean-up before processing
237 ;
238 ; SACC Exception received for usage of $ZF(-1) in PRC*5.1*83
239 ; See IFCAP technical manual
240 I CKOS["VMS" D ;O/S IS VMS
241 . Q:CLRSERR'="0"
242 . N PV,PV1,XPV,XPV1
243 . S XPV="S PV=$ZF(-1,""DELETE "_FILEDIR_"*"_STID_"*.*;*"")"
244 . X XPV
245 . Q
246 Q
Note: See TracBrowser for help on using the repository browser.