- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m
r613 r623 1 ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ;3/31/04 09:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195,278,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 EN1 ; -- tasked entry point 6 Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) ;skip lodger mvts 7 N ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I 8 S ZTDESC="Auto-DC and/or Release orders on MAS movement",ZTIO="" 9 S ZTRTN="EN^ORMEVNT",ZTDTH=$H,ZTSAVE("^UTILITY(""DGPM"",$J,")="" 10 F I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT" S ZTSAVE(I)="" 11 D ^%ZTLOAD ;D EN^ORYDGPM 12 Q 13 ; 14 EN ; -- main entry point 15 S:$D(ZTQUEUED) ZTREQ="@" 16 Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) 17 I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195 18 I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 Q ;195 edits processed after new JEH 19 N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context 20 N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT 21 S VAIP("E")=DGPMDA D IN5^VADPT M ORVP=VAIP I '$G(DGPMA) D Q ;deleted 22 . N LAST,OREVT S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 23 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)) 24 . D ACTLOG^OREVNTX(OREVT,"DL") 25 A ; 26 S ORVP=+DFN_";DPT(",ORTS=+$G(^DPT(DFN,.103)),ORWARD=$G(^(.1)) 27 S ORWARD=$S($L(ORWARD):+$O(^DIC(42,"B",ORWARD,0)),1:0) 28 S ORL=$S(ORWARD:+$G(^DIC(42,ORWARD,44))_";SC(",1:""),ORDIV=$$DIV(+ORL) 29 S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)="" 30 S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y) 31 N OREVNTLK S OREVNTLK="" ;JEH 32 S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW") ; Lock 33 I OREVENT=-1 D EN1 Q ;195 Can't lock, retry 34 S OREVNTLK=OREVENT ; save routine copy of ifn JEH 35 I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D ;edited 36 . N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 37 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0)) 38 . S X=$G(^ORE(100.2,OREVT,10,DA,0)) ;last activity on movement 39 . 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 40 . I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1 41 I $G(DONE) D FINISHED Q ; unlock and clean up before quit IFNjeh 42 B ; 43 I '$G(DGPMP),ORCURRNT D ;new mvt - autoDC 44 . I $D(^ORE(100.2,"ADT",DGPMDA)) D Q:$G(DONE) ;ReEntered 45 .. N LAST,OREVT S DONE=0 46 .. S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1),OREVT=+$O(^(LAST,0)) 47 .. Q:+ORVP'=+$G(^ORE(100.2,OREVT,0)) ;diff pat -> diff mvt 48 .. S ORACT="RE",DONE=1 Q:OREVENT ;log on new event instead 49 .. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1) 50 . I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out 51 . S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U)) 52 . I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt 53 C ; 54 I OREVENT D ;release delayed orders, complete event 55 . D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA) 56 . I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use 57 . D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1) 58 . I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA 59 . ;D UNLEVT^ORX2(OREVENT) 60 I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL) 61 I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events 62 I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case 63 FINISHED ; unlock and clean up JEH 64 D:$G(OREVNTLK) UNLEVT^ORX2(OREVNTLK) K ^XTMP("OREVENT",DFN,DGPMDA) ;195 65 Q 66 ; 67 CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement 68 N Y,LAST,LASTYPE,LASTDT S Y=0 69 S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2) 70 ; VAIP(14) = last physical movement for the admission 71 I DGPMT=6 D G CQ 72 . N CA,IDT I LAST,LASTDT>+VAIP(3) Q ;last physical mvt 73 . S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3) 74 . I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q ;last TS mvt 75 I DGPMT=3 D ;get last mvt overall 76 . N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT 77 . S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset 78 I LAST=DGPMDA S Y=1 G CQ ;primary mvt 79 I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt 80 CQ Q Y 81 ; 82 PREVTS() ; -- Returns previous treating specialty 83 N TS,TSP,CA,ID,LAST,Y 84 S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P")) 85 I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt 86 ; look for TS mvt since last phys mvt 87 S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA 88 S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6)) 89 PRVQ Q Y 90 ; 91 TYPE(X) ; -- Return type of event from MAS code 92 N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"") 93 Q Y 94 ; 95 DIV(LOC) ; -- Return Institution file #4 ptr for LOC 96 N X0,Y S X0=$G(^SC(+LOC,0)) 97 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))) 98 Q Y 99 ; 100 PATEVT() ; -- Find match to new data in Patient Event file 101 N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ 102 S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0 103 S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)="" 104 I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH 105 I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH 106 I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154 107 F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S IFN=+$O(^(EVT,0)) D Q:Y 108 . Q:$$LAPSED^OREVNTX(+IFN) Q:$P($G(^ORE(100.2,IFN,1)),U,5) 109 . S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV 110 . I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q ;Xaction type 111 . I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q ;Mvt type 112 . I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS)) Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV")) 113 . I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD)) Q:ORWARD=ORLAST("WD") 114 . S Y=+IFN ;ok 115 I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible 116 PTQ Q Y 117 ; 118 DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL 119 N MVTYPE,DIV,XFER,ORY,EXC,OBS 120 S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt 121 S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186 122 S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1) 123 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 124 I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS 125 S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge 126 S ORY=+$O(^ORD(100.6,"AC",ORDIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate 127 I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ 128 I MVTYPE=4 D G DCQ ;ck Div and Loc multiples 129 . I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q 130 . N OLD,INCL S INCL=0 ;ck incl loc's 131 . F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q 132 . S:'INCL ORY=0 133 I DGPMT=3,OBS D ;readmitting from observation? 134 . N TORY 135 . S TORY=ORY 136 . S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule 137 . I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0 138 . I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186 139 . K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds 140 DCQ Q ORY 141 ; 142 READMIT() ; -- Return 1 or 0, if patient is being readmitted 143 N X,Y,DIR 144 S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? " 145 S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation." 146 D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^" 147 Q Y 148 ; 149 COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15] 150 N ORI,ORLIST,ORIFN,OREDT 151 I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0 152 D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U) 153 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 154 Q 155 ; 156 LOC(NODE) ; -- Returns [new] patient location from NODE 157 N X,Y S X=$P($G(NODE),U,6) 158 I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0)) 159 S Y=+$G(^DIC(42,+X,44))_";SC(" 160 Q Y 161 ; 162 DISCH ; -- Lapse/cancel outstanding events on discharge 163 D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations 164 Q 165 ; 166 XTMP ; -- Save ORIFN to possibly reinstate on admission 167 ; Also uses ORVP, DGPMDA 168 Q:'$G(DGPMDA) Q:'$G(ORIFN) Q:'$G(ORVP) 169 N ORNOW S ORNOW=+$$NOW^XLFDT 170 I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0)<ORNOW K ^XTMP("ORDCOBS-"_+ORVP) 171 I '$G(^XTMP("ORDCOBS-"_+ORVP,0)) D 172 . N ORNOW1H S ORNOW1H=$$FMADD^XLFDT(ORNOW,,1) 173 . S ^XTMP("ORDCOBS-"_+ORVP,0)=ORNOW1H_U_ORNOW_"^InptMeds AutoDC'd on Discharge from Observation" 174 S ^XTMP("ORDCOBS-"_+ORVP,+ORIFN)=$G(^OR(100,+ORIFN,4)) 175 S ^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE")=DGPMDA 176 Q 177 ; 178 REINST ; -- Reinstate meds from observation 179 I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q ;DBIA 3598 180 N ORIDT,ORLASTDC,X0,ORIFN,PSIFN 181 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 182 Q:$G(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC S X0=$G(^(0)) 183 I $P(X0,U)<$$NOW^XLFDT K ^XTMP("ORDCOBS-"_+ORVP) Q ;readmit after one hour 177 184 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 185 K ^XTMP("ORDCOBS-"_+ORVP) 186 Q 187 ; 188 ; -- Moved code: 189 EXP(ORDER,ORSTOP) G EXP^ORMEVNT1 190 ACTIVE(ORDER,ORSTRT) G ACT^ORMEVNT1 191 PURGE(ORDER) G PUR^ORMEVNT1 1 ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ;3/31/04 09:21 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195**;Dec 17, 1997 3 ; 4 EN1 ; -- tasked entry point 5 Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) ;skip lodger mvts 6 N ZTDESC,ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTSK,I 7 S ZTDESC="Auto-DC and/or Release orders on MAS movement",ZTIO="" 8 S ZTRTN="EN^ORMEVNT",ZTDTH=$H,ZTSAVE("^UTILITY(""DGPM"",$J,")="" 9 F I="DFN","DGPMDA","DGPMA","DGPMP","DGPMT" S ZTSAVE(I)="" 10 D ^%ZTLOAD ;D EN^ORYDGPM 11 Q 12 ; 13 EN ; -- main entry point 14 S:$D(ZTQUEUED) ZTREQ="@" 15 Q:'$G(DFN) Q:$D(DGPMPC) Q:DGPMT=4!(DGPMT=5) 16 I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195 17 I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 ;195 edits processed after new 18 N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context 19 N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT 20 S VAIP("E")=DGPMDA D IN5^VADPT M ORVP=VAIP I '$G(DGPMA) D Q ;deleted 21 . N LAST,OREVT S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 22 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)) 23 . D ACTLOG^OREVNTX(OREVT,"DL") 24 A ; 25 S ORVP=+DFN_";DPT(",ORTS=+$G(^DPT(DFN,.103)),ORWARD=$G(^(.1)) 26 S ORWARD=$S($L(ORWARD):+$O(^DIC(42,"B",ORWARD,0)),1:0) 27 S ORL=$S(ORWARD:+$G(^DIC(42,ORWARD,44))_";SC(",1:""),ORDIV=$$DIV(+ORL) 28 S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)="" 29 S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y) 30 S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW") 31 I OREVENT=-1 D EN1 Q ;195 Can't lock, retry 32 I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D Q:$G(DONE) ;edited 33 . N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1 34 . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0)) 35 . S X=$G(^ORE(100.2,OREVT,10,DA,0)) ;last activity on movement 36 . 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 37 . I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1 38 B ; 39 I '$G(DGPMP),ORCURRNT D ;new mvt - autoDC 40 . I $D(^ORE(100.2,"ADT",DGPMDA)) D Q:$G(DONE) ;ReEntered 41 .. N LAST,OREVT S DONE=0 42 .. S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1),OREVT=+$O(^(LAST,0)) 43 .. Q:+ORVP'=+$G(^ORE(100.2,OREVT,0)) ;diff pat -> diff mvt 44 .. S ORACT="RE",DONE=1 Q:OREVENT ;log on new event instead 45 .. D ACTLOG^OREVNTX(OREVT,ORACT,$$TYPE(DGPMT),1) 46 . I DGPMT=3 D COMP("ALG") ;keep until GMRA*4*15 gets out 47 . S ORDCRULE=$$DCEVT D:ORDCRULE AUTODC^ORMEVNT1(ORDCRULE,$P(DGPMA,U)) 48 . I DGPMT=1!(DGPMT=2&("^13^40^"[("^"_$P(DGPMA,U,18)_"^"))) I $G(^XTMP("ORDCOBS-"_+ORVP,0)) D REINST ;186 TO ASIH tran mvmt 49 C ; 50 I OREVENT D ;release delayed orders, complete event 51 . D RELEASE^ORMEVNT1(OREVENT),DONE^OREVNTX(OREVENT,$P(DGPMA,U),DGPMDA) 52 . I '$G(VAIP(1)) M VAIP=ORVP ;reset for ACTLOG use 53 . D ACTLOG^OREVNTX(OREVENT,ORACT,$$TYPE(DGPMT),1) 54 . I DGPMT=1,'$P($G(^ORE(100.2,+OREVENT,0)),U,3) S $P(^(0),U,3)=DGPMDA 55 . ;D UNLEVT^ORX2(OREVENT) 56 I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL) 57 I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events 58 I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case 59 D:$G(OREVENT) UNLEVT^ORX2(OREVENT) K ^XTMP("OREVENT",DFN,DGPMDA) ;195 60 Q 61 ; 62 CURRENT() ; -- Returns 1 or 0, if DGPMDA is the latest movement 63 N Y,LAST,LASTYPE,LASTDT S Y=0 64 S LAST=+VAIP(14),LASTDT=+VAIP(14,1),LASTYPE=+VAIP(14,2) 65 ; VAIP(14) = last physical movement for the admission 66 I DGPMT=6 D G CQ 67 . N CA,IDT I LAST,LASTDT>+VAIP(3) Q ;last physical mvt 68 . S CA=+VAIP(13),IDT=9999999.9999999-VAIP(3) 69 . I '$O(^DGPM("ATS",DFN,CA,IDT),-1) S Y=1 Q ;last TS mvt 70 I DGPMT=3 D ;get last mvt overall 71 . N VAIP,Y S VAIP("D")="LAST" D IN5^VADPT 72 . S LAST=+VAIP(14),LASTYPE=+VAIP(14,2) ;reset 73 I LAST=DGPMDA S Y=1 G CQ ;primary mvt 74 I $D(^UTILITY("DGPM",$J,LASTYPE,LAST)) S Y=1 ;secondary mvt 75 CQ Q Y 76 ; 77 PREVTS() ; -- Returns previous treating specialty 78 N TS,TSP,CA,ID,LAST,Y 79 S TS=+$O(^UTILITY("DGPM",$J,6,0)),TSP=$G(^(TS,"P")) 80 I $G(TSP) S Y=+$P(TSP,U,9) G PRVQ ;edited TS mvt 81 ; look for TS mvt since last phys mvt 82 S CA=$P(DGPMA,U,14),ID=9999999.9999999-DGPMA 83 S LAST=+$O(^DGPM("ATS",DFN,CA,ID)),Y=$S(LAST:+$O(^(LAST,0)),1:+VAIP(15,6)) 84 PRVQ Q Y 85 ; 86 TYPE(X) ; -- Return type of event from MAS code 87 N Y S Y=$S(X=1:"A",X=2:"T",X=3:"D",X=6:"S",1:"") 88 Q Y 89 ; 90 DIV(LOC) ; -- Return Institution file #4 ptr for LOC 91 N X0,Y S X0=$G(^SC(+LOC,0)) 92 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))) 93 Q Y 94 ; 95 PATEVT() ; -- Find match to new data in Patient Event file 96 N TYPE,MVTYPE,EVT,IFN,X0,Y S Y="" G:'$G(ORCURRNT) PTQ 97 S TYPE=$S(DGPMT=1:"A",DGPMT=3:"D",DGPMT=2!(DGPMT=6):"T",1:""),EVT=0 98 S MVTYPE=$P(DGPMA,U,18),TYPE(1)="",MVTYPE(1)="" 99 I DGPMT=2,MVTYPE=13 S TYPE(1)="A",MVTYPE(1)=40 ;To ASIH 100 I DGPMT=3,MVTYPE=41 S TYPE(1)="T",MVTYPE(1)=14 ;From ASIH 101 I DGPMT'=3,$$GET1^DIQ(45.7,+$G(ORTS)_",","SPECIALTY:SERVICE")="NHCU" S TYPE(1)=$S(TYPE="A":"T",1:"A") ;DBIA #1154 102 F S EVT=+$O(^ORE(100.2,"AE",DFN,EVT)) Q:EVT<1 S IFN=+$O(^(EVT,0)) D Q:Y 103 . Q:$$LAPSED^OREVNTX(+IFN) Q:$P($G(^ORE(100.2,IFN,1)),U,5) 104 . S X0=$G(^ORD(100.5,EVT,0)) Q:$P(X0,U,3)'=ORDIV 105 . I $P(X0,U,2)'=TYPE,$P(X0,U,2)'=TYPE(1) Q ;Xaction type 106 . I $P(X0,U,7),$P(X0,U,7)'=MVTYPE,$P(X0,U,7)'=MVTYPE(1) Q ;Mvt type 107 . I $O(^ORD(100.5,EVT,"TS",0)) Q:'$D(^("B",ORTS)) Q:ORTS=ORLAST("TS")&(ORDIV=ORLAST("DIV")) 108 . I $O(^ORD(100.5,EVT,"LOC",0)) Q:'$D(^("B",ORWARD)) Q:ORWARD=ORLAST("WD") 109 . S Y=+IFN ;ok 110 I Y S:'$$LCKEVT^ORX2(Y) Y=-1 ;195 Lock event if possible 111 PTQ Q Y 112 ; 113 DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV,ORTS,ORL 114 N MVTYPE,DIV,XFER,ORY,EXC,OBS 115 S OBS=$S(DGPMT=3:$$MVT^DGPMOBS(DGPMDA),1:0) ;observation mvt 116 S MVTYPE=+$P(DGPMA,U,18) S:MVTYPE=41 MVTYPE=14 S:MVTYPE=40 MVTYPE=13 ;ASIH- 186 117 S XFER=$S(DGPMT=2:1,DGPMT=6:1,MVTYPE'=14:0,OBS:0,1:1) 118 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 119 I XFER,ORLAST("TS")'=ORTS,$D(^ORD(100.6,"AC",ORDIV,20)) S MVTYPE=20 ;TS 120 S DIV=ORDIV I DGPMT=3,MVTYPE'=14 S DIV=ORLAST("DIV") ;discharge 121 S ORY=+$O(^ORD(100.6,"AC",ORDIV,MVTYPE,0)) K:ORY<1&(DGPMT=3)&(OBS) ^XTMP("ORDCOBS-"_+ORVP) G:ORY<1 DCQ ;186, If obs, no active rule, no reinstate 122 I MVTYPE=20,$D(^ORD(100.6,ORY,4,ORLAST("TS"),1,ORTS))!(ORTS=ORLAST("TS")) S ORY=0 G DCQ 123 I MVTYPE=4 D G DCQ ;ck Div and Loc multiples 124 . I ORLAST("DIV")'=ORDIV S:'$D(^ORD(100.6,ORY,6,ORLAST("DIV"))) ORY=0 Q 125 . N OLD,INCL S INCL=0 ;ck incl loc's 126 . F OLD=+ORLAST("LOC"),"ALL" I $D(^ORD(100.6,ORY,5,"ADC",OLD,+ORL))!$D(^("ALL")) S INCL=1 Q 127 . S:'INCL ORY=0 128 I DGPMT=3,OBS D ;readmitting from observation? 129 . N TORY 130 . S TORY=ORY 131 . S EXC=+$P($G(^ORD(100.6,ORY,0)),U,6) S:EXC=2 ORY=0 ;ignore rule 132 . I EXC=1,'$D(ZTQUEUED),$$READMIT S ORY=0 133 . I ORY=0 D DCGEN^ORMEVNT2,TIMER^ORMEVNT2 S:"^14^41^"[("^"_$P(DGPMA,U,18)_"^") ^XTMP("ORDCOBS-"_+ORVP,"READMIT")=1 ;177,186 134 . K:ORY ^XTMP("ORDCOBS-"_+ORVP) ;have rule -> dc, don't reinstate meds 135 DCQ Q ORY 136 ; 137 READMIT() ; -- Return 1 or 0, if patient is being readmitted 138 N X,Y,DIR 139 S DIR(0)="YA",DIR("A")="Will the patient be re-admitted immediately? " 140 S DIR("?")="Enter YES if the patient is to be admitted to the hospital immediately following this discharge from observation." 141 D ^DIR S:$D(DTOUT)!$D(DUOUT) Y="^" 142 Q Y 143 ; 144 COMP(ORDG) ; -- Complete orders on event [Keep until GMRA*4*15] 145 N ORI,ORLIST,ORIFN,OREDT 146 I 'ORDG S:ORDG?1.U ORDG=+$O(^ORD(100.98,"B",ORDG,0)) Q:ORDG'>0 147 D EN^ORQ1(ORVP,ORDG,2) S ORI=0,OREDT=$P(DGPMA,U) 148 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 149 Q 150 ; 151 LOC(NODE) ; -- Returns [new] patient location from NODE 152 N X,Y S X=$P($G(NODE),U,6) 153 I X'>0 S X=$P($G(^DPT(+ORVP,.1)),U) S:$L(X) X=$O(^DIC(42,"B",X,0)) 154 S Y=+$G(^DIC(42,+X,44))_";SC(" 155 Q Y 156 ; 157 DISCH ; -- Lapse/cancel outstanding events on discharge 158 D DISCH^ORMEVNT2 ;195 Code moved to ORMEVNT2 for space considerations 159 Q 160 ; 161 XTMP ; -- Save ORIFN to possibly reinstate on admission 162 ; Also uses ORVP, DGPMDA 163 Q:'$G(DGPMDA) Q:'$G(ORIFN) Q:'$G(ORVP) 164 N ORNOW S ORNOW=+$$NOW^XLFDT 165 I $G(^XTMP("ORDCOBS-"_+ORVP,0)),+^(0)<ORNOW K ^XTMP("ORDCOBS-"_+ORVP) 166 I '$G(^XTMP("ORDCOBS-"_+ORVP,0)) D 167 . N ORNOW1H S ORNOW1H=$$FMADD^XLFDT(ORNOW,,1) 168 . S ^XTMP("ORDCOBS-"_+ORVP,0)=ORNOW1H_U_ORNOW_"^InptMeds AutoDC'd on Discharge from Observation" 169 S ^XTMP("ORDCOBS-"_+ORVP,+ORIFN)=$G(^OR(100,+ORIFN,4)) 170 S ^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE")=DGPMDA 171 Q 172 ; 173 REINST ; -- Reinstate meds from observation 174 I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q 175 N ORIDT,ORLASTDC,X0,ORIFN,PSIFN 176 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 177 Q:$G(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC S X0=$G(^(0)) 178 I $P(X0,U)<$$NOW^XLFDT K ^XTMP("ORDCOBS-"_+ORVP) Q ;readmit after one hour 177 179 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) 180 K ^XTMP("ORDCOBS-"_+ORVP) 181 Q 182 ; 183 ; -- Moved code: 184 EXP(ORDER,ORSTOP) G EXP^ORMEVNT1 185 ACTIVE(ORDER,ORSTRT) G ACT^ORMEVNT1 186 PURGE(ORDER) G PUR^ORMEVNT1
Note:
See TracChangeset
for help on using the changeset viewer.
