source: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLEVUTI2.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1HLEVUTI2 ;O-OIFO/LJA - Event Monitor UTILITIES ;02/04/2004 14:42
2 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
3 ;
4 ; This routine is used to queue M code tasks that automatically
5 ; requeue themselves (within limits.)
6 ;
7INIT ;
8 N A7UOK
9 D HEADER,EX
10 F Q:(+$Y+3)>IOSL W !
11 QUIT:$$BTE^HLCSMON("Press RETURN to continue, or '^' to exit... ") ;->
12 ;
13CTRL ;
14 D HEADER
15 W !
16 D M
17 D ASK I 'A7UOK QUIT ;->
18 D XEC
19 D BT QUIT:'A7UOK ;->
20 G CTRL ;->
21 ;
22BT ;
23 W !
24 S A7UOK=0
25 N DIR
26 S DIR(0)="EA",DIR("A")="Press RETURN to continue, or '^' to exit... "
27 D ^DIR
28 QUIT:+Y'=1 ;->
29 S A7UOK=1
30 QUIT
31 ;
32HEADER ;
33 W @IOF,$$CJ^XLFSTR("M Code Requeue Utility",IOM)
34 W !,$$REPEAT^XLFSTR("=",80)
35 QUIT
36 ;
37M KILL A7UMENU F I=1:1 S T=$T(M+I) QUIT:T'[";;" S T=$P(T,";;",2,99),A7UMENU(I)=$P(T,"~",2,99) W !,$J(I,2),". ",$P(T,"~")
38 ;;Start M code jobs~D START
39 ;;Show M code job runs~D SHOW
40 QUIT
41 ;
42ASK ;
43 W !
44 S A7UOK=0
45 N DIR
46 S DIR(0)="NO^1:"_(+I-1),DIR("A")="Select option"
47 D ^DIR
48 QUIT:'$D(A7UMENU(+Y)) ;->
49 S A7UOPT=+Y
50 S A7UOK=1
51 QUIT
52 ;
53XEC ;
54 S X=A7UMENU(+A7UOPT) X X
55 QUIT
56 ;
57 ;==================================================================
58 ;
59SHOW ; Show M code job "runs"...
60 N C2,C3,C4,C5,X,XTMP,Y
61 ;
62 I $O(^XTMP("HLEVREQ"))'["HLEVREQ" D QUIT ;->
63 . W !!,"No M Code API run data exists..."
64 . W !
65 ;
66 S C2=14,C3=28,C4=41,C5=59
67 W !,"Task#",?C2,"Start",?C3,"Finish",?C4,"|"
68 W ?(C4+2),"Next task#",?C5,"Queue time"
69 W !,$$REPEAT^XLFSTR("=",C4),"|",$$REPEAT^XLFSTR("=",IOM-$X)
70 ;
71 S XTMP="HLEVREQ"
72 F S XTMP=$O(^XTMP(XTMP)) Q:$E(XTMP,1,7)'="HLEVREQ" D
73 . D SXTMPT(XTMP)
74 ;
75 ;
76 S C2=14,C3=28,C4=41,C5=59
77 W !!,"Task#",?C2,"Start",?C3,"Finish",?C4,"M API"
78 W !,$$REPEAT^XLFSTR("=",IOM)
79 ;
80 S XTMP="HLEVREQ"
81 F S XTMP=$O(^XTMP(XTMP)) Q:$E(XTMP,1,7)'="HLEVREQ" D
82 . D SXTMPM(XTMP)
83 ;
84 Q
85 ;
86SXTMPM(XTMP) ; Show individual XTMP entry...
87 ; C2 to C5 -- req
88 N I,XTMP0
89 S XTMP0=$G(^XTMP(XTMP,0)) QUIT:XTMP0']"" ;->
90 W !
91 D P(4,C2),P(2,C3),P(7,C4)
92 W $P(XTMP0,U,8,9)," "
93 S XTMP0=$P(XTMP0,U,8,9) QUIT:XTMP0']"" ;->
94 S XTMP0=$P($T(@XTMP0)," ",2,999) QUIT:XTMP0']"" ;->
95 I $E(XTMP0)=";",$E(XTMP0,1,2)'=";;" S XTMP0=$E(XTMP0,2,999)
96 X "F I=1:1:$L(XTMP0) Q:$E(XTMP0,I)'="" """ S XTMP0=$E(XTMP0,I,999)
97 W $E(XTMP0,1,IOM-$X)
98 Q
99 ;
100SXTMPT(XTMP) ; Show individual XTMP entry...
101 ; C2 to C5 -- req
102 N XTMP0
103 S XTMP0=$G(^XTMP(XTMP,0)) QUIT:XTMP0']"" ;->
104 W !
105 D P(4,C2),P(2,C3),P(7,C4)
106 W "| "
107 D P(5,C5),P(6,IOM)
108 Q
109 ;
110P(PCE,COL) ; Print value and "tab" over to COL...
111 ; XTMP0 -- req
112 N DATA
113 S DATA=$P(XTMP0,U,PCE)
114 I DATA?7N1"."1.N S DATA=$$SDT^HLEVX001(DATA)
115 W DATA,?COL
116 Q
117 ;
118 ;==================================================================
119 ;
120START ;
121 N MREQ,MRTN,MTIME,ZTSK
122 ;
123 W !
124 S MRTN=$$FTMRTN QUIT:MRTN']"" ;->
125 W !
126 S MTIME=$$TIME QUIT:'MTIME ;->
127 W !
128 S MREQ=$$REQNO QUIT:MREQ'>0 ;->
129 ;
130 W !
131 I '$$YN^HLCSRPT4("OK to queue job") D QUIT ;->
132 . W " job not started..."
133 ;
134 S ZTSK=$$NEWJOB($$NOW^XLFDT)
135 W !!,"Queued to task# ",ZTSK,"..."
136 ;
137 QUIT
138 ;
139 ;
140NEWJOB(TIME) ; Start job...
141 ; MREQ,MRTN,MTIME -- req
142 N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSK
143 S ZTIO="",ZTDTH=TIME,ZTDESC="HLEVUTI2-Queued Jobs"
144 S ZTRTN="QUEUE^HLEVUTI2"
145 S ZTSAVE("MREQ")="",ZTSAVE("MRTN")="",ZTSAVE("MTIME")=""
146 S ZTSAVE("HLRUNS*")=""
147 D ^%ZTLOAD
148 QUIT ZTSK
149 ;
150QUEUE ; Queue point for the starting of all queued HLEVUTI2 jobs...
151 ; MREQ,MRTN,MTIME -- req
152 N I,NEWJOB,NOW,TASKNO,XTMP
153 ;
154 S ZTREQ="@",NOW=$$NOW^XLFDT,TASKNO=ZTSK
155 ;
156 ; Store run's ZTSK in HLRUNS...
157 S HLRUNS=$G(HLRUNS)+1,HLRUNS(+ZTSK)=NOW
158 I HLRUNS>30 S I=0 F S I=$O(HLRUNS(I)) KILL HLRUNS(I) ; No STORE errors!
159 ;
160 S XTMP="HLEVREQ-"_ZTSK
161 S ^XTMP(XTMP,0)=$$FMADD^XLFDT(MTIME,1)_U_NOW_U_"Event Monitor HLEVUTI2 Requeue"_U_ZTSK_"^^^^"_MRTN
162 ;
163 ; Piece 1 = Vaporization date/time
164 ; Piece 2 = NOW
165 ; Piece 3 = Description
166 ; Piece 4 = Current task#
167 ; Piece 5 = Next task number or END OF QUEUING
168 ; Piece 6 = Next queue time
169 ; Piece 7 = M code API finish time
170 ; Piece 8 = Tag
171 ; Piece 9 = Routine
172 ;
173 ; Calculate time for next queued job...
174 S NEXTIME=$$FMADD^XLFDT(NOW,"","",MREQ)
175 ;
176 ; If next queue time is not greater, then queue next job...
177 I NEXTIME<MTIME D
178 . S NEWJOB=$$NEWJOB(NEXTIME)
179 . S $P(^XTMP(XTMP,0),U,5,6)=NEWJOB_U_NEXTIME
180 ;
181 ; Run the M code...
182 D @MRTN
183 ;
184 ; M code finish time...
185 S NOW=$$NOW^XLFDT,$P(^XTMP(XTMP,0),U,7)=NOW,$P(HLRUNS(ZTSK),U,2)=NOW
186 ;
187 ; If next queue time < then end time quit (for new job already que'd)
188 QUIT:NEXTIME<MTIME ;->
189 ;
190 S $P(^XTMP(XTMP,0),U,5)="END OF QUEUING"
191 D MAIL
192 ;
193 Q
194 ;
195TEST ; Call here to test M code
196 D SAVE("Line of text saved by SAVE(TXT).")
197 Q
198 ;
199EX N I,T F I=1:1 S T=$T(EX+I) QUIT:T'[";;" W !,$P(T,";;",2,99)
200 ;;This utility runs M code in a background job on a repetitive basis up to the
201 ;;date/time you specify. To use this utility you must supply the following:
202 ;;
203 ;; * M code API (tag~routine.)
204 ;; * Requeue frequency (in minutes.)
205 ;; * Time to stop all requeues (up to 7 days in future.)
206 ;;
207 ;;As soon as the background job starts, the following actions occur:
208 ;;
209 ;; * The time for the next "run" of the 'M code API' is calculated using the
210 ;; 'requeue frequency.'
211 ;; * If the new run time is not past the 'time to stop all requeues', a new
212 ;; future job is queued.
213 ;; * The M code API is called. (This occurs even when no future jobs are
214 ;; queued.
215 QUIT
216 ;
217FTMRTN() ;
218 N ANS,DIR,DIRUT,DTOUT,DUOUT,X,Y
219 S DIR(0)="F^3:17",DIR("A")="Enter TAG~ROUTINE"
220 W !,"Enter the M code API to be called by background jobs. Enter it in the format"
221 W !,"'TAG~ROUTINE'. (Use the tilde (~) character in place of the up-arrow.)"
222 W !
223 D ^DIR
224 QUIT:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) "" ;->
225 S ANS=$TR(Y,"~",U)
226 S X="D "_ANS D ^DIM QUIT:'$D(X) "" ;->
227 Q ANS
228 ;
229TIME() ;
230 N ANS,DIR,DIRUT,DTOUT,DUOUT,NOW,X,Y
231 S NOW=$$NOW^XLFDT
232 S DIR(0)="DA^"_NOW_":"_$$FMADD^XLFDT(NOW,7)_":AEFRS"
233 S DIR("A")="Enter STOP TIME: "
234 S DIR("?")="Enter a future date/time up to "_$$FMTE^XLFDT($$FMADD^XLFDT(NOW,7))_"..."
235 S DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(NOW,1))
236 W !,"New jobs will be requeued until the date/time you enter now. You cannot queue"
237 W !,"jobs past seven days in the future."
238 W !
239 D ^DIR
240 QUIT:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) "" ;->
241 S ANS=Y
242 I ANS'>NOW D QUIT "" ;->
243 . W !!,"Date/time you enter must not be in the past..."
244 Q ANS
245 ;
246REQNO() ;
247 N ANS,DIR,DIRUT,DTOUT,DUOUT,NOW,X,Y
248 S DIR(0)="N^10:1440",DIR("A")="Enter REQUEUE FREQUENCY (min)"
249 W !,"New jobs will be requeued for the number of 'requeue frequency' minutes"
250 W !,"in the future you specify now."
251 W !
252 D ^DIR
253 QUIT:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) "" ;->
254 Q Y
255 ;
256MAIL ; All queues are done. Mail notification to DUZ...
257 N NO,TEXT,XMDUZ,XMSUB,XMTEXT,XMZ
258 S XMDUZ=.5,XMSUB="M Code Requeue Utility"
259 S XMTEXT="^TMP("_$J_",""HLMAILMSG"","
260 KILL ^TMP($J,"HLMAILMSG")
261 S NO=0
262 D MAILADD("The queuing of jobs to "_$TR($G(MRTN),"~",U)_" has finished. #"_$G(HLRUNS)_" jobs were queued.")
263 ;
264 I HLRUNS<31 D
265 . N DATA,LN,TASK,TXT
266 . S LN=$$REPEAT^XLFSTR(" ",74)
267 . D MAILADD("")
268 . D MAILADD("Task# Start Finish")
269 . D MAILADD($$REPEAT^XLFSTR("-",74))
270 . S TASK=0
271 . F S TASK=$O(HLRUNS(TASK)) Q:'TASK D
272 . . S DATA=HLRUNS(TASK)
273 . . S TXT=$E(TASK_LN,1,14) ; Task#
274 . . S TXT=TXT_$E($$SDT^HLEVX001(+DATA)_LN,1,13) ; Start time
275 . . S TXT=TXT_$E($$SDT^HLEVX001($P(DATA,U,2))_LN,1,13) ; End time
276 . . I $D(^XTMP("HLEVREQ-"_TASK,"T")) D
277 . . . S TXT=TXT_"Data in ^XTMP(""HLEVREQ-"_TASK_""",""T"")"
278 . . D MAILADD(TXT)
279 ;
280 S XMY(DUZ)=""
281 D ^XMD
282 I '$D(ZTQUEUED) W !!,"Mail message #",$G(XMZ),"..."
283 KILL ^TMP($J,"HLMAILMSG")
284 ;
285 Q
286 ;
287MAILADD(T) S NO=$G(NO)+1,^TMP($J,"HLMAILMSG",NO)=T
288 Q
289 ;
290 ;==================================================================
291 ;
292SAVE(TXT) ; Save one line of text into ^XTMP
293 ; XTMP -- req
294 N NO
295 QUIT:$G(XTMP)']"" ;->
296 QUIT:$G(^XTMP(XTMP,0))']"" ;->
297 S NO=$O(^XTMP(XTMP,"T",":"),-1)+1
298 S ^XTMP(XTMP,"T",+NO)=$G(TXT)
299 Q
300 ;
301KILLALL ; Kill **ALL** run data for all jobs!!!! (BE CARFUL)
302 N DATA,XTMP
303 ;
304 I $O(^XTMP("HLEVREQ-"))'["HLEVREQ-" D QUIT ;->
305 . W !!,"No data exists... "
306 . W !
307 ;
308 W !!,"Existing M code job run data..."
309 ;
310 W !
311 S XTMP="HLEVREQ-"
312 F S XTMP=$O(^XTMP(XTMP)) Q:$E(XTMP,1,8)'="HLEVREQ-" D
313 . S DATA=$G(^XTMP(XTMP,0)) Q:DATA']"" ;->
314 . W !,"Started: ",$$SDT^HLEVX001($P(DATA,U,2))
315 . W $S($P(DATA,U,7)']"":" Job still running!!",1:" finished: "_$$SDT^HLEVX001(+$P(DATA,U,7)))
316 . W " ",$P(DATA,U,8,9),"..."
317 ;
318 W !
319 I '$$YN^HLCSRPT4("OK to delete ALL M Code requeue data","No") D QUIT ;->
320 . W " nothing deleted..."
321 ;
322 W !
323 S XTMP="HLEVREQ-"
324 F S XTMP=$O(^XTMP(XTMP)) Q:$E(XTMP,1,8)'="HLEVREQ-" D
325 . W !,"Killing ^XTMP(",XTMP,")..."
326 . D KILLXTMP(XTMP)
327 ;
328 W !
329 S X=$$BTE^HLCSMON("Press RETURN to exit... ")
330 ;
331 Q
332 ;
333KILLXTMP(XTMP) ; Kill one XTMP entry... (Pass TASK or full reference)
334 I XTMP=+XTMP S XTMP="HLEVREQ-"_XTMP
335 KILL ^XTMP(XTMP)
336 Q
337 ;
338EOR ;HLEVUTI2 - Event Monitor UTILITIES ;5/16/03 14:42
Note: See TracBrowser for help on using the repository browser.