source: EDIS/trunk/kids/UJO_0100_seq001_pat123.kids@ 1495

Last change on this file since 1495 was 1340, checked in by George Lilly, 13 years ago

latest from EHS
File size: 29.3 KB
RevLine 
[1340]1KIDS Distribution saved on Dec 26, 2011@16:58:31
2EDIS & VL fixes
3**KIDS**:UJO*1.0*123^
4
5**INSTALL NAME**
6UJO*1.0*123
7"BLD",8018,0)
8UJO*1.0*123^JORDAN SPECIFIC MODIFICATIONS^0^3111226^n
9"BLD",8018,1,0)
10^^10^10^3111226^
11"BLD",8018,1,1,0)
12mainly this patch will fix different issues in the attached EDIS and
13"BLD",8018,1,2,0)
14VistALink routines, which falls in the following criteria.
15"BLD",8018,1,3,0)
16
17"BLD",8018,1,4,0)
181- relational operators that GT.M can not compile like using of ">=",
19"BLD",8018,1,5,0)
20GT.M can handle single operator at the time.
21"BLD",8018,1,6,0)
22which exists in EDPRPT5, EDPRPTBV, EDPYPRE routines.
23"BLD",8018,1,7,0)
24
25"BLD",8018,1,8,0)
262- authentication problem, which cause lose of RPC parameters in
27"BLD",8018,1,9,0)
28VistALink in XOBSRA1 routine, New'ing the RPC parameters will preserve
29"BLD",8018,1,10,0)
30the Value of those parameters.
31"BLD",8018,4,0)
32^9.64PA^^
33"BLD",8018,6.3)
346
35"BLD",8018,"KRN",0)
36^9.67PA^779.2^20
37"BLD",8018,"KRN",.4,0)
38.4
39"BLD",8018,"KRN",.401,0)
40.401
41"BLD",8018,"KRN",.402,0)
42.402
43"BLD",8018,"KRN",.403,0)
44.403
45"BLD",8018,"KRN",.5,0)
46.5
47"BLD",8018,"KRN",.84,0)
48.84
49"BLD",8018,"KRN",3.6,0)
503.6
51"BLD",8018,"KRN",3.8,0)
523.8
53"BLD",8018,"KRN",9.2,0)
549.2
55"BLD",8018,"KRN",9.8,0)
569.8
57"BLD",8018,"KRN",9.8,"NM",0)
58^9.68A^5^4
59"BLD",8018,"KRN",9.8,"NM",2,0)
60EDPRPTBV^^0^B22104348
61"BLD",8018,"KRN",9.8,"NM",3,0)
62EDPRPT5^^0^B36687959
63"BLD",8018,"KRN",9.8,"NM",4,0)
64EDPYPRE^^0^B9222306
65"BLD",8018,"KRN",9.8,"NM",5,0)
66XOBSRA1^^0^B4031966
67"BLD",8018,"KRN",9.8,"NM","B","EDPRPT5",3)
68
69"BLD",8018,"KRN",9.8,"NM","B","EDPRPTBV",2)
70
71"BLD",8018,"KRN",9.8,"NM","B","EDPYPRE",4)
72
73"BLD",8018,"KRN",9.8,"NM","B","XOBSRA1",5)
74
75"BLD",8018,"KRN",19,0)
7619
77"BLD",8018,"KRN",19.1,0)
7819.1
79"BLD",8018,"KRN",101,0)
80101
81"BLD",8018,"KRN",409.61,0)
82409.61
83"BLD",8018,"KRN",771,0)
84771
85"BLD",8018,"KRN",779.2,0)
86779.2
87"BLD",8018,"KRN",870,0)
88870
89"BLD",8018,"KRN",8989.51,0)
908989.51
91"BLD",8018,"KRN",8989.52,0)
928989.52
93"BLD",8018,"KRN",8994,0)
948994
95"BLD",8018,"KRN","B",.4,.4)
96
97"BLD",8018,"KRN","B",.401,.401)
98
99"BLD",8018,"KRN","B",.402,.402)
100
101"BLD",8018,"KRN","B",.403,.403)
102
103"BLD",8018,"KRN","B",.5,.5)
104
105"BLD",8018,"KRN","B",.84,.84)
106
107"BLD",8018,"KRN","B",3.6,3.6)
108
109"BLD",8018,"KRN","B",3.8,3.8)
110
111"BLD",8018,"KRN","B",9.2,9.2)
112
113"BLD",8018,"KRN","B",9.8,9.8)
114
115"BLD",8018,"KRN","B",19,19)
116
117"BLD",8018,"KRN","B",19.1,19.1)
118
119"BLD",8018,"KRN","B",101,101)
120
121"BLD",8018,"KRN","B",409.61,409.61)
122
123"BLD",8018,"KRN","B",771,771)
124
125"BLD",8018,"KRN","B",779.2,779.2)
126
127"BLD",8018,"KRN","B",870,870)
128
129"BLD",8018,"KRN","B",8989.51,8989.51)
130
131"BLD",8018,"KRN","B",8989.52,8989.52)
132
133"BLD",8018,"KRN","B",8994,8994)
134
135"BLD",8018,"QUES",0)
136^9.62^^
137"BLD",8018,"REQB",0)
138^9.611^1^1
139"BLD",8018,"REQB",1,0)
140EMERGENCY DEPARTMENT 1.0^1
141"BLD",8018,"REQB","B","EMERGENCY DEPARTMENT 1.0",1)
142
143"MBREQ")
1440
145"PKG",209,-1)
1461^1
147"PKG",209,0)
148JORDAN SPECIFIC MODIFICATIONS^UJO
149"PKG",209,20,0)
150^9.402P^^
151"PKG",209,22,0)
152^9.49I^1^1
153"PKG",209,22,1,0)
1541.0
155"PKG",209,22,1,"PAH",1,0)
156123^3111226^8
157"PKG",209,22,1,"PAH",1,1,0)
158^^10^10^3111226
159"PKG",209,22,1,"PAH",1,1,1,0)
160mainly this patch will fix different issues in the attached EDIS and
161"PKG",209,22,1,"PAH",1,1,2,0)
162VistALink routines, which falls in the following criteria.
163"PKG",209,22,1,"PAH",1,1,3,0)
164
165"PKG",209,22,1,"PAH",1,1,4,0)
1661- relational operators that GT.M can not compile like using of ">=",
167"PKG",209,22,1,"PAH",1,1,5,0)
168GT.M can handle single operator at the time.
169"PKG",209,22,1,"PAH",1,1,6,0)
170which exists in EDPRPT5, EDPRPTBV, EDPYPRE routines.
171"PKG",209,22,1,"PAH",1,1,7,0)
172
173"PKG",209,22,1,"PAH",1,1,8,0)
1742- authentication problem, which cause lose of RPC parameters in
175"PKG",209,22,1,"PAH",1,1,9,0)
176VistALink in XOBSRA1 routine, New'ing the RPC parameters will preserve
177"PKG",209,22,1,"PAH",1,1,10,0)
178the Value of those parameters.
179"QUES","XPF1",0)
180Y
181"QUES","XPF1","??")
182^D REP^XPDH
183"QUES","XPF1","A")
184Shall I write over your |FLAG| File
185"QUES","XPF1","B")
186YES
187"QUES","XPF1","M")
188D XPF1^XPDIQ
189"QUES","XPF2",0)
190Y
191"QUES","XPF2","??")
192^D DTA^XPDH
193"QUES","XPF2","A")
194Want my data |FLAG| yours
195"QUES","XPF2","B")
196YES
197"QUES","XPF2","M")
198D XPF2^XPDIQ
199"QUES","XPI1",0)
200YO
201"QUES","XPI1","??")
202^D INHIBIT^XPDH
203"QUES","XPI1","A")
204Want KIDS to INHIBIT LOGONs during the install
205"QUES","XPI1","B")
206NO
207"QUES","XPI1","M")
208D XPI1^XPDIQ
209"QUES","XPM1",0)
210PO^VA(200,:EM
211"QUES","XPM1","??")
212^D MG^XPDH
213"QUES","XPM1","A")
214Enter the Coordinator for Mail Group '|FLAG|'
215"QUES","XPM1","B")
216
217"QUES","XPM1","M")
218D XPM1^XPDIQ
219"QUES","XPO1",0)
220Y
221"QUES","XPO1","??")
222^D MENU^XPDH
223"QUES","XPO1","A")
224Want KIDS to Rebuild Menu Trees Upon Completion of Install
225"QUES","XPO1","B")
226NO
227"QUES","XPO1","M")
228D XPO1^XPDIQ
229"QUES","XPZ1",0)
230Y
231"QUES","XPZ1","??")
232^D OPT^XPDH
233"QUES","XPZ1","A")
234Want to DISABLE Scheduled Options, Menu Options, and Protocols
235"QUES","XPZ1","B")
236NO
237"QUES","XPZ1","M")
238D XPZ1^XPDIQ
239"QUES","XPZ2",0)
240Y
241"QUES","XPZ2","??")
242^D RTN^XPDH
243"QUES","XPZ2","A")
244Want to MOVE routines to other CPUs
245"QUES","XPZ2","B")
246NO
247"QUES","XPZ2","M")
248D XPZ2^XPDIQ
249"RTN")
2504
251"RTN","EDPRPT5")
2520^3^B36687959
253"RTN","EDPRPT5",1,0)
254EDPRPT5 ;SLC/MKB - Shift Report
255"RTN","EDPRPT5",2,0)
256 ;;1.0;EMERGENCY DEPARTMENT;;Sep 30, 2009;Build 6
257"RTN","EDPRPT5",3,0)
258 ;
259"RTN","EDPRPT5",4,0)
260SFT(DAY) ; Get Shift Report for EDPSITE on DAY
261"RTN","EDPRPT5",5,0)
262 N BEG,END,IN,OUT,LOG,X,X0,X1,X3,X4,S,SOUT,SHIFT
263"RTN","EDPRPT5",6,0)
264 N CNT,VA,DX,OTH,HR6,TRG,OCB,MO,DIE,UNK,PREV,NEXT,SUB
265"RTN","EDPRPT5",7,0)
266 N ELAPSE,ADMDEC,STS,DISP,COL
267"RTN","EDPRPT5",8,0)
268 D INIT ;set counters to 0, SHIFT(#) = start time in seconds
269"RTN","EDPRPT5",9,0)
270 I 'SHIFT D ERR^EDPRPT(2300013) Q
271"RTN","EDPRPT5",10,0)
272 S BEG=$S(SHIFT(1)>0:$$FMADD^XLFDT(DAY,-1,,,SHIFT(SHIFT)),1:DAY)
273"RTN","EDPRPT5",11,0)
274 S END=$S(SHIFT(1)>0:$$FMADD^XLFDT(DAY,,,,SHIFT(SHIFT)),1:DAY_".2359")
275"RTN","EDPRPT5",12,0)
276 S IN=BEG-.000001 F S IN=$O(^EDP(230,"ATI",EDPSITE,IN)) Q:'IN Q:IN>END D
277"RTN","EDPRPT5",13,0)
278 . S LOG=0 F S LOG=+$O(^EDP(230,"ATI",EDPSITE,IN,LOG)) Q:LOG<1 D
279"RTN","EDPRPT5",14,0)
280 .. S X0=^EDP(230,LOG,0),X1=$G(^(1)),X3=$G(^(3)),X4=$G(^(4,1,0))
281"RTN","EDPRPT5",15,0)
282 .. S STS=$$ECODE^EDPRPT($P(X3,U,2))
283"RTN","EDPRPT5",16,0)
284 .. S DISP=$$ECODE^EDPRPT($P(X1,U,2)),DISP=$$UP^XLFSTR(DISP)
285"RTN","EDPRPT5",17,0)
286 .. S OUT=$P(X0,U,9) ;S:OUT="" OUT=NOW
287"RTN","EDPRPT5",18,0)
288 .. S ELAPSE=$S(OUT:($$FMDIFF^XLFDT(OUT,IN,2)\60),1:0) ;#min
289"RTN","EDPRPT5",19,0)
290 .. S ADMDEC=$$ADMIT^EDPRPT(LOG)
291"RTN","EDPRPT5",20,0)
292D1 .. ; all visits
293"RTN","EDPRPT5",21,0)
294 .. S S=$$SHIFT(IN,1),SOUT=$$SHIFT(OUT,1)
295"RTN","EDPRPT5",22,0)
296 .. S CNT(S)=CNT(S)+1
297"RTN","EDPRPT5",23,0)
298 .. S:'$P(X3,U,3) TRG(S)=TRG(S)+1
299"RTN","EDPRPT5",24,0)
300 .. S:ELAPSE>359 HR6(S)=HR6(S)+1
301"RTN","EDPRPT5",25,0)
302 .. S:DISP="O"!(DISP="NVA") OTH(S)=OTH(S)+1
303"RTN","EDPRPT5",26,0)
304 .. S:DISP="D" DIE(S)=DIE(S)+1
305"RTN","EDPRPT5",27,0)
306 .. S:$$MISSEDOP^EDPRPT3(DISP) MO(S)=MO(S)+1
307"RTN","EDPRPT5",28,0)
308 .. S:DISP="" UNK(S)=UNK(S)+1
309"RTN","EDPRPT5",29,0)
310 .. I $L(STS),$$UP^XLFSTR(STS)'="GONE",S'=SOUT S OCB(S)=OCB(S)+1
311"RTN","EDPRPT5",30,0)
312D2 S OUT=BEG-.000001 F S OUT=$O(^EDP(230,"ATO",EDPSITE,OUT)) Q:'OUT Q:OUT>END D
313"RTN","EDPRPT5",31,0)
314 . S LOG=0 F S LOG=+$O(^EDP(230,"ATO",EDPSITE,OUT,LOG)) Q:LOG<1 D
315"RTN","EDPRPT5",32,0)
316 .. S X0=^EDP(230,LOG,0),X1=$G(^(1))
317"RTN","EDPRPT5",33,0)
318 .. S SOUT=$$SHIFT(OUT,1),DX(SOUT)=DX(SOUT)+1
319"RTN","EDPRPT5",34,0)
320 .. S IN=$P(X0,U,8) S:IN<BEG PREV=PREV+1
321"RTN","EDPRPT5",35,0)
322 .. S DISP=$$ECODE^EDPRPT($P(X1,U,2))
323"RTN","EDPRPT5",36,0)
324 .. S ADMDEC=$$ADMIT^EDPRPT(LOG)
325"RTN","EDPRPT5",37,0)
326 .. I ADMDEC,ADMDEC>BEG,$$VADMIT^EDPRPT2(DISP) S S=$$SHIFT(ADMDEC,1),VA(S)=VA(S)+1
327"RTN","EDPRPT5",38,0)
328D3 ; calculate #carried over
329"RTN","EDPRPT5",39,0)
330 S S=SUB(SHIFT),NEXT(S)=PREV+CNT(S)-DX(S)
331"RTN","EDPRPT5",40,0)
332 S PREV("one")=NEXT(S),PREV(S)=PREV
333"RTN","EDPRPT5",41,0)
334 F I=1:1:(SHIFT-1) S S=SUB(I),X=SUB($S(I>1:I-1,1:SHIFT)),NEXT(S)=NEXT(X)+CNT(S)-DX(S)
335"RTN","EDPRPT5",42,0)
336 F I=2:1:(SHIFT-1) S PREV(SUB(I))=NEXT(SUB(I-1))
337"RTN","EDPRPT5",43,0)
338 ;S NEXT("three")=PREV+CNT("three")-DX("three")
339"RTN","EDPRPT5",44,0)
340 ;S NEXT("one")=NEXT("three")+CNT("one")-DX("one")
341"RTN","EDPRPT5",45,0)
342 ;S NEXT("two")=NEXT("one")+CNT("two")-DX("two")
343"RTN","EDPRPT5",46,0)
344 ;S PREV("one")=NEXT("three"),PREV("two")=NEXT("one"),PREV("three")=PREV
345"RTN","EDPRPT5",47,0)
346D4 ; return column info
347"RTN","EDPRPT5",48,0)
348 F I=1:1:SHIFT D ;convert #seconds to HH[:MM]
349"RTN","EDPRPT5",49,0)
350 . N X,Y S X=SHIFT(I),Y=X\60
351"RTN","EDPRPT5",50,0)
352 . ;S Y=X\3600 S:Y=0 Y=12 S:Y>12 Y=Y-12
353"RTN","EDPRPT5",51,0)
354 . S SHIFT(I)=$$ETIME^EDPRPT(Y) ;Y_$S(X#3600:":"_(X#3600)\60,1:"")
355"RTN","EDPRPT5",52,0)
356 F I=1:1:SHIFT D ;build column captions
357"RTN","EDPRPT5",53,0)
358 . S COL(I,"name")=SHIFT(I)_" to "_SHIFT($S(I+1>SHIFT:1,1:I+1))
359"RTN","EDPRPT5",54,0)
360 . S COL(I,"shiftId")=SUB(I)
361"RTN","EDPRPT5",55,0)
362 ;S COL(1,"name")="7 to 3",COL(1,"shiftId")="one"
363"RTN","EDPRPT5",56,0)
364 ;S COL(2,"name")="3 to 11",COL(2,"shiftId")="two"
365"RTN","EDPRPT5",57,0)
366 ;S COL(3,"name")="11 to 7",COL(3,"shiftId")="three"
367"RTN","EDPRPT5",58,0)
368 I $G(CSV) D CSV Q
369"RTN","EDPRPT5",59,0)
370 D XML^EDPX("<columns>")
371"RTN","EDPRPT5",60,0)
372 F S=1:1:SHIFT K X M X=COL(S) S X=$$XMLA^EDPX("column",.X) D XML^EDPX(X)
373"RTN","EDPRPT5",61,0)
374 D XML^EDPX("</columns>")
375"RTN","EDPRPT5",62,0)
376D5 ; return counts and averages as XML
377"RTN","EDPRPT5",63,0)
378 D XML^EDPX("<categories>")
379"RTN","EDPRPT5",64,0)
380 S X=$$XMLA^EDPX("category",.PREV) D XML^EDPX(X)
381"RTN","EDPRPT5",65,0)
382 S X=$$XMLA^EDPX("category",.CNT) D XML^EDPX(X)
383"RTN","EDPRPT5",66,0)
384 S X=$$XMLA^EDPX("category",.DX) D XML^EDPX(X)
385"RTN","EDPRPT5",67,0)
386 S X=$$XMLA^EDPX("category",.VA) D XML^EDPX(X)
387"RTN","EDPRPT5",68,0)
388 S X=$$XMLA^EDPX("category",.OTH) D XML^EDPX(X)
389"RTN","EDPRPT5",69,0)
390 S X=$$XMLA^EDPX("category",.HR6) D XML^EDPX(X)
391"RTN","EDPRPT5",70,0)
392 S X=$$XMLA^EDPX("category",.TRG) D XML^EDPX(X)
393"RTN","EDPRPT5",71,0)
394 S X=$$XMLA^EDPX("category",.OCB) D XML^EDPX(X)
395"RTN","EDPRPT5",72,0)
396 S X=$$XMLA^EDPX("category",.MO) D XML^EDPX(X)
397"RTN","EDPRPT5",73,0)
398 S X=$$XMLA^EDPX("category",.DIE) D XML^EDPX(X)
399"RTN","EDPRPT5",74,0)
400 S X=$$XMLA^EDPX("category",.UNK) D XML^EDPX(X)
401"RTN","EDPRPT5",75,0)
402 S X=$$XMLA^EDPX("category",.NEXT) D XML^EDPX(X)
403"RTN","EDPRPT5",76,0)
404 D XML^EDPX("</categories>")
405"RTN","EDPRPT5",77,0)
406 Q
407"RTN","EDPRPT5",78,0)
408 ;
409"RTN","EDPRPT5",79,0)
410CSV ; Return headers, counts and averages as CSV
411"RTN","EDPRPT5",80,0)
412 N X,TAB S TAB=$C(9)
413"RTN","EDPRPT5",81,0)
414 S X="Category"_TAB_COL(SHIFT,"name")
415"RTN","EDPRPT5",82,0)
416 F I=1:1:(SHIFT-1) S X=X_TAB_COL(I,"name")
417"RTN","EDPRPT5",83,0)
418 D ADD^EDPCSV(X) ;headers
419"RTN","EDPRPT5",84,0)
420 D ROW("Carried over at Report Start",.PREV)
421"RTN","EDPRPT5",85,0)
422 D ROW("Number of New Patients",.CNT)
423"RTN","EDPRPT5",86,0)
424 D ROW("Number of Patients Discharged",.DX)
425"RTN","EDPRPT5",87,0)
426 D ROW("Number Dec to Admit to VA",.VA)
427"RTN","EDPRPT5",88,0)
428 D ROW("Number Dec to Admit to Other",.OTH)
429"RTN","EDPRPT5",89,0)
430 D ROW("Number over Six Hours",.HR6)
431"RTN","EDPRPT5",90,0)
432 D ROW("Number Waiting for Triage",.TRG)
433"RTN","EDPRPT5",91,0)
434 D ROW("Number of Occupied Beds",.OCB)
435"RTN","EDPRPT5",92,0)
436 D ROW("Number of Missed Opportunities",.MO)
437"RTN","EDPRPT5",93,0)
438 D ROW("Number Deceased",.DIE)
439"RTN","EDPRPT5",94,0)
440 D ROW("Number With No Disposition",.UNK)
441"RTN","EDPRPT5",95,0)
442 D ROW("Carry over to Next Shift",.NEXT)
443"RTN","EDPRPT5",96,0)
444 Q
445"RTN","EDPRPT5",97,0)
446 ;
447"RTN","EDPRPT5",98,0)
448ROW(NAME,LIST) ; add row
449"RTN","EDPRPT5",99,0)
450 N S,I
451"RTN","EDPRPT5",100,0)
452 S S=SUB(SHIFT),X=NAME_TAB_LIST(S)
453"RTN","EDPRPT5",101,0)
454 F I=1:1:(SHIFT-1) S S=SUB(I),X=X_TAB_LIST(S)
455"RTN","EDPRPT5",102,0)
456 D ADD^EDPCSV(X)
457"RTN","EDPRPT5",103,0)
458 Q
459"RTN","EDPRPT5",104,0)
460 ;
461"RTN","EDPRPT5",105,0)
462INIT ; Initialize counters and sums
463"RTN","EDPRPT5",106,0)
464 N I,S
465"RTN","EDPRPT5",107,0)
466 S PREV=0,DAY=$P(DAY,".")
467"RTN","EDPRPT5",108,0)
468 D SETUP F I=1:1:SHIFT D
469"RTN","EDPRPT5",109,0)
470 . S S=$$WORD(I),SUB(I)=S
471"RTN","EDPRPT5",110,0)
472 . S CNT(S)=0,CNT("category")="Number of New Patients"
473"RTN","EDPRPT5",111,0)
474 . S DX(S)=0,DX("category")="Number of Patients Discharged"
475"RTN","EDPRPT5",112,0)
476 . S VA(S)=0,VA("category")="Number Dec to Admit to VA"
477"RTN","EDPRPT5",113,0)
478 . S OTH(S)=0,OTH("category")="Number Dec to Admit to Other"
479"RTN","EDPRPT5",114,0)
480 . S HR6(S)=0,HR6("category")="Number over Six Hours"
481"RTN","EDPRPT5",115,0)
482 . S TRG(S)=0,TRG("category")="Number Waiting for Triage" ;no acuity
483"RTN","EDPRPT5",116,0)
484 . S OCB(S)=0,OCB("category")="Number of Occupied Beds"
485"RTN","EDPRPT5",117,0)
486 . S MO(S)=0,MO("category")="Number of Missed Opportunities"
487"RTN","EDPRPT5",118,0)
488 . S DIE(S)=0,DIE("category")="Number Deceased"
489"RTN","EDPRPT5",119,0)
490 . S UNK(S)=0,UNK("category")="Number With No Disposition"
491"RTN","EDPRPT5",120,0)
492 . S PREV(S)=0,PREV("category")="Carried over at Report Start"
493"RTN","EDPRPT5",121,0)
494 . S NEXT(S)=0,NEXT("category")="Carry over to Next Shift"
495"RTN","EDPRPT5",122,0)
496 Q
497"RTN","EDPRPT5",123,0)
498 ;
499"RTN","EDPRPT5",124,0)
500WORD(X) ; Return name of number X
501"RTN","EDPRPT5",125,0)
502 N Y S Y=$S(X=1:"one",X=2:"two",X=3:"three",X=4:"four",X=5:"five",X=6:"six",X=7:"seven",X=8:"eight",X=9:"nine",X=10:"ten",X=11:"eleven",X=12:"twelve",1:"none")
503"RTN","EDPRPT5",126,0)
504 Q Y
505"RTN","EDPRPT5",127,0)
506 ;
507"RTN","EDPRPT5",128,0)
508SETUP ; Create SHIFT(#) list of shift times
509"RTN","EDPRPT5",129,0)
510 N TA,X1,X,DUR
511"RTN","EDPRPT5",130,0)
512 S TA=+$O(^EDPB(231.9,"C",EDPSITE,0)),X1=$G(^EDPB(231.9,TA,1))
513"RTN","EDPRPT5",131,0)
514 S X=$P(X1,U,6),DUR=$P(X1,U,7)*60 I DUR'>0 S SHIFT=0 Q
515"RTN","EDPRPT5",132,0)
516 S SHIFT=1,SHIFT(1)=X*60 ;seconds
517"RTN","EDPRPT5",133,0)
518 F S X=SHIFT(SHIFT)+DUR Q:X>86340 S SHIFT=SHIFT+1,SHIFT(SHIFT)=X
519"RTN","EDPRPT5",134,0)
520 Q
521"RTN","EDPRPT5",135,0)
522 ;
523"RTN","EDPRPT5",136,0)
524SHIFT(X,TXT) ; Return shift # for time X using SHIFT(#)
525"RTN","EDPRPT5",137,0)
526 I $G(X)="" Q 0
527"RTN","EDPRPT5",138,0)
528 N TM,Y
529"RTN","EDPRPT5",139,0)
530 S TM=$P($$FMTH^XLFDT(X),",",2) ;#seconds since midnight
531"RTN","EDPRPT5",140,0)
532 ;;UJO/AS fix mathematical expressions that GT.M can not compile
533"RTN","EDPRPT5",141,0)
534 ;I TM<SHIFT(1)!(TM>=SHIFT(SHIFT)) S Y=SHIFT
535"RTN","EDPRPT5",142,0)
536 ;;
537"RTN","EDPRPT5",143,0)
538 I TM<SHIFT(1)!((TM>SHIFT(SHIFT))!(TM=SHIFT(SHIFT))) S Y=SHIFT
539"RTN","EDPRPT5",144,0)
540 E F I=2:1:SHIFT I TM<SHIFT(I) S Y=I-1 Q
541"RTN","EDPRPT5",145,0)
542 S:$G(TXT) Y=$$WORD(Y)
543"RTN","EDPRPT5",146,0)
544 ;S Y=$S(TM<25200:"three",TM<54000:"one",TM<82800:"two",1:"three")
545"RTN","EDPRPT5",147,0)
546 Q Y
547"RTN","EDPRPT5",148,0)
548 ;
549"RTN","EDPRPT5",149,0)
550ECODE(IEN) ; Return external value for an Acuity code
551"RTN","EDPRPT5",150,0)
552 N X,Y S X=$P($G(^EDPB(233.1,IEN,0)),U,3) ;code
553"RTN","EDPRPT5",151,0)
554 S Y=$S(X="":"none",'X:X,X=1:"one",X=2:"two",X=3:"three",X=4:"four",X=5:"five",1:"X")
555"RTN","EDPRPT5",152,0)
556 Q Y
557"RTN","EDPRPTBV")
5580^2^B22104348
559"RTN","EDPRPTBV",1,0)
560EDPRPTBV ;SLC/MKB - BVAC Report
561"RTN","EDPRPTBV",2,0)
562 ;;1.0;EMERGENCY DEPARTMENT;;Sep 30, 2009;Build 6
563"RTN","EDPRPTBV",3,0)
564 ;
565"RTN","EDPRPTBV",4,0)
566EN(BEG,END) ; Get Activity Report for EDPSITE by date range
567"RTN","EDPRPTBV",5,0)
568 N LOG,X,X0,X1,X3,DX,IN,OUT,ROW,ICD,I
569"RTN","EDPRPTBV",6,0)
570 N ELAPSE,TRIAGE,ADMDEC,ADMDEL,CNT,ADM,MIN,AVG
571"RTN","EDPRPTBV",7,0)
572 D INIT ;set counters, sums to 0
573"RTN","EDPRPTBV",8,0)
574 D:'$G(CSV) XML^EDPX("<logEntries>") I $G(CSV) D ;headers
575"RTN","EDPRPTBV",9,0)
576 . N TAB S TAB=$C(9)
577"RTN","EDPRPTBV",10,0)
578 . S X="Patient"_TAB_"Time In"_TAB_"Time Out"_TAB_"Complaint"_TAB_"MD"_TAB_"Acuity"_TAB_"Elapsed"_TAB_"Triage"_TAB_"Dispo"_TAB_"Admit Dec"_TAB_"Admit Delay"_TAB_"Diagnosis"_TAB_"ICD9"
579"RTN","EDPRPTBV",11,0)
580 . S X=X_TAB_"Viet Vet"_TAB_"Agent Orange"_TAB_"OEF/OIF"_TAB_"Pers Gulf"_TAB_"VA Pension"_TAB_"POW"_TAB_"Serv Conn %"_TAB_"Purp Hrt"_TAB_"Unemploy"_TAB_"Combat End"
581"RTN","EDPRPTBV",12,0)
582 . D ADD^EDPCSV(X)
583"RTN","EDPRPTBV",13,0)
584 S IN=BEG-.000001
585"RTN","EDPRPTBV",14,0)
586 F S IN=$O(^EDP(230,"ATI",EDPSITE,IN)) Q:'IN Q:IN>END S LOG=0 F S LOG=+$O(^EDP(230,"ATI",EDPSITE,IN,LOG)) Q:LOG<1 D
587"RTN","EDPRPTBV",15,0)
588 . S X0=^EDP(230,LOG,0),X1=$G(^(1)),X3=$G(^(3))
589"RTN","EDPRPTBV",16,0)
590 . S DX=$$BVAC(+$P(X0,U,3),LOG) Q:DX="" ;no codes in range
591"RTN","EDPRPTBV",17,0)
592 . S CNT=CNT+1,OUT=$P(X0,U,9) ;S:OUT="" OUT=NOW
593"RTN","EDPRPTBV",18,0)
594 . S ELAPSE=$S(OUT:($$FMDIFF^XLFDT(OUT,IN,2)\60),1:0)
595"RTN","EDPRPTBV",19,0)
596 . S MIN("elapsed")=MIN("elapsed")+ELAPSE
597"RTN","EDPRPTBV",20,0)
598 . S X=$$ACUITY^EDPRPT(LOG),TRIAGE=0 ;S:X<1 X=OUT
599"RTN","EDPRPTBV",21,0)
600 . S:X TRIAGE=($$FMDIFF^XLFDT(X,IN,2)\60)
601"RTN","EDPRPTBV",22,0)
602 . S MIN("triage")=MIN("triage")+TRIAGE
603"RTN","EDPRPTBV",23,0)
604 . S (ADMDEC,ADMDEL)=""
605"RTN","EDPRPTBV",24,0)
606 . S X=$$ADMIT^EDPRPT(LOG) I X S ADM=ADM+1 D ;decision to admit
607"RTN","EDPRPTBV",25,0)
608 .. S ADMDEC=($$FMDIFF^XLFDT(X,IN,2)\60)
609"RTN","EDPRPTBV",26,0)
610 .. S ADMDEL=$S(OUT:($$FMDIFF^XLFDT(OUT,X,2)\60),1:0)
611"RTN","EDPRPTBV",27,0)
612 .. S MIN("admDec")=MIN("admDec")+ADMDEC
613"RTN","EDPRPTBV",28,0)
614 .. S MIN("admDel")=MIN("admDel")+ADMDEL
615"RTN","EDPRPTBV",29,0)
616 . ;
617"RTN","EDPRPTBV",30,0)
618BV1 . ; add row to report
619"RTN","EDPRPTBV",31,0)
620 . ;S ICD=$P($G(^ICD9(+$P(X4,U,2),0)),U) Q:ICD<290 Q:ICD>316
621"RTN","EDPRPTBV",32,0)
622 . K ROW S ROW("patient")=$P(X0,U,4)
623"RTN","EDPRPTBV",33,0)
624 . S ROW("inTS")=$S($G(CSV):$$EDATE^EDPRPT(IN),1:IN)
625"RTN","EDPRPTBV",34,0)
626 . S ROW("outTS")=$S($G(CSV):$$EDATE^EDPRPT(OUT),1:OUT)
627"RTN","EDPRPTBV",35,0)
628 . S ROW("complaint")=$P(X1,U)
629"RTN","EDPRPTBV",36,0)
630 . S ROW("md")=$$EPERS^EDPRPT($P(X3,U,5))
631"RTN","EDPRPTBV",37,0)
632 . S ROW("acuity")=$$ECODE^EDPRPT($P(X3,U,3))
633"RTN","EDPRPTBV",38,0)
634 . S ROW("elapsed")=ELAPSE_$S(ELAPSE>359:" *",1:"")
635"RTN","EDPRPTBV",39,0)
636 . S ROW("triage")=TRIAGE
637"RTN","EDPRPTBV",40,0)
638 . S ROW("disposition")=$$ECODE^EDPRPT($P(X1,U,2))
639"RTN","EDPRPTBV",41,0)
640 . S ROW("admDec")=ADMDEC,ROW("admDel")=ADMDEL
641"RTN","EDPRPTBV",42,0)
642 . S ROW("icd")=$P(DX,U),ROW("dx")=$P(DX,U,2)
643"RTN","EDPRPTBV",43,0)
644 . ; get other patient attributes from VADPT
645"RTN","EDPRPTBV",44,0)
646 . N DFN,VAEL,VASV,VAMB,VAERR
647"RTN","EDPRPTBV",45,0)
648 . S DFN=$P(X0,U,6) I DFN D 8^VADPT D
649"RTN","EDPRPTBV",46,0)
650 .. S ROW("vietnam")=$S(VASV(1):"Y",1:"N")
651"RTN","EDPRPTBV",47,0)
652 .. S ROW("agentOrange")=$S(VASV(2):"Y",1:"N")
653"RTN","EDPRPTBV",48,0)
654 .. S ROW("iraq")=$S(VASV(11)!VASV(12)!VASV(13):"Y",1:"N")
655"RTN","EDPRPTBV",49,0)
656 .. S ROW("persGulf")=$P($G(^DPT(DFN,.322)),U,10)
657"RTN","EDPRPTBV",50,0)
658 .. S ROW("vaPension")=$S(VAMB(4):"Y",1:"N")
659"RTN","EDPRPTBV",51,0)
660 .. S ROW("pow")=$S(VASV(4):"Y",1:"N")
661"RTN","EDPRPTBV",52,0)
662 .. S ROW("servConnPct")=+$P(VAEL(3),U,2)
663"RTN","EDPRPTBV",53,0)
664 .. S ROW("purpleHeart")=$S(VASV(9):"Y",1:"N")
665"RTN","EDPRPTBV",54,0)
666 .. ; ROW("unemployable")=$P($G(^DGEN(27.11,DFN,"E")),U,17) ;or VAPD(7)=3^NOT EMPLOYED ??
667"RTN","EDPRPTBV",55,0)
668 .. S ROW("combatEndDT")=$P($G(VASV(10,1)),U)
669"RTN","EDPRPTBV",56,0)
670BV2 . ;
671"RTN","EDPRPTBV",57,0)
672 . I '$G(CSV) S X=$$XMLA^EDPX("log",.ROW) D XML^EDPX(X) Q
673"RTN","EDPRPTBV",58,0)
674 . S X=ROW("patient")
675"RTN","EDPRPTBV",59,0)
676 . F I="inTS","outTS","complaint","md","acuity","elapsed","triage","disposition","admDec","admDel","dx","icd" S X=X_$C(9)_$G(ROW(I))
677"RTN","EDPRPTBV",60,0)
678 . F I="vietnam","agentOrange","iraq","persGulf","vaPension","pow","servConn%","purpleHeart","unemployable","combatEndDT" S X=X_$C(9)_$G(ROW(I))
679"RTN","EDPRPTBV",61,0)
680 . D ADD^EDPCSV(X)
681"RTN","EDPRPTBV",62,0)
682 D:'$G(CSV) XML^EDPX("</logEntries>")
683"RTN","EDPRPTBV",63,0)
684 ;
685"RTN","EDPRPTBV",64,0)
686BV3 ; calculate & include averages
687"RTN","EDPRPTBV",65,0)
688 Q:CNT<1 ;no visits found
689"RTN","EDPRPTBV",66,0)
690 S ELAPSE=$$ETIME^EDPRPT(MIN("elapsed")\CNT),AVG("elapsed")=ELAPSE
691"RTN","EDPRPTBV",67,0)
692 S TRIAGE=$$ETIME^EDPRPT(MIN("triage")\CNT),AVG("triage")=TRIAGE
693"RTN","EDPRPTBV",68,0)
694 S ADMDEC=$S(ADM:$$ETIME^EDPRPT(MIN("admDec")\ADM),1:"00:00")
695"RTN","EDPRPTBV",69,0)
696 S ADMDEL=$S(ADM:$$ETIME^EDPRPT(MIN("admDel")\ADM),1:"00:00")
697"RTN","EDPRPTBV",70,0)
698 S AVG("admDec")=ADMDEC,AVG("admDel")=ADMDEL,AVG("total")=CNT
699"RTN","EDPRPTBV",71,0)
700 ;
701"RTN","EDPRPTBV",72,0)
702 I $G(CSV) D Q ;CSV format
703"RTN","EDPRPTBV",73,0)
704 . N TAB,D S TAB=$C(9)
705"RTN","EDPRPTBV",74,0)
706 . D BLANK^EDPCSV
707"RTN","EDPRPTBV",75,0)
708 . S X=TAB_"Total Patients"_TAB_CNT_TAB_"Averages Per Patient"_TAB_TAB_TAB_ELAPSE_TAB_TRIAGE_TAB_ADMDEC_TAB_ADMDEL
709"RTN","EDPRPTBV",76,0)
710 . D ADD^EDPCSV(X),BLANK^EDPCSV
711"RTN","EDPRPTBV",77,0)
712 D XML^EDPX("<averages>")
713"RTN","EDPRPTBV",78,0)
714 S X=$$XMLA^EDPX("average",.AVG) D XML^EDPX(X)
715"RTN","EDPRPTBV",79,0)
716 D XML^EDPX("</averages>")
717"RTN","EDPRPTBV",80,0)
718 Q
719"RTN","EDPRPTBV",81,0)
720 ;
721"RTN","EDPRPTBV",82,0)
722INIT ; Initialize counters and sums
723"RTN","EDPRPTBV",83,0)
724 N I,X S (CNT,ADM)=0
725"RTN","EDPRPTBV",84,0)
726 F I="elapsed","triage","admDec","admDel" S MIN(I)=0
727"RTN","EDPRPTBV",85,0)
728 Q
729"RTN","EDPRPTBV",86,0)
730 ;
731"RTN","EDPRPTBV",87,0)
732ECODE(IEN) ; Return external value for a Code
733"RTN","EDPRPTBV",88,0)
734 Q:IEN $P($G(^EDPB(233.1,IEN,0)),U,2) ;name
735"RTN","EDPRPTBV",89,0)
736 Q ""
737"RTN","EDPRPTBV",90,0)
738 ;
739"RTN","EDPRPTBV",91,0)
740BVAC(AREA,LOG) ; -- Return ICD^text of diagnosis in range, else null
741"RTN","EDPRPTBV",92,0)
742 N X,Y,I,EDPDX S Y=""
743"RTN","EDPRPTBV",93,0)
744 D DXALL^EDPQPCE(AREA,LOG,.EDPDX)
745"RTN","EDPRPTBV",94,0)
746 ;;UJO/AS fix mathematical expressions that GT.M can not compile
747"RTN","EDPRPTBV",95,0)
748 ; S I=0 F S I=$O(EDPDX(I)) Q:I<1 S X=$G(EDPDX(I)) I 290<=+X,+X<=316 S Y=X Q
749"RTN","EDPRPTBV",96,0)
750 ;;
751"RTN","EDPRPTBV",97,0)
752 S I=0 F S I=$O(EDPDX(I)) Q:I<1 S X=$G(EDPDX(I)) I ((290<+X)!(290=+X)),((+X<316)!(+X=316)) S Y=X Q
753"RTN","EDPRPTBV",98,0)
754 Q Y
755"RTN","EDPYPRE")
7560^4^B9222306
757"RTN","EDPYPRE",1,0)
758EDPYPRE ;SLC/KCM - Pre-init for facility install
759"RTN","EDPYPRE",2,0)
760 ;;1.0;EMERGENCY DEPARTMENT;;Sep 30, 2009;Build 6
761"RTN","EDPYPRE",3,0)
762 ;
763"RTN","EDPYPRE",4,0)
764 S ^TMP("EDP-LAST-VERSION")=+$P($$VERSRV,"1.0-T",2)
765"RTN","EDPYPRE",5,0)
766 ;
767"RTN","EDPYPRE",6,0)
768 D FIXT5,DELFLDS,DELCODES,CHGNAMES
769"RTN","EDPYPRE",7,0)
770 Q
771"RTN","EDPYPRE",8,0)
772 ;
773"RTN","EDPYPRE",9,0)
774DELFLDS ; delete obsolete fields
775"RTN","EDPYPRE",10,0)
776 I $$VERGTE(20) Q ; only convert if version <20
777"RTN","EDPYPRE",11,0)
778 ;
779"RTN","EDPYPRE",12,0)
780 N DIK,DA
781"RTN","EDPYPRE",13,0)
782 I $D(^DD(230.1,1)) D
783"RTN","EDPYPRE",14,0)
784 . S DIK="^DD(230.1,",DA=1,DA(1)=230.1
785"RTN","EDPYPRE",15,0)
786 . D ^DIK
787"RTN","EDPYPRE",16,0)
788 I $D(^DD(231.9,.04)) D
789"RTN","EDPYPRE",17,0)
790 . S DIK="^DD(231.9,",DA=.04,DA(1)=231.9
791"RTN","EDPYPRE",18,0)
792 . D ^DIK
793"RTN","EDPYPRE",19,0)
794 Q
795"RTN","EDPYPRE",20,0)
796DELCODES ; delete site code sets
797"RTN","EDPYPRE",21,0)
798 I $$VERGTE(16) Q ; only convert if version <16
799"RTN","EDPYPRE",22,0)
800 ;
801"RTN","EDPYPRE",23,0)
802 N X,DIK,DA
803"RTN","EDPYPRE",24,0)
804 S X="" F S X=$O(^EDPB(233.2,"B",X)) Q:X="" D
805"RTN","EDPYPRE",25,0)
806 . I $P(X,".")="edp" Q
807"RTN","EDPYPRE",26,0)
808 . S DA=$O(^EDPB(233.2,"B",X,0)) Q:'DA
809"RTN","EDPYPRE",27,0)
810 . S DIK="^EDPB(233.2,"
811"RTN","EDPYPRE",28,0)
812 . D ^DIK
813"RTN","EDPYPRE",29,0)
814 Q
815"RTN","EDPYPRE",30,0)
816CHGNAMES ; change code names
817"RTN","EDPYPRE",31,0)
818 I $$VERGTE(20) Q ; only convert if version <20
819"RTN","EDPYPRE",32,0)
820 ;
821"RTN","EDPYPRE",33,0)
822 D CHG("edp.source.ambulance","zzedp.source.ambulance")
823"RTN","EDPYPRE",34,0)
824 D CHG("edp.source.code","zzedp.source.code")
825"RTN","EDPYPRE",35,0)
826 D CHG("edp.source.walk-in","zzedp.source.walk-in")
827"RTN","EDPYPRE",36,0)
828 D CHG("edp.source.cboc","edp.source.clinic-offsite")
829"RTN","EDPYPRE",37,0)
830 D CHG("edp.source.clinic","edp.source.clinic-onsite")
831"RTN","EDPYPRE",38,0)
832 D CHG("edp.source.nhcu","edp.source.nhcu-onsite")
833"RTN","EDPYPRE",39,0)
834 D CHG("edp.status.observation","zzedp.status.observation")
835"RTN","EDPYPRE",40,0)
836 D CHG("edp.status.overflow","zzedp.status.overflow")
837"RTN","EDPYPRE",41,0)
838 D CHG("edp.status.gone","zzedp.status.gone")
839"RTN","EDPYPRE",42,0)
840 D CHG("edp.delay.admitorders","edp.delay.admitdispo")
841"RTN","EDPYPRE",43,0)
842 Q
843"RTN","EDPYPRE",44,0)
844CHG(OLD,NEW) ; change old to new name
845"RTN","EDPYPRE",45,0)
846 Q:'$D(^EDPB(233.1,"B",OLD))
847"RTN","EDPYPRE",46,0)
848 N IEN
849"RTN","EDPYPRE",47,0)
850 S IEN=$O(^EDPB(233.1,"B",OLD,0)) Q:'IEN
851"RTN","EDPYPRE",48,0)
852 N FDA,DIERR
853"RTN","EDPYPRE",49,0)
854 S IEN=IEN_","
855"RTN","EDPYPRE",50,0)
856 S FDA(233.1,IEN,.01)=NEW
857"RTN","EDPYPRE",51,0)
858 D FILE^DIE("","FDA","ERR")
859"RTN","EDPYPRE",52,0)
860 D CLEAN^DILF
861"RTN","EDPYPRE",53,0)
862 Q
863"RTN","EDPYPRE",54,0)
864 ;
865"RTN","EDPYPRE",55,0)
866 ; VERSRV copied from EDPQAR to avoid $T(VERSRV^EDPQAR) error
867"RTN","EDPYPRE",56,0)
868 ;
869"RTN","EDPYPRE",57,0)
870VERSRV() ; Return server version of option name
871"RTN","EDPYPRE",58,0)
872 N EDPLST,VAL
873"RTN","EDPYPRE",59,0)
874 D FIND^DIC(19,"",1,"X","EDPF TRACKING SYSTEM",1,,,,"EDPLST")
875"RTN","EDPYPRE",60,0)
876 S VAL=$G(EDPLST("DILIST","ID",1,1))
877"RTN","EDPYPRE",61,0)
878 S VAL=$P(VAL,"version ",2)
879"RTN","EDPYPRE",62,0)
880 I 'VAL Q "1.0T?"
881"RTN","EDPYPRE",63,0)
882 Q VAL
883"RTN","EDPYPRE",64,0)
884 ;
885"RTN","EDPYPRE",65,0)
886VERGTE(HIGH) ; Return 1 if existing version and greater than HIGH
887"RTN","EDPYPRE",66,0)
888 I $G(^TMP("EDP-LAST-VERSION"))<1 Q 1 ; no prior version
889"RTN","EDPYPRE",67,0)
890 ;;UJO/AS fix mathematical expressions that GT.M can not compile
891"RTN","EDPYPRE",68,0)
892 ;I $G(^TMP("EDP-LAST-VERSION"))>=HIGH Q 1 ; don't convert
893"RTN","EDPYPRE",69,0)
894 ;;
895"RTN","EDPYPRE",70,0)
896 I ($G(^TMP("EDP-LAST-VERSION"))>HIGH)!($G(^TMP("EDP-LAST-VERSION"))=HIGH) Q 1 ; don't convert
897"RTN","EDPYPRE",71,0)
898 Q 0 ; convert
899"RTN","EDPYPRE",72,0)
900 ;
901"RTN","EDPYPRE",73,0)
902FIXT5 ; convert the timezone offset to visit string
903"RTN","EDPYPRE",74,0)
904 ; (change occurred between T5 and T6)
905"RTN","EDPYPRE",75,0)
906 I $$VERGTE(6) Q ; only convert if version <6
907"RTN","EDPYPRE",76,0)
908 ;
909"RTN","EDPYPRE",77,0)
910 N LOG,X0
911"RTN","EDPYPRE",78,0)
912 S LOG=0 F S LOG=$O(^EDP(230,LOG)) Q:'LOG D
913"RTN","EDPYPRE",79,0)
914 . S X0=^EDP(230,LOG,0)
915"RTN","EDPYPRE",80,0)
916 . I $P(X0,U,12)="0" S $P(^EDP(230,LOG,0),U,12)=""
917"RTN","EDPYPRE",81,0)
918 Q
919"RTN","EDPYPRE",82,0)
920 ;. To convert VSTR to VISIT
921"RTN","EDPYPRE",83,0)
922 ;. I $L($P(X0,U,12),";")=3 D
923"RTN","EDPYPRE",84,0)
924 ;.. N VSTR,VISIT,DFN,VISITIEN,I
925"RTN","EDPYPRE",85,0)
926 ;.. S VSTR=$P(X0,U,12),DFN=$P(X0,U,6)
927"RTN","EDPYPRE",86,0)
928 ;.. Q:'DFN
929"RTN","EDPYPRE",87,0)
930 ;.. K ^TMP("PXKENC",$J)
931"RTN","EDPYPRE",88,0)
932 ;.. S VISIT=+$$GETENC^PXAPI(DFN,$P(VSTR,";",2),$P(VSTR,";"))
933"RTN","EDPYPRE",89,0)
934 ;.. I VISIT<0 S $P(^EDP(230,LOG,0),U,12)="" Q
935"RTN","EDPYPRE",90,0)
936 ;.. S VISITIEN=""
937"RTN","EDPYPRE",91,0)
938 ;.. F I=1:1:$L(VISIT,U) I $P(^TMP("PXKENC",$J,$P(VISIT,U,I),"VST",$P(VISIT,U,I),0),U,6)=DUZ(2) S VISITIEN=$P(VISIT,U,I) Q
939"RTN","EDPYPRE",92,0)
940 ;.. S $P(^EDP(230,LOG,0),U,12)=VISITIEN
941"RTN","EDPYPRE",93,0)
942 Q
943"RTN","XOBSRA1")
9440^5^B4031966
945"RTN","XOBSRA1",1,0)
946XOBSRA1 ;mjk,esd/alb - VistALink Reauthentication Code ; 05/22/2003 07:00
947"RTN","XOBSRA1",2,0)
948 ;;1.5;VistALink Security;;Sep 09, 2005;Build 6
949"RTN","XOBSRA1",3,0)
950 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
951"RTN","XOBSRA1",4,0)
952 ;
953"RTN","XOBSRA1",5,0)
954 QUIT
955"RTN","XOBSRA1",6,0)
956 ;
957"RTN","XOBSRA1",7,0)
958KILL ; -- clean up partition's local symbol table ; called from INIT^XOBSRA
959"RTN","XOBSRA1",8,0)
960 ;SET AAXOB="before" DO ^%ZTER ; -- used to view symbol table 'before' state
961"RTN","XOBSRA1",9,0)
962 ;
963"RTN","XOBSRA1",10,0)
964 IF XOBOS["OpenM" DO
965"RTN","XOBSRA1",11,0)
966 . ; -- Stack: CACHEVMS^XOBVTCP
967"RTN","XOBSRA1",12,0)
968 . ; SPAWN^XOBVLL
969"RTN","XOBSRA1",13,0)
970 . ; NXTCALL^XOBVLL
971"RTN","XOBSRA1",14,0)
972 . ; EN^XOBVRM
973"RTN","XOBSRA1",15,0)
974 . ; EN^XOBVRPC()
975"RTN","XOBSRA1",16,0)
976 . ; SETUPDUZ^XOBSRA()
977"RTN","XOBSRA1",17,0)
978 . ;
979"RTN","XOBSRA1",18,0)
980 . ; -- NEW non-XOB variables created in above stack
981"RTN","XOBSRA1",19,0)
982 . NEW DIQUIET,DX,DY,RPC0,RPCNAME,RPCIEN,TAG,ROU,METHSIG,XRTN
983"RTN","XOBSRA1",20,0)
984 . DO CACHE("XOB")
985"RTN","XOBSRA1",21,0)
986 ELSE DO
987"RTN","XOBSRA1",22,0)
988 . DO OTHER
989"RTN","XOBSRA1",23,0)
990 ;
991"RTN","XOBSRA1",24,0)
992 ;SET AAXOB="after" DO ^%ZTER ; -- used to view symbol table 'after' state
993"RTN","XOBSRA1",25,0)
994 QUIT
995"RTN","XOBSRA1",26,0)
996 ;
997"RTN","XOBSRA1",27,0)
998CACHE(%NS) ; -- KILL all 'L'ocal 'VAR'iables except for a 'N'ame'S'pace (%NS) and Kernel for Cache systems
999"RTN","XOBSRA1",28,0)
1000 NEW %LVAR,%NSLEN
1001"RTN","XOBSRA1",29,0)
1002 SET %NSLEN=$LENGTH(%NS)
1003"RTN","XOBSRA1",30,0)
1004 SET %LVAR=%NS
1005"RTN","XOBSRA1",31,0)
1006 FOR SET %LVAR=$ORDER(@%LVAR) QUIT:%LVAR=""!($EXTRACT(%LVAR,1,%NSLEN)'=%NS) NEW @%LVAR
1007"RTN","XOBSRA1",32,0)
1008 ; -- NEW Kernel variables and do the big KILL
1009"RTN","XOBSRA1",33,0)
1010 DO KILL^XUSCLEAN
1011"RTN","XOBSRA1",34,0)
1012 QUIT
1013"RTN","XOBSRA1",35,0)
1014 ;
1015"RTN","XOBSRA1",36,0)
1016OTHER ; -- explicit NEW'ing for other for non-Cache M implementations
1017"RTN","XOBSRA1",37,0)
1018 ; -- The following are NEW'ed as part KILL^XOBVLL call:
1019"RTN","XOBSRA1",38,0)
1020 ; XOBPORT,XOBSTOP,XOBNULL,XOBOS,XOBSYS,XOBHDLR,XOBOK
1021"RTN","XOBSRA1",39,0)
1022 ; -- additional NEW'ing needed to preserve for CACHEVMS^XOBVTCP
1023"RTN","XOBSRA1",40,0)
1024 NEW XOBEC
1025"RTN","XOBSRA1",41,0)
1026 ; -- additional NEW'ing needed to preserve for SPAWN^XOBVLL
1027"RTN","XOBSRA1",42,0)
1028 NEW XOBLASTR
1029"RTN","XOBSRA1",43,0)
1030 ;;
1031"RTN","XOBSRA1",44,0)
1032 ;;EHS/AFS CHANGE START
1033"RTN","XOBSRA1",45,0)
1034 ;;additional NEW'ing needed to preserve RPC parameters
1035"RTN","XOBSRA1",46,0)
1036 FOR SET I=$ORDER(XOBDATA("XOB RPC","PARAMS",I)) Q:I="" NEW @XOBDATA("XOB RPC","PARAMS",I)
1037"RTN","XOBSRA1",47,0)
1038 ;;EHS/AFS CHANGE END
1039"RTN","XOBSRA1",48,0)
1040 ; -- additional NEW'ing needed to preserve for NXTCALL^XOBVLL
1041"RTN","XOBSRA1",49,0)
1042 NEW XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBDATA,DIQUIET
1043"RTN","XOBSRA1",50,0)
1044 ; -- additional NEW'ing needed to preserve for EN^XOBVRM
1045"RTN","XOBSRA1",51,0)
1046 NEW XOBOPT
1047"RTN","XOBSRA1",52,0)
1048 ; -- additional NEW'ing needed to preserve for EN^XOBVRPC()
1049"RTN","XOBSRA1",53,0)
1050 NEW DX,DY,RPC0,RPCNAME,RPCIEN,TAG,ROU,METHSIG,XOBERR,XOBR,XOBSEC,XOBWRAP,XRTN,XOBRA,XOBVER,XOBPTYPE
1051"RTN","XOBSRA1",54,0)
1052 ; -- additional NEW'ing needed to preserve for SETUPDUZ^XOBSRA()
1053"RTN","XOBSRA1",55,0)
1054 NEW XOBERR,XOBID,XOBTYPE
1055"RTN","XOBSRA1",56,0)
1056 ; -- call KILL^XOBVLL to finish NEW'ing and execute Kernel call to kill
1057"RTN","XOBSRA1",57,0)
1058 DO KILL^XOBVLL
1059"RTN","XOBSRA1",58,0)
1060 QUIT
1061"RTN","XOBSRA1",59,0)
1062 ;
1063"VER")
10648.0^22.0
1065**END**
1066**END**
Note: See TracBrowser for help on using the repository browser.