ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ; 6/8/10 9:49am
;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195,278,243,324**;Dec 17, 1997;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN1 ; -- tasked entry point
Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) ;skip lodger mvts
N ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I
S ZTDESC="Auto-DC and/or Release orders on MAS movement",ZTIO=""
S ZTRTN="EN^ORMEVNT",ZTDTH=$H,ZTSAVE("^UTILITY(""DGPM"",$J,")=""
F I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT" S ZTSAVE(I)=""
D ^%ZTLOAD ;D EN^ORYDGPM
Q
;
EN ; -- main entry point
S:$D(ZTQUEUED) ZTREQ="@"
Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5)
I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195
I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 Q ;195 edits processed after new JEH
N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context
N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT
S VAIP("E")=DGPMDA D IN5^VADPT M ORVP=VAIP I '$G(DGPMA) D Q ;deleted
. N LAST,OREVT S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1
. S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0))
. D ACTLOG^OREVNTX(OREVT,"DL")
A ;
S ORVP=+DFN_";DPT(",ORTS=+$G(^DPT(DFN,.103)),ORWARD=$G(^(.1))
S ORWARD=$S($L(ORWARD):+$O(^DIC(42,"B",ORWARD,0)),1:0)
S ORL=$S(ORWARD:+$G(^DIC(42,ORWARD,44))_";SC(",1:""),ORDIV=$$DIV(+ORL)
S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)=""
S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y)
N OREVNTLK S OREVNTLK="" ;JEH
S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW") ; Lock
I OREVENT=-1 D EN1 Q ;195 Can't lock, retry
S OREVNTLK=OREVENT ; save routine copy of ifn JEH
I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D ;edited
. N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1
. S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0))
. S X=$G(^ORE(100.2,OREVT,10,DA,0)) ;last activity on movement
. I $P(X,U,5)=+$G(VAIP(4)),$P(X,U,6)=+$G(VAIP(8)),$P(X,U,7)=+$G(VAIP(5)) S DONE=1 Q ;no change
. I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1
I $G(DONE) D FINISHED Q ; unlock and clean up before quit IFNjeh
B ;
I '$G(DGPMP),ORCURRNT D ;new mvt - autoDC
. I $D(^ORE(100.2,"ADT",DGPMDA)) D Q:$G(DONE) ;ReEntered
.. N LAST,OREVT S DONE=0
.. S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1),OREVT=+$O(^(LAST,0))
.. Q:+ORVP'=+$G(^ORE(100.2,OREVT,0)) ;diff pat -> diff mvt
.. S ORACT="RE",DONE=1 Q:OREVENT ;log on new event instead
.. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1)
. I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out
. S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U))
. I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt
C ;
I OREVENT D ;release delayed orders, complete event
. D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA)
. I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use
. D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1)
. I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA
. ;D UNLEVT^ORX2(OREVENT)
I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL)
I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events
I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case
FINISHED ; unlock and clean up JEH
D:$G(OREVNTLK) UNLEVT^ORX2(OREVNTLK) K ^XTMP("OREVENT",DFN,DGPMDA) ;195
Q
;
CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement
N Y,LAST,LASTYPE,LASTDT S Y=0
S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2)
; VAIP(14) = last physical movement for the admission
I DGPMT=6 D G CQ
. N CA,IDT I LAST,LASTDT>+VAIP(3) Q ;last physical mvt
. S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3)
. I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q ;last TS mvt
I DGPMT=3 D ;get last mvt overall
. N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT
. S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset
I LAST=DGPMDA S Y=1 G CQ ;primary mvt
I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt
CQ Q Y
;
PREVTS() ; -- Returns previous treating specialty
N TS,TSP,CA,ID,LAST,Y
S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P"))
I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt
; look for TS mvt since last phys mvt
S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA
S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6))
PRVQ Q Y
;
TYPE(X) ; -- Return type of event from MAS code
N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"")
Q Y
;
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
;
PATEVT() ; -- Find match to new data in Patient Event file
N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ
S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0
S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)=""
I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH
I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH
I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154
F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S IFN=+$O(^(EVT,0)) D Q:Y
. Q:$$LAPSED^OREVNTX(+IFN) Q:$P($G(^ORE(100.2,IFN,1)),U,5)
. S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV
. I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q ;Xaction type
. I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q ;Mvt type
. I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS)) Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV"))
. I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD)) Q:ORWARD=ORLAST("WD")
. S Y=+IFN ;ok
I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible
PTQ Q Y
;
DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL
N MVTYPE,DIV,XFER,ORY,EXC,OBS
S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt
S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186
S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1)
I DGPMT=2,MVTYPE=13,$G(^XTMP("ORDCOBS-"_+ORVP,"READMIT")) S ORY=0 K ^XTMP("ORDCOBS-"_+ORVP,"READMIT") G DCQ ;186 Obs readmit from ASIH don't auto-dc
I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS
S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge
;*324 Replace ORDIV with DIV
S ORY=+$O(^ORD(100.6,"AC",DIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate
I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ
I MVTYPE=4 D G DCQ ;ck Div and Loc multiples
. I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q
. N OLD,INCL S INCL=0 ;ck incl loc's
. F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q
. S:'INCL ORY=0
I DGPMT=3,OBS D ;readmitting from observation?
. N TORY
. S TORY=ORY
. S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule
. I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0
. I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186
. K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds
DCQ Q ORY
;
READMIT() ; -- Return 1 or 0, if patient is being readmitted
N X,Y,DIR
S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? "
S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation."
D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^"
Q Y
;
COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15]
N ORI,ORLIST,ORIFN,OREDT
I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0
D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U)
F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S ORIFN=^(ORI) D STATUS^ORCSAVE2(+ORIFN,2) S:$G(OREDT) $P(^OR(100,+ORIFN,3),U)=OREDT,$P(^(6),U,6)=OREDT
Q
;
LOC(NODE) ; -- Returns [new] patient location from NODE
N X,Y S X=$P($G(NODE),U,6)
I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0))
S Y=+$G(^DIC(42,+X,44))_";SC("
Q Y
;
DISCH ; -- Lapse/cancel outstanding events on discharge
D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations
Q
;
XTMP ; -- Save ORIFN to possibly reinstate on admission
; Also uses ORVP, DGPMDA
Q:'$G(DGPMDA) Q:'$G(ORIFN) Q:'$G(ORVP)
N ORNOW S ORNOW=+$$NOW^XLFDT
I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0)<ORNOW K ^XTMP("ORDCOBS-"_+ORVP)
I '$G(^XTMP("ORDCOBS-"_+ORVP,0)) D
. N ORNOW1H S ORNOW1H=$$FMADD^XLFDT(ORNOW,,1)
. S ^XTMP("ORDCOBS-"_+ORVP,0)=ORNOW1H_U_ORNOW_"^InptMeds AutoDC'd on Discharge from Observation"
S ^XTMP("ORDCOBS-"_+ORVP,+ORIFN)=$G(^OR(100,+ORIFN,4))
S ^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE")=DGPMDA
Q
;
REINST ; -- Reinstate meds from observation
I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q ;DBIA 3598
N ORIDT,ORLASTDC,X0,ORIFN,PSIFN
S ORIDT=+$O(^DGPM("ATID3",+ORVP,0)) S:DGPMT=2 ORIDT=$O(^DGPM("ATID3",+ORVP,ORIDT)) Q:ORIDT<1 S ORLASTDC=+$O(^(ORIDT,0)) ;186 If reinstating for transfer TO ASIH then skip pseudo discharge for WHILE ASIH
Q:$G(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC S X0=$G(^(0))
I $P(X0,U)<$$NOW^XLFDT K ^XTMP("ORDCOBS-"_+ORVP) Q ;readmit after one hour 177
S ORIFN=0 F S ORIFN=+$O(^XTMP("ORDCOBS-"_+ORVP,ORIFN)) Q:ORIFN<1 S PSIFN=$G(^(ORIFN)) D:PSIFN ENR^PSJOERI(+ORVP,PSIFN,+ORWARD) ;DBIA 3598
K ^XTMP("ORDCOBS-"_+ORVP)
Q
;
; -- Moved code:
EXP(ORDER,ORSTOP) G EXP^ORMEVNT1
ACTIVE(ORDER,ORSTRT) G ACT^ORMEVNT1
PURGE(ORDER) G PUR^ORMEVNT1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMEVNT 9881 printed Dec 13, 2024@02:31:53 Page 2
ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ; 6/8/10 9:49am
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195,278,243,324**;Dec 17, 1997;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN1 ; -- tasked entry point
+1 ;skip lodger mvts
if '$GET(DFN)
QUIT
if $DATA(DGPMPC)
QUIT
if DGPMT=4!(DGPMT=5)
QUIT
+2 NEW ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I
+3 SET ZTDESC="Auto-DC and/or Release orders on MAS movement"
SET ZTIO=""
+4 SET ZTRTN="EN^ORMEVNT"
SET ZTDTH=$HOROLOG
SET ZTSAVE("^UTILITY(""DGPM"",$J,")=""
+5 FOR I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT"
SET ZTSAVE(I)=""
+6 ;D EN^ORYDGPM
DO ^%ZTLOAD
+7 QUIT
+8 ;
EN ; -- main entry point
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 if '$GET(DFN)
QUIT
if $DATA(DGPMPC)
QUIT
if DGPMT=4!(DGPMT=5)
QUIT
+3 ;195
IF '$GET(DGPMP)
SET ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag"
+4 ;195 edits processed after new JEH
IF $GET(DGPMP)
IF $DATA(^XTMP("OREVENT",DFN,DGPMDA))
DO EN1
QUIT
+5 ;protect protocol context
NEW XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT
+6 NEW VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT
+7 ;deleted
SET VAIP("E")=DGPMDA
DO IN5^VADPT
MERGE ORVP=VAIP
IF '$GET(DGPMA)
Begin DoDot:1
+8 NEW LAST,OREVT
SET LAST=+$ORDER(^ORE(100.2,"ADT",DGPMDA,""),-1)
if LAST<1
QUIT
+9 SET OREVT=+$ORDER(^ORE(100.2,"ADT",DGPMDA,LAST,0))
+10 DO ACTLOG^OREVNTX(OREVT,"DL")
End DoDot:1
QUIT
A ;
+1 SET ORVP=+DFN_";DPT("
SET ORTS=+$GET(^DPT(DFN,.103))
SET ORWARD=$GET(^(.1))
+2 SET ORWARD=$SELECT($LENGTH(ORWARD):+$ORDER(^DIC(42,"B",ORWARD,0)),1:0)
+3 SET ORL=$SELECT(ORWARD:+$GET(^DIC(42,ORWARD,44))_";SC(",1:"")
SET ORDIV=$$DIV(+ORL)
+4 SET ORLAST("TS")=$$PREVTS
SET X=+VAIP(15,4)
FOR I="WD","LOC","DIV"
SET ORLAST(I)=""
+5 if X
SET ORLAST("WD")=X
SET Y=+$GET(^DIC(42,X,44))
SET ORLAST("LOC")=Y_";SC("
SET ORLAST("DIV")=$$DIV(Y)
+6 ;JEH
NEW OREVNTLK
SET OREVNTLK=""
+7 ; Lock
SET ORCURRNT=$$CURRENT
SET OREVENT=$$PATEVT
SET ORACT=$SELECT($GET(DGPMP):"ED",1:"NW")
+8 ;195 Can't lock, retry
IF OREVENT=-1
DO EN1
QUIT
+9 ; save routine copy of ifn JEH
SET OREVNTLK=OREVENT
+10 ;edited
IF $GET(DGPMP)
IF $DATA(^ORE(100.2,"ADT",DGPMDA))
Begin DoDot:1
+11 NEW LAST,OREVT,DA,X,I
SET LAST=+$ORDER(^ORE(100.2,"ADT",DGPMDA,""),-1)
if LAST<1
QUIT
+12 SET OREVT=+$ORDER(^ORE(100.2,"ADT",DGPMDA,LAST,0))
SET DA=+$ORDER(^(OREVT,0))
+13 ;last activity on movement
SET X=$GET(^ORE(100.2,OREVT,10,DA,0))
+14 ;no change
IF $PIECE(X,U,5)=+$GET(VAIP(4))
IF $PIECE(X,U,6)=+$GET(VAIP(8))
IF $PIECE(X,U,7)=+$GET(VAIP(5))
SET DONE=1
QUIT
+15 IF 'OREVENT
DO ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1)
SET DONE=1
End DoDot:1
+16 ; unlock and clean up before quit IFNjeh
IF $GET(DONE)
DO FINISHED
QUIT
B ;
+1 ;new mvt - autoDC
IF '$GET(DGPMP)
IF ORCURRNT
Begin DoDot:1
+2 ;ReEntered
IF $DATA(^ORE(100.2,"ADT",DGPMDA))
Begin DoDot:2
+3 NEW LAST,OREVT
SET DONE=0
+4 SET LAST=+$ORDER(^ORE(100.2,"ADT",DGPMDA,""),-1)
SET OREVT=+$ORDER(^(LAST,0))
+5 ;diff pat -> diff mvt
if +ORVP'=+$GET(^ORE(100.2,OREVT,0))
QUIT
+6 ;log on new event instead
SET ORACT="RE"
SET DONE=1
if OREVENT
QUIT
+7 DO ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1)
End DoDot:2
if $GET(DONE)
QUIT
+8 ;keep until GMRA*4*15 gets out
IF DGPMT=3
DO COMP("ALG")
+9 SET ORDCRULE=$$DCEVT
if ORDCRULE
DO AUTODC^ORMEVNT1(ORDCRULE,$PIECE(DGPMA,U))
+10 ;186 TO ASIH tran mvmt
IF DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$PIECE(DGPMA,U,18)_"^")))
IF $GET(^XTMP("ORDCOBS-"_+ORVP,0))
DO REINST
End DoDot:1
C ;
+1 ;release delayed orders, complete event
IF OREVENT
Begin DoDot:1
+2 DO RELEASE^ORMEVNT1(OREVENT)
DO DONE^OREVNTX(OREVENT,$PIECE(DGPMA,U),DGPMDA)
+3 ;reset for ACTLOG use
IF '$GET(VAIP(1))
MERGE VAIP=ORVP
+4 DO ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1)
+5 IF DGPMT=1
IF '$PIECE($GET(^ORE(100.2,+OREVENT,0)),U,3)
SET $PIECE(^(0),U,3)=DGPMDA
+6 ;D UNLEVT^ORX2(OREVENT)
End DoDot:1
+7 IF $ORDER(ORPRINT(0))
IF $GET(ORL)
DO PRINTS^ORWD1(.ORPRINT,+ORL)
+8 ;lapse remaining events
IF DGPMT=3
IF ORCURRNT
IF '$GET(DGPMP)
DO DISCH
+9 ;just in case
IF '$GET(DFN)
IF $GET(ORVP)
SET DFN=+ORVP
FINISHED ; unlock and clean up JEH
+1 ;195
if $GET(OREVNTLK)
DO UNLEVT^ORX2(OREVNTLK)
KILL ^XTMP("OREVENT",DFN,DGPMDA)
+2 QUIT
+3 ;
CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement
+1 NEW Y,LAST,LASTYPE,LASTDT
SET Y=0
+2 SET LAST=+VAIP(14)
SET LASTDT=+VAIP(14,1)
SET LASTYPE=+VAIP(14,2)
+3 ; VAIP(14) = last physical movement for the admission
+4 IF DGPMT=6
Begin DoDot:1
+5 ;last physical mvt
NEW CA,IDT
IF LAST
IF LASTDT>+VAIP(3)
QUIT
+6 SET CA=+VAIP(13)
SET IDT=9999999.9999999-VAIP(3)
+7 ;last TS mvt
IF '$ORDER(^DGPM("ATS",DFN,CA,IDT),-1)
SET Y=1
QUIT
End DoDot:1
GOTO CQ
+8 ;get last mvt overall
IF DGPMT=3
Begin DoDot:1
+9 NEW VAIP,Y
SET VAIP("D")="LAST"
DO IN5^VADPT
+10 ;reset
SET LAST=+VAIP(14)
SET LASTYPE=+VAIP(14,2)
End DoDot:1
+11 ;primary mvt
IF LAST=DGPMDA
SET Y=1
GOTO CQ
+12 ;secondary mvt
IF $DATA(^UTILITY("DGPM",$JOB,LASTYPE,LAST))
SET Y=1
CQ QUIT Y
+1 ;
PREVTS() ; -- Returns previous treating specialty
+1 NEW TS,TSP,CA,ID,LAST,Y
+2 SET TS=+$ORDER(^UTILITY("DGPM",$JOB,6,0))
SET TSP=$GET(^(TS,"P"))
+3 ;edited TS mvt
IF $GET(TSP)
SET Y=+$PIECE(TSP,U,9)
GOTO PRVQ
+4 ; look for TS mvt since last phys mvt
+5 SET CA=$PIECE(DGPMA,U,14)
SET ID=9999999.9999999-DGPMA
+6 SET LAST=+$ORDER(^DGPM("ATS",DFN,CA,ID))
SET Y=$SELECT(LAST:+$ORDER(^(LAST,0)),1:+VAIP(15,6))
PRVQ QUIT Y
+1 ;
TYPE(X) ; -- Return type of event from MAS code
+1 NEW Y
SET Y=$SELECT(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"")
+2 QUIT Y
+3 ;
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 ;
PATEVT() ; -- Find match to new data in Patient Event file
+1 NEW TYPE,MVTYPE,EVT,IFN,X0,Y
SET Y=""
if '$GET(ORCURRNT)
GOTO PTQ
+2 SET TYPE=$SELECT(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:"")
SET EVT=0
+3 SET MVTYPE=$PIECE(DGPMA,U,18)
SET TYPE(1)=""
SET MVTYPE(1)=""
+4 ;To ASIH
IF DGPMT=2
IF MVTYPE=13
SET TYPE(1)="A"
SET MVTYPE(1)=40
+5 ;From ASIH
IF DGPMT=3
IF MVTYPE=41
SET TYPE(1)="T"
SET MVTYPE(1)=14
+6 ;DBIA #1154
IF DGPMT'=3
IF $$GET1^DIQ(45.7,+$GET(ORTS)_",","SPECIALTY:SERVICE")="NHCU"
SET TYPE(1)=$SELECT(TYPE="A":"T",1:"A")
+7 FOR
SET EVT=+$ORDER(^ORE(100.2,"AE",DFN,EVT))
if EVT<1
QUIT
SET IFN=+$ORDER(^(EVT,0))
Begin DoDot:1
+8 if $$LAPSED^OREVNTX(+IFN)
QUIT
if $PIECE($GET(^ORE(100.2,IFN,1)),U,5)
QUIT
+9 SET X0=$GET(^ORD(100.5,EVT,0))
if $PIECE(X0,U,3)'=ORDIV
QUIT
+10 ;Xaction type
IF $PIECE(X0,U,2)'=TYPE
IF $PIECE(X0,U,2)'=TYPE(1)
QUIT
+11 ;Mvt type
IF $PIECE(X0,U,7)
IF $PIECE(X0,U,7)'=MVTYPE
IF $PIECE(X0,U,7)'=MVTYPE(1)
QUIT
+12 IF $ORDER(^ORD(100.5,EVT,"TS",0))
if '$DATA(^("B",ORTS))
QUIT
if ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV"))
QUIT
+13 IF $ORDER(^ORD(100.5,EVT,"LOC",0))
if '$DATA(^("B",ORWARD))
QUIT
if ORWARD=ORLAST("WD")
QUIT
+14 ;ok
SET Y=+IFN
End DoDot:1
if Y
QUIT
+15 ;195 Lock event if possible
IF Y
if '$$LCKEVT^ORX2(Y)
SET Y=-1
PTQ QUIT Y
+1 ;
DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL
+1 NEW MVTYPE,DIV,XFER,ORY,EXC,OBS
+2 ;observation mvt
SET OBS=$SELECT(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0)
+3 ;ASIH- 186
SET MVTYPE=+$PIECE(DGPMA,U,18)
if MVTYPE=41
SET MVTYPE=14
if MVTYPE=40
SET MVTYPE=13
+4 SET XFER=$SELECT(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1)
+5 ;186 Obs readmit from ASIH don't auto-dc
IF DGPMT=2
IF MVTYPE=13
IF $GET(^XTMP("ORDCOBS-"_+ORVP,"READMIT"))
SET ORY=0
KILL ^XTMP("ORDCOBS-"_+ORVP,"READMIT")
GOTO DCQ
+6 ;TS
IF XFER
IF ORLAST("TS")'=ORTS
IF $DATA(^ORD(100.6,"AC",ORDIV,20))
SET MVTYPE=20
+7 ;discharge
SET DIV=ORDIV
IF DGPMT=3
IF MVTYPE'=14
SET DIV=ORLAST("DIV")
+8 ;*324 Replace ORDIV with DIV
+9 ;186, If obs, no active rule, no reinstate
SET ORY=+$ORDER(^ORD(100.6,"AC",DIV,MVTYPE,0))
if ORY<1&(DGPMT=3)&(OBS)
KILL ^XTMP("ORDCOBS-"_+ORVP)
if ORY<1
GOTO DCQ
+10 IF MVTYPE=20
IF $DATA(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS"))
SET ORY=0
GOTO DCQ
+11 ;ck Div and Loc multiples
IF MVTYPE=4
Begin DoDot:1
+12 IF ORLAST("DIV")'=ORDIV
if '$DATA(^ORD(100.6,ORY,6,ORLAST("DIV")))
SET ORY=0
QUIT
+13 ;ck incl loc's
NEW OLD,INCL
SET INCL=0
+14 FOR OLD=+ORLAST("LOC"),"ALL"
IF $DATA(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$DATA(^("ALL"))
SET INCL=1
QUIT
+15 if 'INCL
SET ORY=0
End DoDot:1
GOTO DCQ
+16 ;readmitting from observation?
IF DGPMT=3
IF OBS
Begin DoDot:1
+17 NEW TORY
+18 SET TORY=ORY
+19 ;ignore rule
SET EXC=+$PIECE($GET(^ORD(100.6,ORY,0)),U,6)
if EXC=2
SET ORY=0
+20 IF EXC=1
IF '$DATA(ZTQUEUED)
IF $$READMIT
SET ORY=0
+21 ;177,186
IF ORY=0
DO DCGEN^ORMEVNT2
DO TIMER^ORMEVNT2
if "^14^41^"[("^"_$PIECE(DGPMA,U,18)_"^")
SET ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1
+22 ;have rule -> dc, don't reinstate meds
if ORY
KILL ^XTMP("ORDCOBS-"_+ORVP)
End DoDot:1
DCQ QUIT ORY
+1 ;
READMIT() ; -- Return 1 or 0, if patient is being readmitted
+1 NEW X,Y,DIR
+2 SET DIR(0)="YA"
SET DIR("A")="Will the patient be re-admitted immediately? "
+3 SET DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation."
+4 DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
SET Y="^"
+5 QUIT Y
+6 ;
COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15]
+1 NEW ORI,ORLIST,ORIFN,OREDT
+2 IF 'ORDG
if ORDG?1.U
SET ORDG=+$ORDER(^ORD(100.98,"B",ORDG,0))
if ORDG'>0
QUIT
+3 DO EN^ORQ1(ORVP,ORDG,2)
SET ORI=0
SET OREDT=$PIECE(DGPMA,U)
+4 FOR
SET ORI=$ORDER(^TMP("ORR",$JOB,ORLIST,ORI))
if ORI'>0
QUIT
SET ORIFN=^(ORI)
DO STATUS^ORCSAVE2(+ORIFN,2)
if $GET(OREDT)
SET $PIECE(^OR(100,+ORIFN,3),U)=OREDT
SET $PIECE(^(6),U,6)=OREDT
+5 QUIT
+6 ;
LOC(NODE) ; -- Returns [new] patient location from NODE
+1 NEW X,Y
SET X=$PIECE($GET(NODE),U,6)
+2 IF X'>0
SET X=$PIECE($GET(^DPT(+ORVP,.1)),U)
if $LENGTH(X)
SET X=$ORDER(^DIC(42,"B",X,0))
+3 SET Y=+$GET(^DIC(42,+X,44))_";SC("
+4 QUIT Y
+5 ;
DISCH ; -- Lapse/cancel outstanding events on discharge
+1 ;195 Code moved to ORMEVNT2 for space considerations
DO DISCH^ORMEVNT2
+2 QUIT
+3 ;
XTMP ; -- Save ORIFN to possibly reinstate on admission
+1 ; Also uses ORVP, DGPMDA
+2 if '$GET(DGPMDA)
QUIT
if '$GET(ORIFN)
QUIT
if '$GET(ORVP)
QUIT
+3 NEW ORNOW
SET ORNOW=+$$NOW^XLFDT
+4 IF $GET(^XTMP("ORDCOBS-"_+ORVP,0))
IF +^(0)<ORNOW
KILL ^XTMP("ORDCOBS-"_+ORVP)
+5 IF '$GET(^XTMP("ORDCOBS-"_+ORVP,0))
Begin DoDot:1
+6 NEW ORNOW1H
SET ORNOW1H=$$FMADD^XLFDT(ORNOW,,1)
+7 SET ^XTMP("ORDCOBS-"_+ORVP,0)=ORNOW1H_U_ORNOW_"^InptMeds AutoDC'd on Discharge from Observation"
End DoDot:1
+8 SET ^XTMP("ORDCOBS-"_+ORVP,+ORIFN)=$GET(^OR(100,+ORIFN,4))
+9 SET ^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE")=DGPMDA
+10 QUIT
+11 ;
REINST ; -- Reinstate meds from observation
+1 ;DBIA 3598
IF '$LENGTH($TEXT(ENR^PSJOERI))
KILL ^XTMP("ORDCOBS-"_+ORVP)
QUIT
+2 NEW ORIDT,ORLASTDC,X0,ORIFN,PSIFN
+3 ;186 If reinstating for transfer TO ASIH then skip pseudo discharge for WHILE ASIH
SET ORIDT=+$ORDER(^DGPM("ATID3",+ORVP,0))
if DGPMT=2
SET ORIDT=$ORDER(^DGPM("ATID3",+ORVP,ORIDT))
if ORIDT<1
QUIT
SET ORLASTDC=+$ORDER(^(ORIDT,0))
+4 if $GET(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC
QUIT
SET X0=$GET(^(0))
+5 ;readmit after one hour 177
IF $PIECE(X0,U)<$$NOW^XLFDT
KILL ^XTMP("ORDCOBS-"_+ORVP)
QUIT
+6 ;DBIA 3598
SET ORIFN=0
FOR
SET ORIFN=+$ORDER(^XTMP("ORDCOBS-"_+ORVP,ORIFN))
if ORIFN<1
QUIT
SET PSIFN=$GET(^(ORIFN))
if PSIFN
DO ENR^PSJOERI(+ORVP,PSIFN,+ORWARD)
+7 KILL ^XTMP("ORDCOBS-"_+ORVP)
+8 QUIT
+9 ;
+10 ; -- Moved code:
EXP(ORDER,ORSTOP) GOTO EXP^ORMEVNT1
ACTIVE(ORDER,ORSTRT) GOTO ACT^ORMEVNT1
PURGE(ORDER) GOTO PUR^ORMEVNT1
