ORMEVNT2 ;SLC/DAN Additional event delayed order utilities ; 11/15/10 12:53pm
;;3.0;ORDER ENTRY/RESULTS REPORTING;**177,186,195,341**;Dec 17, 1997;Build 3
;
;DBIA SECTION
;10063 - %ZTLOAD
;17 - DGPM("ATID3"
;
DCGEN ;Auto-dc admission generic order for observation episode of
;care, if it exists and other orders are being carried over
;
N ORLIST,ORADM,OREASON,ORNATR,X,ORCREATE,ORPRNT,ORSIG,ORI,ORPKG,ORDC,ORDT,ORN
S ORLIST=$H
S ORADM=$G(VAIP(13,1)) ;Admission date/time for this episode of care
D ADMORD^ORMEVNT1 ;See if admission order exists
Q:'$D(^TMP("ORR",$J,ORLIST)) ;no order found
S OREASON=$P($G(^ORD(100.6,TORY,0)),U,4) I OREASON<1 S OREASON=+$O(^ORD(100.3,"C","ORDIS",0)) ;If no reason assigned to rule, use discharge
S ORNATR=+$P($G(^ORD(100.03,+$G(OREASON),0)),U,7) I ORNATR<1 S ORNATR=+$O(^ORD(100.02,"C","A",0)) ;Get nature from reason, if none then use auto-dc
S X=$G(^ORD(100.02,ORNATR,1)),ORCREATE=+$P(X,U),ORPRNT=+$P(X,U,2) ;create order action, print?
S ORSIG=$S('ORCREATE:"",1:$P(X,U,4)) ;Signature required?
S ORI=0 F S ORI=$O(^ORD(100.6,TORY,7,"B",ORI)) Q:ORI<1 S ORPKG(ORI)=1 ;Identify packages to be auto-dcd for the rule
S ORDT=$P($G(DGPMA),U),ORDC=TORY,ORN=""
D DC1^ORMEVNT1 ;Code to auto-dc order
Q
;
TIMER ;Start background job to make sure that patient was readmitted
;following the discharge from observation. Readmission must
;occur within 1 hour
N ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
S ZTRTN="TIMERDQ^ORMEVNT2",ZTIO="",ZTDESC="Observation readmit"
S ZTDTH=$P($G(^XTMP("ORDCOBS-"_+$G(ORVP),0)),U) ;If inpatient med orders will be reinstated, match timing
I ZTDTH="" S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,1) ;One hour from now
S ZTSAVE("*")="" ;Save everything for possible use in auto-dcing
D ^%ZTLOAD
Q
;
TIMERDQ ;Check if patient readmitted, if not, auto-dc orders that should have auto-dcd on discharge
N CVAIP
K VAIP("E") S VAIP("V")="CVAIP" D IN5^VADPT ;Is patient an inpatient?
I $G(^XTMP("ORDCOBS-"_$G(DFN),"READMIT")) G DEL ;186 If readmit from ASIH OBS hasn't happened then auto-dc orders
I CVAIP(13)'="",CVAIP(13)'=VAIP(13) Q ;Check to see that patient is currently an inpatient and that they are in a different episode of care than the observation episode
I +$P($Q(^DGPM("ATID3",DFN)),",",4)'=VAIP(1) Q ;Stop if there's been another discharge since the discharge from observation.
DEL K ^XTMP("ORDCOBS-"_$G(DFN)) ;Inpatient meds waiting for reinstatement are no longer needed so XTMP can be deleted
D AUTODC^ORMEVNT1(TORY,$P($G(DGPMA),U)) ;Auto-dc orders from observation
;*341 Check $G(OREVENT) first.
I $G(OREVENT),'$D(^ORE(100.2,$G(OREVENT),10)) D ACTLOG^OREVNTX(OREVENT,"NW","D",1),DONE^OREVNTX(OREVENT,,DGPMDA) ;186 Log event in 100.2 if not previously done
Q
;
DISCH ; -- Lapse/cancel outstanding events on discharge ;Section moved with 195
N X,ADM,EVT,ORP,X0,IFN,STS,X8,ORNOW,J,ORX,ORCH,DAD S ORNOW=+$E($$NOW^XLFDT,1,12) ;195
S X=$P(DGPMA,U,18),ADM=$S(X=12!(X=38):"",1:+$G(VAIP(13))),EVT=0
F S EVT=+$O(^ORE(100.2,"AE",+ORVP,EVT)) Q:EVT<1 S ORP=+$O(^(EVT,0)) D
. I $G(^ORE(100.2,ORP,1)) K ^ORE(100.2,"AE",+ORVP,EVT,ORP) Q
. Q:$$LAPSED^OREVNTX(ORP) I $$EMPTY^OREVNTX(ORP) D CANCEL^OREVNTX(ORP) Q
. I ADM,$P($G(^ORE(100.2,ORP,0)),U,3)'=ADM Q ;ck adm if not death
. S X0=$G(^ORE(100.2,ORP,0)),ORX=ORP ;195
. S DAD=0 I $D(^ORE(100.2,"DAD",ORP)) S ORCH=0,DAD=ORP F S ORCH=$O(^ORE(100.2,"DAD",ORP,ORCH)) Q:'+ORCH S ORX=ORX_","_ORCH ;195
. F J=1:1:$L(ORX,",") S ORP=$P(ORX,",",J) S IFN=0 F S IFN=$O(^OR(100,"AEVNT",ORVP,ORP,IFN)) Q:IFN<1 D ;195
.. S STS=$P($G(^OR(100,IFN,3)),U,3) I (STS=10)!(IFN=+$P(X0,U,4)) D
... D STATUS^ORCSAVE2(IFN,13) S X8=$G(^OR(100,IFN,8,1,0))
... S:$P(X8,U,15) $P(^OR(100,IFN,8,1,0),U,15)=13
... D:$P(X8,U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,1)
... S ^OR(100,IFN,6)=+$O(^ORD(100.02,"C","A",0))_U_U_ORNOW_U_+$O(^ORD(100.03,"C","ORDIS",0))_U_U_U_U_$G(OREVENT)
. S:$G(DAD) ORP=DAD D DONE^OREVNTX(ORP),ACTLOG^OREVNTX(ORP,"CA") ;195
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMEVNT2 4032 printed Dec 13, 2024@02:31:55 Page 2
ORMEVNT2 ;SLC/DAN Additional event delayed order utilities ; 11/15/10 12:53pm
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**177,186,195,341**;Dec 17, 1997;Build 3
+2 ;
+3 ;DBIA SECTION
+4 ;10063 - %ZTLOAD
+5 ;17 - DGPM("ATID3"
+6 ;
DCGEN ;Auto-dc admission generic order for observation episode of
+1 ;care, if it exists and other orders are being carried over
+2 ;
+3 NEW ORLIST,ORADM,OREASON,ORNATR,X,ORCREATE,ORPRNT,ORSIG,ORI,ORPKG,ORDC,ORDT,ORN
+4 SET ORLIST=$HOROLOG
+5 ;Admission date/time for this episode of care
SET ORADM=$GET(VAIP(13,1))
+6 ;See if admission order exists
DO ADMORD^ORMEVNT1
+7 ;no order found
if '$DATA(^TMP("ORR",$JOB,ORLIST))
QUIT
+8 ;If no reason assigned to rule, use discharge
SET OREASON=$PIECE($GET(^ORD(100.6,TORY,0)),U,4)
IF OREASON<1
SET OREASON=+$ORDER(^ORD(100.3,"C","ORDIS",0))
+9 ;Get nature from reason, if none then use auto-dc
SET ORNATR=+$PIECE($GET(^ORD(100.03,+$GET(OREASON),0)),U,7)
IF ORNATR<1
SET ORNATR=+$ORDER(^ORD(100.02,"C","A",0))
+10 ;create order action, print?
SET X=$GET(^ORD(100.02,ORNATR,1))
SET ORCREATE=+$PIECE(X,U)
SET ORPRNT=+$PIECE(X,U,2)
+11 ;Signature required?
SET ORSIG=$SELECT('ORCREATE:"",1:$PIECE(X,U,4))
+12 ;Identify packages to be auto-dcd for the rule
SET ORI=0
FOR
SET ORI=$ORDER(^ORD(100.6,TORY,7,"B",ORI))
if ORI<1
QUIT
SET ORPKG(ORI)=1
+13 SET ORDT=$PIECE($GET(DGPMA),U)
SET ORDC=TORY
SET ORN=""
+14 ;Code to auto-dc order
DO DC1^ORMEVNT1
+15 QUIT
+16 ;
TIMER ;Start background job to make sure that patient was readmitted
+1 ;following the discharge from observation. Readmission must
+2 ;occur within 1 hour
+3 NEW ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
+4 SET ZTRTN="TIMERDQ^ORMEVNT2"
SET ZTIO=""
SET ZTDESC="Observation readmit"
+5 ;If inpatient med orders will be reinstated, match timing
SET ZTDTH=$PIECE($GET(^XTMP("ORDCOBS-"_+$GET(ORVP),0)),U)
+6 ;One hour from now
IF ZTDTH=""
SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,1)
+7 ;Save everything for possible use in auto-dcing
SET ZTSAVE("*")=""
+8 DO ^%ZTLOAD
+9 QUIT
+10 ;
TIMERDQ ;Check if patient readmitted, if not, auto-dc orders that should have auto-dcd on discharge
+1 NEW CVAIP
+2 ;Is patient an inpatient?
KILL VAIP("E")
SET VAIP("V")="CVAIP"
DO IN5^VADPT
+3 ;186 If readmit from ASIH OBS hasn't happened then auto-dc orders
IF $GET(^XTMP("ORDCOBS-"_$GET(DFN),"READMIT"))
GOTO DEL
+4 ;Check to see that patient is currently an inpatient and that they are in a different episode of care than the observation episode
IF CVAIP(13)'=""
IF CVAIP(13)'=VAIP(13)
QUIT
+5 ;Stop if there's been another discharge since the discharge from observation.
IF +$PIECE($QUERY(^DGPM("ATID3",DFN)),",",4)'=VAIP(1)
QUIT
DEL ;Inpatient meds waiting for reinstatement are no longer needed so XTMP can be deleted
KILL ^XTMP("ORDCOBS-"_$GET(DFN))
+1 ;Auto-dc orders from observation
DO AUTODC^ORMEVNT1(TORY,$PIECE($GET(DGPMA),U))
+2 ;*341 Check $G(OREVENT) first.
+3 ;186 Log event in 100.2 if not previously done
IF $GET(OREVENT)
IF '$DATA(^ORE(100.2,$GET(OREVENT),10))
DO ACTLOG^OREVNTX(OREVENT,"NW","D",1)
DO DONE^OREVNTX(OREVENT,,DGPMDA)
+4 QUIT
+5 ;
DISCH ; -- Lapse/cancel outstanding events on discharge ;Section moved with 195
+1 ;195
NEW X,ADM,EVT,ORP,X0,IFN,STS,X8,ORNOW,J,ORX,ORCH,DAD
SET ORNOW=+$EXTRACT($$NOW^XLFDT,1,12)
+2 SET X=$PIECE(DGPMA,U,18)
SET ADM=$SELECT(X=12!(X=38):"",1:+$GET(VAIP(13)))
SET EVT=0
+3 FOR
SET EVT=+$ORDER(^ORE(100.2,"AE",+ORVP,EVT))
if EVT<1
QUIT
SET ORP=+$ORDER(^(EVT,0))
Begin DoDot:1
+4 IF $GET(^ORE(100.2,ORP,1))
KILL ^ORE(100.2,"AE",+ORVP,EVT,ORP)
QUIT
+5 if $$LAPSED^OREVNTX(ORP)
QUIT
IF $$EMPTY^OREVNTX(ORP)
DO CANCEL^OREVNTX(ORP)
QUIT
+6 ;ck adm if not death
IF ADM
IF $PIECE($GET(^ORE(100.2,ORP,0)),U,3)'=ADM
QUIT
+7 ;195
SET X0=$GET(^ORE(100.2,ORP,0))
SET ORX=ORP
+8 ;195
SET DAD=0
IF $DATA(^ORE(100.2,"DAD",ORP))
SET ORCH=0
SET DAD=ORP
FOR
SET ORCH=$ORDER(^ORE(100.2,"DAD",ORP,ORCH))
if '+ORCH
QUIT
SET ORX=ORX_","_ORCH
+9 ;195
FOR J=1:1:$LENGTH(ORX,",")
SET ORP=$PIECE(ORX,",",J)
SET IFN=0
FOR
SET IFN=$ORDER(^OR(100,"AEVNT",ORVP,ORP,IFN))
if IFN<1
QUIT
Begin DoDot:2
+10 SET STS=$PIECE($GET(^OR(100,IFN,3)),U,3)
IF (STS=10)!(IFN=+$PIECE(X0,U,4))
Begin DoDot:3
+11 DO STATUS^ORCSAVE2(IFN,13)
SET X8=$GET(^OR(100,IFN,8,1,0))
+12 if $PIECE(X8,U,15)
SET $PIECE(^OR(100,IFN,8,1,0),U,15)=13
+13 if $PIECE(X8,U,4)=2
DO SIGN^ORCSAVE2(IFN,"","",5,1)
+14 SET ^OR(100,IFN,6)=+$ORDER(^ORD(100.02,"C","A",0))_U_U_ORNOW_U_+$ORDER(^ORD(100.03,"C","ORDIS",0))_U_U_U_U_$GET(OREVENT)
End DoDot:3
End DoDot:2
+15 ;195
if $GET(DAD)
SET ORP=DAD
DO DONE^OREVNTX(ORP)
DO ACTLOG^OREVNTX(ORP,"CA")
End DoDot:1
+16 QUIT
