- 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 Jan 18, 2025@03:33:02 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