source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT1.m@ 1499

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1ORMEVNT1 ;SLC/MKB-Trigger HL7 msg off OR events,ORMTIME ;9/9/03 13:00
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,177,186,215**;Dec 17, 1997
3 ;
4 ;DBIA Section
5 ; 3559 - Direct read of ^SRF
6 ;10039 - Direct read of ^DIC(42,
7 ;
8OR2(ORSRDA) ;Queue EDO process to background, return control to surgery
9 ;
10 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
11 S ZTRTN="OR2Q^ORMEVNT1",ZTDTH=$H,ZTDESC="Surgery triggered EDO processing",ZTIO="",ZTSAVE("ORSRDA")="" D ^%ZTLOAD
12 Q
13 ;
14OR2Q ; -- Kill logic, from Surgery package [DBIA #3558]
15 I $D(^XTMP("ORSURG",ORSRDA)) D OR2(ORSRDA) Q ;186 requeue if flag set
16 N X,Y,DA,OREVT,ORSRF,ORACT
17 S OREVT=+$O(^ORE(100.2,"ASR",+$G(ORSRDA),0)) Q:OREVT<1
18 S ORSRF=$G(^SRF(+ORSRDA,.2)),ORACT=$S($L($P(ORSRF,U,12)):"ED",1:"DL")
19 D ACTLOG^OREVNTX(OREVT,ORACT)
20 Q
21 ;
22OR1(ORSRDA,ORSRX) ;Queue EDO process to background, return control to surgery
23 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
24 S ZTRTN="OR1Q^ORMEVNT1",ZTDTH=$H,ZTDESC="Surgery triggered EDO processing",ZTIO="",ZTSAVE("ORSRDA")="",ZTSAVE("ORSRX")="" D ^%ZTLOAD
25 Q
26 ;
27OR1Q ; -- Set logic, from Surgery package [DBIA #3558]
28 I $D(^XTMP("ORSURG",ORSRDA)) D OR1(ORSRDA,ORSRX) Q ;186 requeue if flag set
29 N X S X=ORSRX
30 I $G(^SRF(+$G(ORSRDA),"CON")),$D(^ORE(100.2,"ASR",+^("CON"))) Q ;concurrent
31 Q:$D(^ORE(100.2,"ASR",+$G(ORSRDA))) Q:'$$CURRENT ;edit
32 ;
33 N ORSR0,DFN,VAIP,VAERR,X,Y,DA,ORVP,ORL,ORDIV,ORTS,OREVENT,ORDCRULE,ORPRINT
34 S ORSR0=$G(^SRF(+$G(ORSRDA),0)),DFN=+$P(ORSR0,U)
35 D IN5^VADPT Q:'$G(VAIP(13)) ;not admitted
36 S ^XTMP("ORSURG",ORSRDA)=$$FMADD^XLFDT(DT,5)_U_DT ;186 Set flag
37 S ORL=$P($G(^SRS(+$P(ORSR0,U,2),0)),U)_";SC(",ORDIV=$$DIV(+ORL) ;DBIA #3362
38 I '$G(LOC) S ORL=+$G(^DIC(42,+$G(VAIP(5)),44))_";SC(" ;186 If no O.R. loc then use current loc
39 S ORTS=+$G(VAIP(8)) ; need surg spec too? DBIA #991
40 S ORVP=DFN_";DPT(",OREVENT=$$PATEVT,ORDCRULE=$$DCEVT
41 D:ORDCRULE AUTODC(ORDCRULE,ORSRX) I OREVENT D
42 . D RELEASE(OREVENT),DONE^OREVNTX(OREVENT,ORSRX,,ORSRDA)
43 . D ACTLOG^OREVNTX(OREVENT,"NW","O")
44 I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL)
45 K ^XTMP("ORSURG",ORSRDA) ;186
46 Q
47 ;
48DIV(LOC) ; -- Return Institution file #4 ptr for LOC
49 N X0,Y S X0=$G(^SC(+LOC,0))
50 S Y=$S($P(X0,U,4):$P(X0,U,4),$P(X0,U,15):$$SITE^VASITE(DT,$P(X0,U,15)),1:+$G(DUZ(2)))
51 Q Y
52 ;
53CURRENT() ; -- Is posted mvt the latest one?
54 N Y S Y=$S((DT-X)<1:1,1:0)
55 Q Y
56 ;
57PATEVT() ; -- Find match to new data in Patient Event file
58 N EVT,IFN,X0,Y S EVT=0,Y=""
59 F S EVT=+$O(^ORE(100.2,"AE",+ORVP,EVT)) Q:EVT<1 S IFN=$O(^(EVT,0)) D Q:Y
60 . Q:$$LAPSED^OREVNTX(+IFN) ;don't release orders
61 . S X0=$G(^ORD(100.5,EVT,0))
62 . I $P(X0,U,2)="O",$P(X0,U,3)=ORDIV S Y=+IFN Q
63 Q Y
64 ;
65DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV
66 N Y I '$G(^DPT(+ORVP,.105)) Q 0 ;no auto-dc's if not admitted
67 S Y=+$O(^ORD(100.6,"AE",ORDIV,"O",0))
68 Q Y
69 ;
70AUTODC(ORDC,ORDT) ; -- DC orders based on rule ORDC [also from ORMEVNT]
71 ; Expects VAIP array with current admission data
72 N ORADM,ORNOW,ORN,X,OREASON,ORNATR,ORCREATE,ORPRNT,ORSIG,ORDG,ORI,ORPKG,ORLIST,ORIFN,OR0,ORDER,ORERR
73 S OREASON=+$P($G(^ORD(100.6,ORDC,0)),U,4) I OREASON<1 D
74 . S OREASON=$S('$G(DGPMT):"OROR",DGPMT=1:"ORADMIT",DGPMT=2:"ORTRANS",DGPMT=3:"ORDIS",1:"ORSPEC")
75 . S OREASON=+$O(^ORD(100.03,"C",OREASON,0))
76 S ORNATR=+$P($G(^ORD(100.03,+$G(OREASON),0)),U,7)
77 S:ORNATR'>0 ORNATR=+$O(^ORD(100.02,"C","A",0))
78 S X=$G(^ORD(100.02,ORNATR,1)),ORCREATE=+$P(X,U),ORPRNT=+$P(X,U,2)
79 S ORSIG=$S('ORCREATE:"",1:$P(X,U,4)),ORDG=$O(^ORD(100.98,"B","ALL",0))
80 S ORI=0 F S ORI=$O(^ORD(100.6,ORDC,7,"B",ORI)) Q:ORI<1 S ORPKG(ORI)=1
81 D:$G(DGPMT)'=1 CHKOBS S:'$G(ORADM) ORADM=+$G(VAIP(13,1)) S ORNOW=$$NOW^XLFDT,ORN="A",ORI=6 ;177
82 I $G(DGPMT)=1 S ORI=2,ORADM="",ORN="A"
83 I $G(DGPMT)=3,"^12^38^"[(U_$P(DGPMA,U,18)_U) S ORI=2,ORADM="",ORN=""
84 D EN^ORQ1(ORVP,ORDG,ORI,,ORADM,ORNOW),ADMORD S ORI=0
85DC1 F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S ORIFN=^(ORI) D
86 . ;Q:$P(ORIFN,";",2)>1 ; or DC/Delete actions ??
87 . Q:"^1^2^7^11^12^13^"[(U_$P(^OR(100,+ORIFN,3),U,3)_U) S OR0=$G(^(0))
88 . Q:'$G(ORPKG($P(OR0,U,14))) Q:$D(^ORD(100.6,ORDC,10,"B",+$P(OR0,U,11)))
89 . S X=+$$VALUE^ORX8(+ORIFN,"ORDERABLE") Q:$D(^ORD(100.6,ORDC,8,"B",X))
90 . Q:'$$VALID^ORCACT0(ORIFN,"DC",,ORN) ;ok to auto-dc order?
91 . I '$G(OREVENT) S OREVENT=+$$NEW^OREVNT(+ORVP) ;no delayed orders
92 . S ORDER=+ORIFN_$S(ORCREATE:";"_$$ACTION^ORCSAVE("DC",+ORIFN,$G(ORNP),,$G(ORDT)),1:"")
93 . D EN^ORCSEND(ORDER,"DC",ORSIG,1,ORNATR,$G(OREASON),.ORERR) Q:$G(ORERR)
94 . S $P(^OR(100,+ORIFN,6),U,8)=OREVENT D SAVE(ORIFN,OREVENT,3)
95 . S:ORPRNT ORPRINT=$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORDER_"^1"
96DC2 I $G(OREVENT) D
97 . S $P(^ORE(100.2,OREVENT,1),U,3)=ORDC,^ORE(100.2,"DC",ORDC,OREVENT)=""
98 . I $G(DGPMDA),$D(^XTMP("ORDC-"_DGPMDA)) D XTMP ;save order#'s
99 K ^TMP("ORR",$J,ORLIST),^XTMP("ORDC-"_$G(DGPMDA))
100 Q
101 ;
102RELEASE(OREVT) ; -- release orders for OREVT [also from ORMEVNT]
103 ; Returns ORPRINT(#)=order^prints for orders released
104 Q:'$G(OREVT) N ORPARM,ORLR,ORX,ORI,ORV,ORIFN,ORERR,OR0,OR3,ORLAB
105 S ORPARM="" I $G(ORL) F ORI="CHART COPY","LABELS","REQUISITIONS","SERVICE","WORK COPY" S ORX=$S(ORI="SERVICE":0,1:$$GET^XPAR("ALL^"_ORL,"ORPF PROMPT FOR "_ORI,1,"I")),ORPARM=ORPARM_U_$S(ORX="*":0,1:1)
106 I $D(^XTMP("ORSURG",+$G(ORSRDA))) S ORL=+$G(^DIC(42,+$G(VAIP(5)),44))_";SC(" ;186 Reset loc
107 F ORI="LR","VBEC" S ORX=+$O(^DIC(9.4,"C",ORI,0)) S:ORX ORLR(ORX)=1
108 S ORX=OREVT,ORI=0
109 F S ORI=+$O(^ORE(100.2,"DAD",OREVT,ORI)) Q:ORI<1 S ORX=ORX_U_ORI
110 F ORV=1:1:$L(ORX,U) S OREVT=$P(ORX,U,ORV) D ;event[+children]
111 . F S ORI=$O(^OR(100,"AEVNT",ORVP,OREVT,ORI)) Q:ORI'>0 D
112 .. S ORIFN=ORI,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3))
113 .. I ORIFN=+$P($G(^ORE(100.2,OREVT,0)),U,4) D Q ;event order
114 ... Q:$$TYPE^OREVNTX(OREVT)="D" Q:$P(OR3,U,3)=11
115 ... S ORPRINT=+$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
116 .. Q:$P(OR3,U,3)'=10 Q:$P(OR3,U,9) ;released or cancelled, has parent
117 .. S:$G(ORL) $P(^OR(100,ORIFN,0),U,10)=ORL ;set location
118 .. S:$G(ORTS) $P(^OR(100,ORIFN,0),U,13)=ORTS ;set specialty
119 .. I $G(ORLR(+$P(OR0,U,14))),'$G(ORLAB) D BHS^ORMBLD(ORVP) S ORLAB=1
120 .. K ORERR D EN1^ORCSEND(ORIFN,.ORERR) Q:$G(ORERR)
121 .. Q:"^10^11^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D SAVE(ORIFN,OREVT,2)
122 .. S ORPRINT=+$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
123 D BTS^ORMBLD(ORVP):$G(ORLAB) ;send batch hdr/tlr segments for labs
124 Q
125 ;
126ADMORD ; -- Add admission order to list
127 ; Uses VAIP(13),ORADM from AUTODC
128 ;Q:$G(DGPMT)'=3
129 I $G(DGPMT)=3 Q:"^12^38^"[(U_$P(DGPMA,U,18)_U) ;already included
130 N LAST,ADMEVT,IFN
131 S LAST=+$O(^ORE(100.2,"ADT",+$G(VAIP(13)),""),-1),ADMEVT=+$O(^(LAST,0))
132 S IFN=+$P($G(^ORE(100.2,ADMEVT,0)),U,4) Q:IFN<1
133 I $P($G(^OR(100,IFN,8,1,0)),U,16)<ORADM D ;add to auto-dc list
134 . N ORI S ORI=+$O(^TMP("ORR",$J,ORLIST,"A"),-1),ORI=ORI+1
135 . S ^TMP("ORR",$J,ORLIST,ORI)=IFN
136 Q
137 ;
138XTMP ; -- Save auto-dc'd by package order numbers
139 N ORDC,ORIFN,X Q:'$G(OREVENT)
140 S ORDC="ORDC-"_$G(DGPMDA),ORIFN=0
141 F S ORIFN=+$O(^XTMP(ORDC,ORIFN)) Q:ORIFN<1 S X=$G(^(ORIFN)) D
142 . D SAVE(ORIFN,OREVENT,3,X)
143 . S $P(^OR(100,+ORIFN,6),U,8)=OREVENT
144 Q
145 ;
146SAVE(IFN,EVT,NODE,PKG) ; -- Save order# IFN with EVT at NODE
147 ; NODE=2: Released orders, NODE=3: Auto-DC'd orders
148 Q:'$G(IFN)!'$G(EVT)!'$G(NODE) ;missing data
149 Q:$D(^ORE(100.2,EVT,NODE,+IFN,0)) ;already saved
150 N I,HDR,TOTAL
151 F I=1:1:10 L +^ORE(100.2,EVT,NODE,0):1 Q:$T H 2
152 Q:'$T S HDR=$G(^ORE(100.2,EVT,NODE,0))
153 I '$L(HDR) S:NODE=2 HDR="^100.26PA^^" S:NODE=3 HDR="^100.27PA^^"
154 Q:'$L(HDR) S TOTAL=+$P(HDR,U,4),$P(HDR,U,3,4)=+IFN_U_(TOTAL+1)
155 S ^ORE(100.2,EVT,NODE,0)=HDR L -^ORE(100.2,EVT,NODE,0)
156 S ^ORE(100.2,EVT,NODE,+IFN,0)=+IFN_$S($D(PKG):U_PKG,1:"")
157 Q
158 ;
159EXP ; -- expire an order from EXP^ORMEVNT(ORDER,ORSTOP)
160 ; [ORMTIME]
161 G:'$D(^OR(100,+ORDER,0)) EXPQ
162 N OR0,ORNMSP,ORSTS
163 S OR0=$G(^OR(100,+ORDER,0)),ORSTS=$P($G(^(3)),U,3)
164 I "^1^2^7^12^13^14^"[(U_ORSTS_U) G EXPQ ;done
165 I $O(^OR(100,+ORDER,2,0)) G EXPQ ;parent
166 I $P(^ORD(100.98,$P(OR0,U,11),0),U,3)="NV RX" G EXPQ ;Non-VA med
167 S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
168 D:ORNMSP="PS"!(ORNMSP="FH") MSG^ORMBLD(+ORDER,"SS")
169 I ORNMSP="OR"!(ORNMSP="FH"),"^1^7^"'[(U_ORSTS_U) D STATUS^ORCSAVE2(+ORDER,7) ;ck FH
170EXPQ K ^OR(100,"AE",ORSTOP,ORDER)
171 Q
172 ;
173ACT ; -- activate an order from ACTIVE^ORMEVNT(ORDER,ORSTRT)
174 ; [ORMTIME]
175 G:'$D(^OR(100,+ORDER,0)) ACTQ
176 N OR0,ORNMSP,ORSTS
177 S OR0=$G(^OR(100,+ORDER,0)),ORSTS=$P($G(^(3)),U,3)
178 I "^1^2^6^7^12^13^14^"[(U_ORSTS_U) G ACTQ ;done
179 I $O(^OR(100,+ORDER,2,0)) G ACTQ ;parent
180 S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
181 D:ORNMSP="PS"!(ORNMSP="FH") MSG^ORMBLD(+ORDER,"SS")
182 I ORNMSP="OR"!(ORNMSP="FH"),ORSTS=8 D STATUS^ORCSAVE2(+ORDER,6) ;ck FH
183ACTQ K ^OR(100,"AD",ORSTRT,ORDER)
184 Q
185 ;
186PUR ; -- purge an order
187 ; from PURGE^ORMEVNT(ORDER)
188 N ORSTS,ORPK,ORNMSP,ORCHLD Q:'$D(^OR(100,ORDER))
189 S ORSTS=$P($G(^OR(100,ORDER,3)),U,3),ORPK=$G(^(4)),ORNMSP=$P($G(^(0)),U,14),ORNMSP=$$NMSP^ORCD(ORNMSP)
190 I '$L(ORPK)!(ORSTS=11)!(ORNMSP="OR")!(ORNMSP="LR"&('ORPK)) D DELETE^ORCSAVE2(ORDER) Q
191 I '$D(^OR(100,ORDER,2)) D MSG^ORMBLD(ORDER,"Z@") Q
192 S ORCHLD=0 F S ORCHLD=$O(^OR(100,ORDER,2,ORCHLD)) Q:ORCHLD'>0 D MSG^ORMBLD(ORCHLD,"Z@")
193 I '$O(^OR(100,ORDER,2,0)) D DELETE^ORCSAVE2(ORDER) ; delete parent
194 Q
195 ;
196CHKOBS ;177, previous dx from obs?
197 N INVDT,PDCDT,PDCMVT,CADMDT
198 S CADMDT=+$G(VAIP(13,1)) Q:'CADMDT ;Current admission d/t of movement
199 S INVDT=9999999.9999999-(+VAIP(3)) ;Inverse date of movement
200 S PDCDT=$O(^DGPM("ATID3",DFN,INVDT)) Q:'+PDCDT ;No previous discharge
201 S PDCMVT=$O(^DGPM("ATID3",DFN,PDCDT,0))
202 Q:+$$MVT^DGPMOBS(PDCMVT)'=1 ;Quit if previous discharge not from obs
203 N VAIP
204 S VAIP("E")=PDCMVT
205 D IN5^VADPT
206 Q:'$G(VAIP(13)) ;No previous admission data
207 Q:$$FMDIFF^XLFDT(CADMDT,+$G(VAIP(3)),2)>3600 ;Quit if previous discharge was more than 1 hour before admission
208 S ORADM=+$G(VAIP(13,1))
209 Q
Note: See TracBrowser for help on using the repository browser.