ORMEVNT1 ;SLC/MKB-Trigger HL7 msg off OR events,ORMTIME ;9/9/03 13:00
;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,177,186,215**;Dec 17, 1997
;
;DBIA Section
; 3559 - Direct read of ^SRF
;10039 - Direct read of ^DIC(42,
;
OR2(ORSRDA) ;Queue EDO process to background, return control to surgery
;
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
S ZTRTN="OR2Q^ORMEVNT1",ZTDTH=$H,ZTDESC="Surgery triggered EDO processing",ZTIO="",ZTSAVE("ORSRDA")="" D ^%ZTLOAD
Q
;
OR2Q ; -- Kill logic, from Surgery package [DBIA #3558]
I $D(^XTMP("ORSURG",ORSRDA)) D OR2(ORSRDA) Q ;186 requeue if flag set
N X,Y,DA,OREVT,ORSRF,ORACT
S OREVT=+$O(^ORE(100.2,"ASR",+$G(ORSRDA),0)) Q:OREVT<1
S ORSRF=$G(^SRF(+ORSRDA,.2)),ORACT=$S($L($P(ORSRF,U,12)):"ED",1:"DL")
D ACTLOG^OREVNTX(OREVT,ORACT)
Q
;
OR1(ORSRDA,ORSRX) ;Queue EDO process to background, return control to surgery
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
S ZTRTN="OR1Q^ORMEVNT1",ZTDTH=$H,ZTDESC="Surgery triggered EDO processing",ZTIO="",ZTSAVE("ORSRDA")="",ZTSAVE("ORSRX")="" D ^%ZTLOAD
Q
;
OR1Q ; -- Set logic, from Surgery package [DBIA #3558]
I $D(^XTMP("ORSURG",ORSRDA)) D OR1(ORSRDA,ORSRX) Q ;186 requeue if flag set
N X S X=ORSRX
I $G(^SRF(+$G(ORSRDA),"CON")),$D(^ORE(100.2,"ASR",+^("CON"))) Q ;concurrent
Q:$D(^ORE(100.2,"ASR",+$G(ORSRDA))) Q:'$$CURRENT ;edit
;
N ORSR0,DFN,VAIP,VAERR,X,Y,DA,ORVP,ORL,ORDIV,ORTS,OREVENT,ORDCRULE,ORPRINT
S ORSR0=$G(^SRF(+$G(ORSRDA),0)),DFN=+$P(ORSR0,U)
D IN5^VADPT Q:'$G(VAIP(13)) ;not admitted
S ^XTMP("ORSURG",ORSRDA)=$$FMADD^XLFDT(DT,5)_U_DT ;186 Set flag
S ORL=$P($G(^SRS(+$P(ORSR0,U,2),0)),U)_";SC(",ORDIV=$$DIV(+ORL) ;DBIA #3362
I '$G(LOC) S ORL=+$G(^DIC(42,+$G(VAIP(5)),44))_";SC(" ;186 If no O.R. loc then use current loc
S ORTS=+$G(VAIP(8)) ; need surg spec too? DBIA #991
S ORVP=DFN_";DPT(",OREVENT=$$PATEVT,ORDCRULE=$$DCEVT
D:ORDCRULE AUTODC(ORDCRULE,ORSRX) I OREVENT D
. D RELEASE(OREVENT),DONE^OREVNTX(OREVENT,ORSRX,,ORSRDA)
. D ACTLOG^OREVNTX(OREVENT,"NW","O")
I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL)
K ^XTMP("ORSURG",ORSRDA) ;186
Q
;
DIV(LOC) ; -- Return Institution file #4 ptr for LOC
N X0,Y S X0=$G(^SC(+LOC,0))
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)))
Q Y
;
CURRENT() ; -- Is posted mvt the latest one?
N Y S Y=$S((DT-X)<1:1,1:0)
Q Y
;
PATEVT() ; -- Find match to new data in Patient Event file
N EVT,IFN,X0,Y S EVT=0,Y=""
F S EVT=+$O(^ORE(100.2,"AE",+ORVP,EVT)) Q:EVT<1 S IFN=$O(^(EVT,0)) D Q:Y
. Q:$$LAPSED^OREVNTX(+IFN) ;don't release orders
. S X0=$G(^ORD(100.5,EVT,0))
. I $P(X0,U,2)="O",$P(X0,U,3)=ORDIV S Y=+IFN Q
Q Y
;
DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV
N Y I '$G(^DPT(+ORVP,.105)) Q 0 ;no auto-dc's if not admitted
S Y=+$O(^ORD(100.6,"AE",ORDIV,"O",0))
Q Y
;
AUTODC(ORDC,ORDT) ; -- DC orders based on rule ORDC [also from ORMEVNT]
; Expects VAIP array with current admission data
N ORADM,ORNOW,ORN,X,OREASON,ORNATR,ORCREATE,ORPRNT,ORSIG,ORDG,ORI,ORPKG,ORLIST,ORIFN,OR0,ORDER,ORERR
S OREASON=+$P($G(^ORD(100.6,ORDC,0)),U,4) I OREASON<1 D
. S OREASON=$S('$G(DGPMT):"OROR",DGPMT=1:"ORADMIT",DGPMT=2:"ORTRANS",DGPMT=3:"ORDIS",1:"ORSPEC")
. S OREASON=+$O(^ORD(100.03,"C",OREASON,0))
S ORNATR=+$P($G(^ORD(100.03,+$G(OREASON),0)),U,7)
S:ORNATR'>0 ORNATR=+$O(^ORD(100.02,"C","A",0))
S X=$G(^ORD(100.02,ORNATR,1)),ORCREATE=+$P(X,U),ORPRNT=+$P(X,U,2)
S ORSIG=$S('ORCREATE:"",1:$P(X,U,4)),ORDG=$O(^ORD(100.98,"B","ALL",0))
S ORI=0 F S ORI=$O(^ORD(100.6,ORDC,7,"B",ORI)) Q:ORI<1 S ORPKG(ORI)=1
D:$G(DGPMT)'=1 CHKOBS S:'$G(ORADM) ORADM=+$G(VAIP(13,1)) S ORNOW=$$NOW^XLFDT,ORN="A",ORI=6 ;177
I $G(DGPMT)=1 S ORI=2,ORADM="",ORN="A"
I $G(DGPMT)=3,"^12^38^"[(U_$P(DGPMA,U,18)_U) S ORI=2,ORADM="",ORN=""
D EN^ORQ1(ORVP,ORDG,ORI,,ORADM,ORNOW),ADMORD S ORI=0
DC1 F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S ORIFN=^(ORI) D
. ;Q:$P(ORIFN,";",2)>1 ; or DC/Delete actions ??
. Q:"^1^2^7^11^12^13^"[(U_$P(^OR(100,+ORIFN,3),U,3)_U) S OR0=$G(^(0))
. Q:'$G(ORPKG($P(OR0,U,14))) Q:$D(^ORD(100.6,ORDC,10,"B",+$P(OR0,U,11)))
. S X=+$$VALUE^ORX8(+ORIFN,"ORDERABLE") Q:$D(^ORD(100.6,ORDC,8,"B",X))
. Q:'$$VALID^ORCACT0(ORIFN,"DC",,ORN) ;ok to auto-dc order?
. I '$G(OREVENT) S OREVENT=+$$NEW^OREVNT(+ORVP) ;no delayed orders
. S ORDER=+ORIFN_$S(ORCREATE:";"_$$ACTION^ORCSAVE("DC",+ORIFN,$G(ORNP),,$G(ORDT)),1:"")
. D EN^ORCSEND(ORDER,"DC",ORSIG,1,ORNATR,$G(OREASON),.ORERR) Q:$G(ORERR)
. S $P(^OR(100,+ORIFN,6),U,8)=OREVENT D SAVE(ORIFN,OREVENT,3)
. S:ORPRNT ORPRINT=$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORDER_"^1"
DC2 I $G(OREVENT) D
. S $P(^ORE(100.2,OREVENT,1),U,3)=ORDC,^ORE(100.2,"DC",ORDC,OREVENT)=""
. I $G(DGPMDA),$D(^XTMP("ORDC-"_DGPMDA)) D XTMP ;save order#'s
K ^TMP("ORR",$J,ORLIST),^XTMP("ORDC-"_$G(DGPMDA))
Q
;
RELEASE(OREVT) ; -- release orders for OREVT [also from ORMEVNT]
; Returns ORPRINT(#)=order^prints for orders released
Q:'$G(OREVT) N ORPARM,ORLR,ORX,ORI,ORV,ORIFN,ORERR,OR0,OR3,ORLAB
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)
I $D(^XTMP("ORSURG",+$G(ORSRDA))) S ORL=+$G(^DIC(42,+$G(VAIP(5)),44))_";SC(" ;186 Reset loc
F ORI="LR","VBEC" S ORX=+$O(^DIC(9.4,"C",ORI,0)) S:ORX ORLR(ORX)=1
S ORX=OREVT,ORI=0
F S ORI=+$O(^ORE(100.2,"DAD",OREVT,ORI)) Q:ORI<1 S ORX=ORX_U_ORI
F ORV=1:1:$L(ORX,U) S OREVT=$P(ORX,U,ORV) D ;event[+children]
. F S ORI=$O(^OR(100,"AEVNT",ORVP,OREVT,ORI)) Q:ORI'>0 D
.. S ORIFN=ORI,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3))
.. I ORIFN=+$P($G(^ORE(100.2,OREVT,0)),U,4) D Q ;event order
... Q:$$TYPE^OREVNTX(OREVT)="D" Q:$P(OR3,U,3)=11
... S ORPRINT=+$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
.. Q:$P(OR3,U,3)'=10 Q:$P(OR3,U,9) ;released or cancelled, has parent
.. S:$G(ORL) $P(^OR(100,ORIFN,0),U,10)=ORL ;set location
.. S:$G(ORTS) $P(^OR(100,ORIFN,0),U,13)=ORTS ;set specialty
.. I $G(ORLR(+$P(OR0,U,14))),'$G(ORLAB) D BHS^ORMBLD(ORVP) S ORLAB=1
.. K ORERR D EN1^ORCSEND(ORIFN,.ORERR) Q:$G(ORERR)
.. Q:"^10^11^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D SAVE(ORIFN,OREVT,2)
.. S ORPRINT=+$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
D BTS^ORMBLD(ORVP):$G(ORLAB) ;send batch hdr/tlr segments for labs
Q
;
ADMORD ; -- Add admission order to list
; Uses VAIP(13),ORADM from AUTODC
;Q:$G(DGPMT)'=3
I $G(DGPMT)=3 Q:"^12^38^"[(U_$P(DGPMA,U,18)_U) ;already included
N LAST,ADMEVT,IFN
S LAST=+$O(^ORE(100.2,"ADT",+$G(VAIP(13)),""),-1),ADMEVT=+$O(^(LAST,0))
S IFN=+$P($G(^ORE(100.2,ADMEVT,0)),U,4) Q:IFN<1
I $P($G(^OR(100,IFN,8,1,0)),U,16)<ORADM D ;add to auto-dc list
. N ORI S ORI=+$O(^TMP("ORR",$J,ORLIST,"A"),-1),ORI=ORI+1
. S ^TMP("ORR",$J,ORLIST,ORI)=IFN
Q
;
XTMP ; -- Save auto-dc'd by package order numbers
N ORDC,ORIFN,X Q:'$G(OREVENT)
S ORDC="ORDC-"_$G(DGPMDA),ORIFN=0
F S ORIFN=+$O(^XTMP(ORDC,ORIFN)) Q:ORIFN<1 S X=$G(^(ORIFN)) D
. D SAVE(ORIFN,OREVENT,3,X)
. S $P(^OR(100,+ORIFN,6),U,8)=OREVENT
Q
;
SAVE(IFN,EVT,NODE,PKG) ; -- Save order# IFN with EVT at NODE
; NODE=2: Released orders, NODE=3: Auto-DC'd orders
Q:'$G(IFN)!'$G(EVT)!'$G(NODE) ;missing data
Q:$D(^ORE(100.2,EVT,NODE,+IFN,0)) ;already saved
N I,HDR,TOTAL
F I=1:1:10 L +^ORE(100.2,EVT,NODE,0):1 Q:$T H 2
Q:'$T S HDR=$G(^ORE(100.2,EVT,NODE,0))
I '$L(HDR) S:NODE=2 HDR="^100.26PA^^" S:NODE=3 HDR="^100.27PA^^"
Q:'$L(HDR) S TOTAL=+$P(HDR,U,4),$P(HDR,U,3,4)=+IFN_U_(TOTAL+1)
S ^ORE(100.2,EVT,NODE,0)=HDR L -^ORE(100.2,EVT,NODE,0)
S ^ORE(100.2,EVT,NODE,+IFN,0)=+IFN_$S($D(PKG):U_PKG,1:"")
Q
;
EXP ; -- expire an order from EXP^ORMEVNT(ORDER,ORSTOP)
; [ORMTIME]
G:'$D(^OR(100,+ORDER,0)) EXPQ
N OR0,ORNMSP,ORSTS
S OR0=$G(^OR(100,+ORDER,0)),ORSTS=$P($G(^(3)),U,3)
I "^1^2^7^12^13^14^"[(U_ORSTS_U) G EXPQ ;done
I $O(^OR(100,+ORDER,2,0)) G EXPQ ;parent
I $P(^ORD(100.98,$P(OR0,U,11),0),U,3)="NV RX" G EXPQ ;Non-VA med
S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
D:ORNMSP="PS"!(ORNMSP="FH") MSG^ORMBLD(+ORDER,"SS")
I ORNMSP="OR"!(ORNMSP="FH"),"^1^7^"'[(U_ORSTS_U) D STATUS^ORCSAVE2(+ORDER,7) ;ck FH
EXPQ K ^OR(100,"AE",ORSTOP,ORDER)
Q
;
ACT ; -- activate an order from ACTIVE^ORMEVNT(ORDER,ORSTRT)
; [ORMTIME]
G:'$D(^OR(100,+ORDER,0)) ACTQ
N OR0,ORNMSP,ORSTS
S OR0=$G(^OR(100,+ORDER,0)),ORSTS=$P($G(^(3)),U,3)
I "^1^2^6^7^12^13^14^"[(U_ORSTS_U) G ACTQ ;done
I $O(^OR(100,+ORDER,2,0)) G ACTQ ;parent
S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
D:ORNMSP="PS"!(ORNMSP="FH") MSG^ORMBLD(+ORDER,"SS")
I ORNMSP="OR"!(ORNMSP="FH"),ORSTS=8 D STATUS^ORCSAVE2(+ORDER,6) ;ck FH
ACTQ K ^OR(100,"AD",ORSTRT,ORDER)
Q
;
PUR ; -- purge an order
; from PURGE^ORMEVNT(ORDER)
N ORSTS,ORPK,ORNMSP,ORCHLD Q:'$D(^OR(100,ORDER))
S ORSTS=$P($G(^OR(100,ORDER,3)),U,3),ORPK=$G(^(4)),ORNMSP=$P($G(^(0)),U,14),ORNMSP=$$NMSP^ORCD(ORNMSP)
I '$L(ORPK)!(ORSTS=11)!(ORNMSP="OR")!(ORNMSP="LR"&('ORPK)) D DELETE^ORCSAVE2(ORDER) Q
I '$D(^OR(100,ORDER,2)) D MSG^ORMBLD(ORDER,"Z@") Q
S ORCHLD=0 F S ORCHLD=$O(^OR(100,ORDER,2,ORCHLD)) Q:ORCHLD'>0 D MSG^ORMBLD(ORCHLD,"Z@")
I '$O(^OR(100,ORDER,2,0)) D DELETE^ORCSAVE2(ORDER) ; delete parent
Q
;
CHKOBS ;177, previous dx from obs?
N INVDT,PDCDT,PDCMVT,CADMDT
S CADMDT=+$G(VAIP(13,1)) Q:'CADMDT ;Current admission d/t of movement
S INVDT=9999999.9999999-(+VAIP(3)) ;Inverse date of movement
S PDCDT=$O(^DGPM("ATID3",DFN,INVDT)) Q:'+PDCDT ;No previous discharge
S PDCMVT=$O(^DGPM("ATID3",DFN,PDCDT,0))
Q:+$$MVT^DGPMOBS(PDCMVT)'=1 ;Quit if previous discharge not from obs
N VAIP
S VAIP("E")=PDCMVT
D IN5^VADPT
Q:'$G(VAIP(13)) ;No previous admission data
Q:$$FMDIFF^XLFDT(CADMDT,+$G(VAIP(3)),2)>3600 ;Quit if previous discharge was more than 1 hour before admission
S ORADM=+$G(VAIP(13,1))
Q
ORMEVNT1 ;SLC/MKB-Trigger HL7 msg off OR events,ORMTIME ;9/9/03 13:00
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,177,186,215**;Dec 17, 1997
+2 ;
+3 ;DBIA Section
+4 ; 3559 - Direct read of ^SRF
+5 ;10039 - Direct read of ^DIC(42,
+6 ;
OR2(ORSRDA) ;Queue EDO process to background, return control to surgery
+1 ;
+2 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
+3 SET ZTRTN="OR2Q^ORMEVNT1"
SET ZTDTH=$HOROLOG
SET ZTDESC="Surgery triggered EDO processing"
SET ZTIO=""
SET ZTSAVE("ORSRDA")=""
DO ^%ZTLOAD
+4 QUIT
+5 ;
OR2Q ; -- Kill logic, from Surgery package [DBIA #3558]
+1 ;186 requeue if flag set
IF $DATA(^XTMP("ORSURG",ORSRDA))
DO OR2(ORSRDA)
QUIT
+2 NEW X,Y,DA,OREVT,ORSRF,ORACT
+3 SET OREVT=+$ORDER(^ORE(100.2,"ASR",+$GET(ORSRDA),0))
IF OREVT<1
QUIT
+4 SET ORSRF=$GET(^SRF(+ORSRDA,.2))
SET ORACT=$SELECT($LENGTH($PIECE(ORSRF,U,12)):"ED",1:"DL")
+5 DO ACTLOG^OREVNTX(OREVT,ORACT)
+6 QUIT
+7 ;
OR1(ORSRDA,ORSRX) ;Queue EDO process to background, return control to surgery
+1 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
+2 SET ZTRTN="OR1Q^ORMEVNT1"
SET ZTDTH=$HOROLOG
SET ZTDESC="Surgery triggered EDO processing"
SET ZTIO=""
SET ZTSAVE("ORSRDA")=""
SET ZTSAVE("ORSRX")=""
DO ^%ZTLOAD
+3 QUIT
+4 ;
OR1Q ; -- Set logic, from Surgery package [DBIA #3558]
+1 ;186 requeue if flag set
IF $DATA(^XTMP("ORSURG",ORSRDA))
DO OR1(ORSRDA,ORSRX)
QUIT
+2 NEW X
SET X=ORSRX
+3 ;concurrent
IF $GET(^SRF(+$GET(ORSRDA),"CON"))
IF $DATA(^ORE(100.2,"ASR",+^("CON")))
QUIT
+4 ;edit
IF $DATA(^ORE(100.2,"ASR",+$GET(ORSRDA)))
QUIT
IF '$$CURRENT
QUIT
+5 ;
+6 NEW ORSR0,DFN,VAIP,VAERR,X,Y,DA,ORVP,ORL,ORDIV,ORTS,OREVENT,ORDCRULE,ORPRINT
+7 SET ORSR0=$GET(^SRF(+$GET(ORSRDA),0))
SET DFN=+$PIECE(ORSR0,U)
+8 ;not admitted
DO IN5^VADPT
IF '$GET(VAIP(13))
QUIT
+9 ;186 Set flag
SET ^XTMP("ORSURG",ORSRDA)=$$FMADD^XLFDT(DT,5)_U_DT
+10 ;DBIA #3362
SET ORL=$PIECE($GET(^SRS(+$PIECE(ORSR0,U,2),0)),U)_";SC("
SET ORDIV=$$DIV(+ORL)
+11 ;186 If no O.R. loc then use current loc
IF '$GET(LOC)
SET ORL=+$GET(^DIC(42,+$GET(VAIP(5)),44))_";SC("
+12 ; need surg spec too? DBIA #991
SET ORTS=+$GET(VAIP(8))
+13 SET ORVP=DFN_";DPT("
SET OREVENT=$$PATEVT
SET ORDCRULE=$$DCEVT
+14 IF ORDCRULE
DO AUTODC(ORDCRULE,ORSRX)
IF OREVENT
Begin DoDot:1
+15 DO RELEASE(OREVENT)
DO DONE^OREVNTX(OREVENT,ORSRX,,ORSRDA)
+16 DO ACTLOG^OREVNTX(OREVENT,"NW","O")
End DoDot:1
+17 IF $ORDER(ORPRINT(0))
IF $GET(ORL)
DO PRINTS^ORWD1(.ORPRINT,+ORL)
+18 ;186
KILL ^XTMP("ORSURG",ORSRDA)
+19 QUIT
+20 ;
DIV(LOC) ; -- Return Institution file #4 ptr for LOC
+1 NEW X0,Y
SET X0=$GET(^SC(+LOC,0))
+2 SET Y=$SELECT($PIECE(X0,U,4):$PIECE(X0,U,4),$PIECE(X0,U,15):$$SITE^VASITE(DT,$PIECE(X0,U,15)),1:+$GET(DUZ(2)))
+3 QUIT Y
+4 ;
CURRENT() ; -- Is posted mvt the latest one?
+1 NEW Y
SET Y=$SELECT((DT-X)<1:1,1:0)
+2 QUIT Y
+3 ;
PATEVT() ; -- Find match to new data in Patient Event file
+1 NEW EVT,IFN,X0,Y
SET EVT=0
SET Y=""
+2 FOR
SET EVT=+$ORDER(^ORE(100.2,"AE",+ORVP,EVT))
IF EVT<1
QUIT
SET IFN=$ORDER(^(EVT,0))
Begin DoDot:1
+3 ;don't release orders
IF $$LAPSED^OREVNTX(+IFN)
QUIT
+4 SET X0=$GET(^ORD(100.5,EVT,0))
+5 IF $PIECE(X0,U,2)="O"
IF $PIECE(X0,U,3)=ORDIV
SET Y=+IFN
QUIT
End DoDot:1
IF Y
QUIT
+6 QUIT Y
+7 ;
DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV
+1 ;no auto-dc's if not admitted
NEW Y
IF '$GET(^DPT(+ORVP,.105))
QUIT 0
+2 SET Y=+$ORDER(^ORD(100.6,"AE",ORDIV,"O",0))
+3 QUIT Y
+4 ;
AUTODC(ORDC,ORDT) ; -- DC orders based on rule ORDC [also from ORMEVNT]
+1 ; Expects VAIP array with current admission data
+2 NEW ORADM,ORNOW,ORN,X,OREASON,ORNATR,ORCREATE,ORPRNT,ORSIG,ORDG,ORI,ORPKG,ORLIST,ORIFN,OR0,ORDER,ORERR
+3 SET OREASON=+$PIECE($GET(^ORD(100.6,ORDC,0)),U,4)
IF OREASON<1
Begin DoDot:1
+4 SET OREASON=$SELECT('$GET(DGPMT):"OROR",DGPMT=1:"ORADMIT",DGPMT=2:"ORTRANS",DGPMT=3:"ORDIS",1:"ORSPEC")
+5 SET OREASON=+$ORDER(^ORD(100.03,"C",OREASON,0))
End DoDot:1
+6 SET ORNATR=+$PIECE($GET(^ORD(100.03,+$GET(OREASON),0)),U,7)
+7 IF ORNATR'>0
SET ORNATR=+$ORDER(^ORD(100.02,"C","A",0))
+8 SET X=$GET(^ORD(100.02,ORNATR,1))
SET ORCREATE=+$PIECE(X,U)
SET ORPRNT=+$PIECE(X,U,2)
+9 SET ORSIG=$SELECT('ORCREATE:"",1:$PIECE(X,U,4))
SET ORDG=$ORDER(^ORD(100.98,"B","ALL",0))
+10 SET ORI=0
FOR
SET ORI=$ORDER(^ORD(100.6,ORDC,7,"B",ORI))
IF ORI<1
QUIT
SET ORPKG(ORI)=1
+11 ;177
IF $GET(DGPMT)'=1
DO CHKOBS
IF '$GET(ORADM)
SET ORADM=+$GET(VAIP(13,1))
SET ORNOW=$$NOW^XLFDT
SET ORN="A"
SET ORI=6
+12 IF $GET(DGPMT)=1
SET ORI=2
SET ORADM=""
SET ORN="A"
+13 IF $GET(DGPMT)=3
IF "^12^38^"[(U_$PIECE(DGPMA,U,18)_U)
SET ORI=2
SET ORADM=""
SET ORN=""
+14 DO EN^ORQ1(ORVP,ORDG,ORI,,ORADM,ORNOW)
DO ADMORD
SET ORI=0
DC1 FOR
SET ORI=$ORDER(^TMP("ORR",$JOB,ORLIST,ORI))
IF ORI'>0
QUIT
SET ORIFN=^(ORI)
Begin DoDot:1
+1 ;Q:$P(ORIFN,";",2)>1 ; or DC/Delete actions ??
+2 IF "^1^2^7^11^12^13^"[(U_$PIECE(^OR(100,+ORIFN,3),U,3)_U)
QUIT
SET OR0=$GET(^(0))
+3 IF '$GET(ORPKG($PIECE(OR0,U,14)))
QUIT
IF $DATA(^ORD(100.6,ORDC,10,"B",+$PIECE(OR0,U,11)))
QUIT
+4 SET X=+$$VALUE^ORX8(+ORIFN,"ORDERABLE")
IF $DATA(^ORD(100.6,ORDC,8,"B",X))
QUIT
+5 ;ok to auto-dc order?
IF '$$VALID^ORCACT0(ORIFN,"DC",,ORN)
QUIT
+6 ;no delayed orders
IF '$GET(OREVENT)
SET OREVENT=+$$NEW^OREVNT(+ORVP)
+7 SET ORDER=+ORIFN_$SELECT(ORCREATE:";"_$$ACTION^ORCSAVE("DC",+ORIFN,$GET(ORNP),,$GET(ORDT)),1:"")
+8 DO EN^ORCSEND(ORDER,"DC",ORSIG,1,ORNATR,$GET(OREASON),.ORERR)
IF $GET(ORERR)
QUIT
+9 SET $PIECE(^OR(100,+ORIFN,6),U,8)=OREVENT
DO SAVE(ORIFN,OREVENT,3)
+10 IF ORPRNT
SET ORPRINT=$GET(ORPRINT)+1
SET ORPRINT(ORPRINT)=ORDER_"^1"
End DoDot:1
DC2 IF $GET(OREVENT)
Begin DoDot:1
+1 SET $PIECE(^ORE(100.2,OREVENT,1),U,3)=ORDC
SET ^ORE(100.2,"DC",ORDC,OREVENT)=""
+2 ;save order#'s
IF $GET(DGPMDA)
IF $DATA(^XTMP("ORDC-"_DGPMDA))
DO XTMP
End DoDot:1
+3 KILL ^TMP("ORR",$JOB,ORLIST),^XTMP("ORDC-"_$GET(DGPMDA))
+4 QUIT
+5 ;
RELEASE(OREVT) ; -- release orders for OREVT [also from ORMEVNT]
+1 ; Returns ORPRINT(#)=order^prints for orders released
+2 IF '$GET(OREVT)
QUIT
NEW ORPARM,ORLR,ORX,ORI,ORV,ORIFN,ORERR,OR0,OR3,ORLAB
+3 SET ORPARM=""
IF $GET(ORL)
FOR ORI="CHART COPY","LABELS","REQUISITIONS","SERVICE","WORK COPY"
SET ORX=$SELECT(ORI="SERVICE":0,1:$$GET^XPAR("ALL^"_ORL,"ORPF PROMPT FOR "_ORI,1,"I"))
SET ORPARM=ORPARM_U_$SELECT(ORX="*":0,1:1)
+4 ;186 Reset loc
IF $DATA(^XTMP("ORSURG",+$GET(ORSRDA)))
SET ORL=+$GET(^DIC(42,+$GET(VAIP(5)),44))_";SC("
+5 FOR ORI="LR","VBEC"
SET ORX=+$ORDER(^DIC(9.4,"C",ORI,0))
IF ORX
SET ORLR(ORX)=1
+6 SET ORX=OREVT
SET ORI=0
+7 FOR
SET ORI=+$ORDER(^ORE(100.2,"DAD",OREVT,ORI))
IF ORI<1
QUIT
SET ORX=ORX_U_ORI
+8 ;event[+children]
FOR ORV=1:1:$LENGTH(ORX,U)
SET OREVT=$PIECE(ORX,U,ORV)
Begin DoDot:1
+9 FOR
SET ORI=$ORDER(^OR(100,"AEVNT",ORVP,OREVT,ORI))
IF ORI'>0
QUIT
Begin DoDot:2
+10 SET ORIFN=ORI
SET OR0=$GET(^OR(100,ORIFN,0))
SET OR3=$GET(^(3))
+11 ;event order
IF ORIFN=+$PIECE($GET(^ORE(100.2,OREVT,0)),U,4)
Begin DoDot:3
+12 IF $$TYPE^OREVNTX(OREVT)="D"
QUIT
IF $PIECE(OR3,U,3)=11
QUIT
+13 SET ORPRINT=+$GET(ORPRINT)+1
SET ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
End DoDot:3
QUIT
+14 ;released or cancelled, has parent
IF $PIECE(OR3,U,3)'=10
QUIT
IF $PIECE(OR3,U,9)
QUIT
+15 ;set location
IF $GET(ORL)
SET $PIECE(^OR(100,ORIFN,0),U,10)=ORL
+16 ;set specialty
IF $GET(ORTS)
SET $PIECE(^OR(100,ORIFN,0),U,13)=ORTS
+17 IF $GET(ORLR(+$PIECE(OR0,U,14)))
IF '$GET(ORLAB)
DO BHS^ORMBLD(ORVP)
SET ORLAB=1
+18 KILL ORERR
DO EN1^ORCSEND(ORIFN,.ORERR)
IF $GET(ORERR)
QUIT
+19 IF "^10^11^"[(U_$PIECE($GET(^OR(100,ORIFN,3)),U,3)_U)
QUIT
DO SAVE(ORIFN,OREVT,2)
+20 SET ORPRINT=+$GET(ORPRINT)+1
SET ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
End DoDot:2
End DoDot:1
+21 ;send batch hdr/tlr segments for labs
IF $GET(ORLAB)
DO BTS^ORMBLD(ORVP)
+22 QUIT
+23 ;
ADMORD ; -- Add admission order to list
+1 ; Uses VAIP(13),ORADM from AUTODC
+2 ;Q:$G(DGPMT)'=3
+3 ;already included
IF $GET(DGPMT)=3
IF "^12^38^"[(U_$PIECE(DGPMA,U,18)_U)
QUIT
+4 NEW LAST,ADMEVT,IFN
+5 SET LAST=+$ORDER(^ORE(100.2,"ADT",+$GET(VAIP(13)),""),-1)
SET ADMEVT=+$ORDER(^(LAST,0))
+6 SET IFN=+$PIECE($GET(^ORE(100.2,ADMEVT,0)),U,4)
IF IFN<1
QUIT
+7 ;add to auto-dc list
IF $PIECE($GET(^OR(100,IFN,8,1,0)),U,16)<ORADM
Begin DoDot:1
+8 NEW ORI
SET ORI=+$ORDER(^TMP("ORR",$JOB,ORLIST,"A"),-1)
SET ORI=ORI+1
+9 SET ^TMP("ORR",$JOB,ORLIST,ORI)=IFN
End DoDot:1
+10 QUIT
+11 ;
XTMP ; -- Save auto-dc'd by package order numbers
+1 NEW ORDC,ORIFN,X
IF '$GET(OREVENT)
QUIT
+2 SET ORDC="ORDC-"_$GET(DGPMDA)
SET ORIFN=0
+3 FOR
SET ORIFN=+$ORDER(^XTMP(ORDC,ORIFN))
IF ORIFN<1
QUIT
SET X=$GET(^(ORIFN))
Begin DoDot:1
+4 DO SAVE(ORIFN,OREVENT,3,X)
+5 SET $PIECE(^OR(100,+ORIFN,6),U,8)=OREVENT
End DoDot:1
+6 QUIT
+7 ;
SAVE(IFN,EVT,NODE,PKG) ; -- Save order# IFN with EVT at NODE
+1 ; NODE=2: Released orders, NODE=3: Auto-DC'd orders
+2 ;missing data
IF '$GET(IFN)!'$GET(EVT)!'$GET(NODE)
QUIT
+3 ;already saved
IF $DATA(^ORE(100.2,EVT,NODE,+IFN,0))
QUIT
+4 NEW I,HDR,TOTAL
+5 FOR I=1:1:10
LOCK +^ORE(100.2,EVT,NODE,0):1
IF $TEST
QUIT
HANG 2
+6 IF '$TEST
QUIT
SET HDR=$GET(^ORE(100.2,EVT,NODE,0))
+7 IF '$LENGTH(HDR)
IF NODE=2
SET HDR="^100.26PA^^"
IF NODE=3
SET HDR="^100.27PA^^"
+8 IF '$LENGTH(HDR)
QUIT
SET TOTAL=+$PIECE(HDR,U,4)
SET $PIECE(HDR,U,3,4)=+IFN_U_(TOTAL+1)
+9 SET ^ORE(100.2,EVT,NODE,0)=HDR
LOCK -^ORE(100.2,EVT,NODE,0)
+10 SET ^ORE(100.2,EVT,NODE,+IFN,0)=+IFN_$SELECT($DATA(PKG):U_PKG,1:"")
+11 QUIT
+12 ;
EXP ; -- expire an order from EXP^ORMEVNT(ORDER,ORSTOP)
+1 ; [ORMTIME]
+2 IF '$DATA(^OR(100,+ORDER,0))
GOTO EXPQ
+3 NEW OR0,ORNMSP,ORSTS
+4 SET OR0=$GET(^OR(100,+ORDER,0))
SET ORSTS=$PIECE($GET(^(3)),U,3)
+5 ;done
IF "^1^2^7^12^13^14^"[(U_ORSTS_U)
GOTO EXPQ
+6 ;parent
IF $ORDER(^OR(100,+ORDER,2,0))
GOTO EXPQ
+7 ;Non-VA med
IF $PIECE(^ORD(100.98,$PIECE(OR0,U,11),0),U,3)="NV RX"
GOTO EXPQ
+8 SET ORNMSP=$$NMSP^ORCD($PIECE(OR0,U,14))
+9 IF ORNMSP="PS"!(ORNMSP="FH")
DO MSG^ORMBLD(+ORDER,"SS")
+10 ;ck FH
IF ORNMSP="OR"!(ORNMSP="FH")
IF "^1^7^"'[(U_ORSTS_U)
DO STATUS^ORCSAVE2(+ORDER,7)
EXPQ KILL ^OR(100,"AE",ORSTOP,ORDER)
+1 QUIT
+2 ;
ACT ; -- activate an order from ACTIVE^ORMEVNT(ORDER,ORSTRT)
+1 ; [ORMTIME]
+2 IF '$DATA(^OR(100,+ORDER,0))
GOTO ACTQ
+3 NEW OR0,ORNMSP,ORSTS
+4 SET OR0=$GET(^OR(100,+ORDER,0))
SET ORSTS=$PIECE($GET(^(3)),U,3)
+5 ;done
IF "^1^2^6^7^12^13^14^"[(U_ORSTS_U)
GOTO ACTQ
+6 ;parent
IF $ORDER(^OR(100,+ORDER,2,0))
GOTO ACTQ
+7 SET ORNMSP=$$NMSP^ORCD($PIECE(OR0,U,14))
+8 IF ORNMSP="PS"!(ORNMSP="FH")
DO MSG^ORMBLD(+ORDER,"SS")
+9 ;ck FH
IF ORNMSP="OR"!(ORNMSP="FH")
IF ORSTS=8
DO STATUS^ORCSAVE2(+ORDER,6)
ACTQ KILL ^OR(100,"AD",ORSTRT,ORDER)
+1 QUIT
+2 ;
PUR ; -- purge an order
+1 ; from PURGE^ORMEVNT(ORDER)
+2 NEW ORSTS,ORPK,ORNMSP,ORCHLD
IF '$DATA(^OR(100,ORDER))
QUIT
+3 SET ORSTS=$PIECE($GET(^OR(100,ORDER,3)),U,3)
SET ORPK=$GET(^(4))
SET ORNMSP=$PIECE($GET(^(0)),U,14)
SET ORNMSP=$$NMSP^ORCD(ORNMSP)
+4 IF '$LENGTH(ORPK)!(ORSTS=11)!(ORNMSP="OR")!(ORNMSP="LR"&('ORPK))
DO DELETE^ORCSAVE2(ORDER)
QUIT
+5 IF '$DATA(^OR(100,ORDER,2))
DO MSG^ORMBLD(ORDER,"Z@")
QUIT
+6 SET ORCHLD=0
FOR
SET ORCHLD=$ORDER(^OR(100,ORDER,2,ORCHLD))
IF ORCHLD'>0
QUIT
DO MSG^ORMBLD(ORCHLD,"Z@")
+7 ; delete parent
IF '$ORDER(^OR(100,ORDER,2,0))
DO DELETE^ORCSAVE2(ORDER)
+8 QUIT
+9 ;
CHKOBS ;177, previous dx from obs?
+1 NEW INVDT,PDCDT,PDCMVT,CADMDT
+2 ;Current admission d/t of movement
SET CADMDT=+$GET(VAIP(13,1))
IF 'CADMDT
QUIT
+3 ;Inverse date of movement
SET INVDT=9999999.9999999-(+VAIP(3))
+4 ;No previous discharge
SET PDCDT=$ORDER(^DGPM("ATID3",DFN,INVDT))
IF '+PDCDT
QUIT
+5 SET PDCMVT=$ORDER(^DGPM("ATID3",DFN,PDCDT,0))
+6 ;Quit if previous discharge not from obs
IF +$$MVT^DGPMOBS(PDCMVT)'=1
QUIT
+7 NEW VAIP
+8 SET VAIP("E")=PDCMVT
+9 DO IN5^VADPT
+10 ;No previous admission data
IF '$GET(VAIP(13))
QUIT
+11 ;Quit if previous discharge was more than 1 hour before admission
IF $$FMDIFF^XLFDT(CADMDT,+$GET(VAIP(3)),2)>3600
QUIT
+12 SET ORADM=+$GET(VAIP(13,1))
+13 QUIT
