Routine: ORMEVNT2

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

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

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMEVNT2   4032     printed  Mar 13, 2025@21:36:51                                                                                                                                                                                                    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

ORMEVNT2.m