ORB3TIM2 ; slc/CLA - Routine to trigger time-related notifications ;3/30/01 07:41 [1/3/05 8:21am]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**102,215,251,265**;Dec 17, 1997;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EXPIR ;trigger expiring order notifs
N EDT,EXDT,EXORN,ORBDNR,ORPT,ORBRSLT,RXORD,ORLASTDT,X,Y,%DT
N OIFILE,ORBY,ORBZ,ORBI,ORSCH,ORSCHFIL,ONETIME,ORST,ORNG,ORDT,ORDW,ORHOL
N EXOI,ORBLST,ORBERR,OITXT,PTLOC,ORSDT,ORNOW,ORLDT
;
S ORNOW=$$NOW^XLFDT
;
I '$D(^XTMP("ORB LAST EXPIRE")) D ;holds last dt EXPIR processed
.S ^XTMP("ORB LAST EXPIRE",0)=$$FMADD^XLFDT(ORNOW,7,"","","")_U
;
;determine number of days to return orders using day of week & holidays
F ORNG=1:1 D I ORHOL=0,ORDW=0 Q
.S ORDW=$S($H-4+ORNG#7>4:1,1:0) ;if Sat or Sun, ORDW=0
.S ORDT=$$FMADD^XLFDT(DT,ORNG)
.K DIC S DIC="^HOLIDAY(",X=ORDT D ^DIC
.S ORHOL=$S(+$G(Y)>0:1,1:0) ;if ORDT is a holiday, ORHOL=0
S %DT="",X="T+"_ORNG D ^%DT
S EDT=Y_".2400"
K DIC
;
;get DNR OIs:
S OIFILE=$$TERMLKUP^ORB31(.ORBY,"DNR")
;
;get local admin schedules for ONE TIME MED:
S ORSCHFIL=$$TERMLKUP^ORB31(.ORBZ,"ONE TIME MED")
;
;examine expiring orders:
S ORLASTDT=$P(^XTMP("ORB LAST EXPIRE",0),U,2)
S EXDT=$S($L(ORLASTDT):ORLASTDT,1:ORNOW)
F S EXDT=$O(^OR(100,"AE",EXDT)) Q:(EXDT="") D Q:ORBRSLT<0
.S ORBRSLT=$$FMDIFF^XLFDT(EDT,$P(EXDT,".")_".2400",2) ;diff in seconds
.Q:ORBRSLT<0
.S EXORN="" F S EXORN=$O(^OR(100,"AE",EXDT,EXORN)) Q:EXORN="" D
..;
..;Quit if isn't at least next day after order's Date of Last Activity:
..S ORLDT=$P(^OR(100,EXORN,3),U)
..Q:$$FMDIFF^XLFDT(ORNOW,ORLDT)<1
..;
..Q:$D(^XTMP("ORB LAST EXPIRE",EXORN)) ;quit if order already processed
..S ^XTMP("ORB LAST EXPIRE",EXORN)=EXDT
..;
..S ORPT=$$PT^ORQOR2(EXORN) ; get pt assoc w/order
..Q:+$G(ORPT)<1
..;
..Q:+$G(^DPT(ORPT,.35))>0 ; quit if pt deceased - DBIA #10035
..;
..S PTLOC=$G(^DPT(+$G(ORPT),.1)),PTLOC=$S($L(PTLOC):PTLOC,1:"OUTPT")
..;
..; is expiring order a DNR order:
..I $D(ORBY),(+$G(OIFILE)=101.43) D
...F ORBI=1:1:ORBY D
....S ORBDNR=$P(ORBY(ORBI),U) I ORBDNR=$$OI^ORQOR2(EXORN) D
.....S ORST=$P($$STATUS^ORQOR2(EXORN),U,2)
.....I ORST'="DISCONTINUED",ORST'="COMPLETE",ORST'="EXPIRED",ORST'="CANCELLED",ORST'="DISCONTINUED/EDIT" D
......D EN^ORB3(45,ORPT,EXORN,"","",EXORN_"@") ;trigger DNR notif
..;
..; is expiring order a flagged oi:
..S EXOI=$$OI^ORQOR2(EXORN) I +$G(EXOI)>0 D
...I $L(PTLOC),PTLOC'="OUTPT" D
....D ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - INPT","`"_EXOI,.ORBERR)
....I 'ORBERR,'$G(ORBLST) D ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - INPT PR","`"_EXOI,.ORBERR)
....I 'ORBERR,$G(ORBLST)>0 D
.....S OITXT=$P(^ORD(101.43,EXOI,0),U)
.....S ORSDT=$P(^OR(100,EXORN,0),U,8),ORSDT=$$FMTE^XLFDT(ORSDT,"2P")
.....D EN^ORB3(64,ORPT,EXORN,"","["_PTLOC_"] Order expiring: "_OITXT_" "_ORSDT,EXORN_"@") ;trigger Expiring Flagged OI - INPT notification
...;
...I $L(PTLOC),PTLOC="OUTPT" D
....D ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - OUTPT","`"_EXOI,.ORBERR)
....I 'ORBERR,$G(ORBLST)>0 D
.....S OITXT=$P(^ORD(101.43,EXOI,0),U)
.....S ORSDT=$P(^OR(100,EXORN,0),U,8),ORSDT=$$FMTE^XLFDT(ORSDT,"2P")
.....D EN^ORB3(65,ORPT,EXORN,"","["_PTLOC_"] Order expiring: "_OITXT_" "_ORSDT,EXORN_"@") ;trigger Expiring Flagged OI - OUTPT notification
..;
..;is expiring order a med order:
..S RXORD=$$DGRX^ORQOR2(EXORN)
..I $L(RXORD) D ;if expiring order is a med order
...;
...N DFN S DFN=ORPT
...D ADM^VADPT2
...;
...I (RXORD="OUTPATIENT MEDICATIONS")!(+$G(VADMVT)<1&(RXORD'="CLINIC ORDERS")) D
....D EN^ORB3(72,ORPT,EXORN,"","",EXORN_"@") ;trigger outpt notif
...;
...Q:RXORD="OUTPATIENT MEDICATIONS" ;quit if an outpt med
...Q:+$G(VADMVT)<1&(RXORD'="CLINIC ORDERS") ;quit if an outpt
...;
...K VADMVT
...;
...;is schedule for the order a ONE TIME MED:
...S ONETIME=0
...I $D(ORBZ),(+$G(ORSCHFIL)=51.1) F ORBI=1:1:ORBZ D
....S ORSCH=$P(ORBZ(ORBI),U,2)
....I ORSCH=$$VALUE^ORCSAVE2(EXORN,"SCHEDULE") S ONETIME=1 Q
...Q:+$G(ONETIME)=1 ;quit if one time med
...;
...;check if this is an IMO order and what it is,send an M.E.-OUTPT alert
...I RXORD="CLINIC ORDERS" D Q
....N ORDLG,ORDG,ORDLGNM,FLAG,ORX
....S FLAG=0
....S ORDLG=$P($G(^OR(100,EXORN,0)),U,5) Q:$P(ORDLG,";",2)'="ORD(101.41,"
....S ORDLGNM=$P($G(^ORD(101.41,+ORDLG,0)),U)
....S ORDG=$P($G(^ORD(101.41,+ORDLG,0)),U,2)
....I ORDLGNM="PSJ OR PAT OE"!(ORDLGNM="PSJI OR PAT FLUID OE") S FLAG=1
....I 'FLAG F ORX="INPATIENT MEDICATIONS","IV MEDICATIONS","UNIT DOSE MEDICATIONS","CLINIC ORDERS" I $$UPPER^ORU(ORDG)=ORX D
.....S FLAG=1
.....I ORX="IV MEDICATIONS",(+$$IVRENEW(EXORN)=0) S FLAG=0
.....I ORX="UNIT DOSE MEDICATIONS",(+$$UDRENEW(EXORN,EXDT)=0) S FLAG=0
....I FLAG D EN^ORB3(72,ORPT,EXORN,"","",EXORN_"@") ;trigger outpt notif
...;
...;quit if inpt/unit dose med and med is not renewable:
...I RXORD="UNIT DOSE MEDICATIONS",(+$$UDRENEW(EXORN,EXDT)=0) Q
...;
...;quit if IV med and med is not renewable:
...I RXORD="IV MEDICATIONS",(+$$IVRENEW(EXORN)=0) Q
...;
...D EN^ORB3(47,ORPT,EXORN,"","",EXORN_"@") ;trigger notif
S ^XTMP("ORB LAST EXPIRE",0)=$$FMADD^XLFDT(ORNOW,7,"","","")_U_$$NOW^XLFDT
D EXCLN(ORNOW)
Q
UDRENEW(EXORN,EXDT) ;extr function returns 1 if med is renewable, 0 if not
N ORNOW,ORSLT,ORSTATUS
S ORSLT=0
S ORSTATUS=$P($$STATUS^ORQOR2(EXORN),U,2)
I ORSTATUS="ACTIVE" Q 1 ;renewable if "active"
I ORSTATUS="HOLD" Q 1 ;renewable if "on hold"
I ORSTATUS="EXPIRED" D
.S ORNOW=$$NOW^XLFDT
.;renewable if expired w/in past 4 days:
.I $$FMDIFF^XLFDT(ORNOW,EXDT,1)<4 S ORSLT=1
Q ORSLT
;
IVRENEW(EXORN) ;extr function returns 1 if med is renewable, 0 if not
N ORSLT,ORSTATUS
S ORSLT=0
S ORSTATUS=$P($$STATUS^ORQOR2(EXORN),U,2)
I ORSTATUS="ACTIVE" Q 1 ;renewable if "active"
I ORSTATUS="HOLD" Q 1 ;renewable if "on hold"
I ORSTATUS="EXPIRED" Q 1 ;renewable if "expired"
Q ORSLT
;
EXCLN(ORNOW) ;clean up old entires in ^XTMP("ORB LAST EXPIRE")
N ORN,ORDT
S ORN=1
F S ORN=$O(^XTMP("ORB LAST EXPIRE",ORN)) Q:ORN="" D
.S ORDT=$G(^XTMP("ORB LAST EXPIRE",ORN))
.I $L(ORDT),(ORDT<ORNOW) D
..K ^XTMP("ORB LAST EXPIRE",ORN)
Q
ORB3TIM2 ; slc/CLA - Routine to trigger time-related notifications ;3/30/01 07:41 [1/3/05 8:21am]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**102,215,251,265**;Dec 17, 1997;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EXPIR ;trigger expiring order notifs
+1 NEW EDT,EXDT,EXORN,ORBDNR,ORPT,ORBRSLT,RXORD,ORLASTDT,X,Y,%DT
+2 NEW OIFILE,ORBY,ORBZ,ORBI,ORSCH,ORSCHFIL,ONETIME,ORST,ORNG,ORDT,ORDW,ORHOL
+3 NEW EXOI,ORBLST,ORBERR,OITXT,PTLOC,ORSDT,ORNOW,ORLDT
+4 ;
+5 SET ORNOW=$$NOW^XLFDT
+6 ;
+7 ;holds last dt EXPIR processed
IF '$DATA(^XTMP("ORB LAST EXPIRE"))
Begin DoDot:1
+8 SET ^XTMP("ORB LAST EXPIRE",0)=$$FMADD^XLFDT(ORNOW,7,"","","")_U
End DoDot:1
+9 ;
+10 ;determine number of days to return orders using day of week & holidays
+11 FOR ORNG=1:1
Begin DoDot:1
+12 ;if Sat or Sun, ORDW=0
SET ORDW=$SELECT($HOROLOG-4+ORNG#7>4:1,1:0)
+13 SET ORDT=$$FMADD^XLFDT(DT,ORNG)
+14 KILL DIC
SET DIC="^HOLIDAY("
SET X=ORDT
DO ^DIC
+15 ;if ORDT is a holiday, ORHOL=0
SET ORHOL=$SELECT(+$GET(Y)>0:1,1:0)
End DoDot:1
IF ORHOL=0
IF ORDW=0
QUIT
+16 SET %DT=""
SET X="T+"_ORNG
DO ^%DT
+17 SET EDT=Y_".2400"
+18 KILL DIC
+19 ;
+20 ;get DNR OIs:
+21 SET OIFILE=$$TERMLKUP^ORB31(.ORBY,"DNR")
+22 ;
+23 ;get local admin schedules for ONE TIME MED:
+24 SET ORSCHFIL=$$TERMLKUP^ORB31(.ORBZ,"ONE TIME MED")
+25 ;
+26 ;examine expiring orders:
+27 SET ORLASTDT=$PIECE(^XTMP("ORB LAST EXPIRE",0),U,2)
+28 SET EXDT=$SELECT($LENGTH(ORLASTDT):ORLASTDT,1:ORNOW)
+29 FOR
SET EXDT=$ORDER(^OR(100,"AE",EXDT))
IF (EXDT="")
QUIT
Begin DoDot:1
+30 ;diff in seconds
SET ORBRSLT=$$FMDIFF^XLFDT(EDT,$PIECE(EXDT,".")_".2400",2)
+31 IF ORBRSLT<0
QUIT
+32 SET EXORN=""
FOR
SET EXORN=$ORDER(^OR(100,"AE",EXDT,EXORN))
IF EXORN=""
QUIT
Begin DoDot:2
+33 ;
+34 ;Quit if isn't at least next day after order's Date of Last Activity:
+35 SET ORLDT=$PIECE(^OR(100,EXORN,3),U)
+36 IF $$FMDIFF^XLFDT(ORNOW,ORLDT)<1
QUIT
+37 ;
+38 ;quit if order already processed
IF $DATA(^XTMP("ORB LAST EXPIRE",EXORN))
QUIT
+39 SET ^XTMP("ORB LAST EXPIRE",EXORN)=EXDT
+40 ;
+41 ; get pt assoc w/order
SET ORPT=$$PT^ORQOR2(EXORN)
+42 IF +$GET(ORPT)<1
QUIT
+43 ;
+44 ; quit if pt deceased - DBIA #10035
IF +$GET(^DPT(ORPT,.35))>0
QUIT
+45 ;
+46 SET PTLOC=$GET(^DPT(+$GET(ORPT),.1))
SET PTLOC=$SELECT($LENGTH(PTLOC):PTLOC,1:"OUTPT")
+47 ;
+48 ; is expiring order a DNR order:
+49 IF $DATA(ORBY)
IF (+$GET(OIFILE)=101.43)
Begin DoDot:3
+50 FOR ORBI=1:1:ORBY
Begin DoDot:4
+51 SET ORBDNR=$PIECE(ORBY(ORBI),U)
IF ORBDNR=$$OI^ORQOR2(EXORN)
Begin DoDot:5
+52 SET ORST=$PIECE($$STATUS^ORQOR2(EXORN),U,2)
+53 IF ORST'="DISCONTINUED"
IF ORST'="COMPLETE"
IF ORST'="EXPIRED"
IF ORST'="CANCELLED"
IF ORST'="DISCONTINUED/EDIT"
Begin DoDot:6
+54 ;trigger DNR notif
DO EN^ORB3(45,ORPT,EXORN,"","",EXORN_"@")
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
+55 ;
+56 ; is expiring order a flagged oi:
+57 SET EXOI=$$OI^ORQOR2(EXORN)
IF +$GET(EXOI)>0
Begin DoDot:3
+58 IF $LENGTH(PTLOC)
IF PTLOC'="OUTPT"
Begin DoDot:4
+59 DO ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - INPT","`"_EXOI,.ORBERR)
+60 IF 'ORBERR
IF '$GET(ORBLST)
DO ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - INPT PR","`"_EXOI,.ORBERR)
+61 IF 'ORBERR
IF $GET(ORBLST)>0
Begin DoDot:5
+62 SET OITXT=$PIECE(^ORD(101.43,EXOI,0),U)
+63 SET ORSDT=$PIECE(^OR(100,EXORN,0),U,8)
SET ORSDT=$$FMTE^XLFDT(ORSDT,"2P")
+64 ;trigger Expiring Flagged OI - INPT notification
DO EN^ORB3(64,ORPT,EXORN,"","["_PTLOC_"] Order expiring: "_OITXT_" "_ORSDT,EXORN_"@")
End DoDot:5
End DoDot:4
+65 ;
+66 IF $LENGTH(PTLOC)
IF PTLOC="OUTPT"
Begin DoDot:4
+67 DO ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - OUTPT","`"_EXOI,.ORBERR)
+68 IF 'ORBERR
IF $GET(ORBLST)>0
Begin DoDot:5
+69 SET OITXT=$PIECE(^ORD(101.43,EXOI,0),U)
+70 SET ORSDT=$PIECE(^OR(100,EXORN,0),U,8)
SET ORSDT=$$FMTE^XLFDT(ORSDT,"2P")
+71 ;trigger Expiring Flagged OI - OUTPT notification
DO EN^ORB3(65,ORPT,EXORN,"","["_PTLOC_"] Order expiring: "_OITXT_" "_ORSDT,EXORN_"@")
End DoDot:5
End DoDot:4
End DoDot:3
+72 ;
+73 ;is expiring order a med order:
+74 SET RXORD=$$DGRX^ORQOR2(EXORN)
+75 ;if expiring order is a med order
IF $LENGTH(RXORD)
Begin DoDot:3
+76 ;
+77 NEW DFN
SET DFN=ORPT
+78 DO ADM^VADPT2
+79 ;
+80 IF (RXORD="OUTPATIENT MEDICATIONS")!(+$GET(VADMVT)<1&(RXORD'="CLINIC ORDERS"))
Begin DoDot:4
+81 ;trigger outpt notif
DO EN^ORB3(72,ORPT,EXORN,"","",EXORN_"@")
End DoDot:4
+82 ;
+83 ;quit if an outpt med
IF RXORD="OUTPATIENT MEDICATIONS"
QUIT
+84 ;quit if an outpt
IF +$GET(VADMVT)<1&(RXORD'="CLINIC ORDERS")
QUIT
+85 ;
+86 KILL VADMVT
+87 ;
+88 ;is schedule for the order a ONE TIME MED:
+89 SET ONETIME=0
+90 IF $DATA(ORBZ)
IF (+$GET(ORSCHFIL)=51.1)
FOR ORBI=1:1:ORBZ
Begin DoDot:4
+91 SET ORSCH=$PIECE(ORBZ(ORBI),U,2)
+92 IF ORSCH=$$VALUE^ORCSAVE2(EXORN,"SCHEDULE")
SET ONETIME=1
QUIT
End DoDot:4
+93 ;quit if one time med
IF +$GET(ONETIME)=1
QUIT
+94 ;
+95 ;check if this is an IMO order and what it is,send an M.E.-OUTPT alert
+96 IF RXORD="CLINIC ORDERS"
Begin DoDot:4
+97 NEW ORDLG,ORDG,ORDLGNM,FLAG,ORX
+98 SET FLAG=0
+99 SET ORDLG=$PIECE($GET(^OR(100,EXORN,0)),U,5)
IF $PIECE(ORDLG,";",2)'="ORD(101.41,"
QUIT
+100 SET ORDLGNM=$PIECE($GET(^ORD(101.41,+ORDLG,0)),U)
+101 SET ORDG=$PIECE($GET(^ORD(101.41,+ORDLG,0)),U,2)
+102 IF ORDLGNM="PSJ OR PAT OE"!(ORDLGNM="PSJI OR PAT FLUID OE")
SET FLAG=1
+103 IF 'FLAG
FOR ORX="INPATIENT MEDICATIONS","IV MEDICATIONS","UNIT DOSE MEDICATIONS","CLINIC ORDERS"
IF $$UPPER^ORU(ORDG)=ORX
Begin DoDot:5
+104 SET FLAG=1
+105 IF ORX="IV MEDICATIONS"
IF (+$$IVRENEW(EXORN)=0)
SET FLAG=0
+106 IF ORX="UNIT DOSE MEDICATIONS"
IF (+$$UDRENEW(EXORN,EXDT)=0)
SET FLAG=0
End DoDot:5
+107 ;trigger outpt notif
IF FLAG
DO EN^ORB3(72,ORPT,EXORN,"","",EXORN_"@")
End DoDot:4
QUIT
+108 ;
+109 ;quit if inpt/unit dose med and med is not renewable:
+110 IF RXORD="UNIT DOSE MEDICATIONS"
IF (+$$UDRENEW(EXORN,EXDT)=0)
QUIT
+111 ;
+112 ;quit if IV med and med is not renewable:
+113 IF RXORD="IV MEDICATIONS"
IF (+$$IVRENEW(EXORN)=0)
QUIT
+114 ;
+115 ;trigger notif
DO EN^ORB3(47,ORPT,EXORN,"","",EXORN_"@")
End DoDot:3
End DoDot:2
End DoDot:1
IF ORBRSLT<0
QUIT
+116 SET ^XTMP("ORB LAST EXPIRE",0)=$$FMADD^XLFDT(ORNOW,7,"","","")_U_$$NOW^XLFDT
+117 DO EXCLN(ORNOW)
+118 QUIT
UDRENEW(EXORN,EXDT) ;extr function returns 1 if med is renewable, 0 if not
+1 NEW ORNOW,ORSLT,ORSTATUS
+2 SET ORSLT=0
+3 SET ORSTATUS=$PIECE($$STATUS^ORQOR2(EXORN),U,2)
+4 ;renewable if "active"
IF ORSTATUS="ACTIVE"
QUIT 1
+5 ;renewable if "on hold"
IF ORSTATUS="HOLD"
QUIT 1
+6 IF ORSTATUS="EXPIRED"
Begin DoDot:1
+7 SET ORNOW=$$NOW^XLFDT
+8 ;renewable if expired w/in past 4 days:
+9 IF $$FMDIFF^XLFDT(ORNOW,EXDT,1)<4
SET ORSLT=1
End DoDot:1
+10 QUIT ORSLT
+11 ;
IVRENEW(EXORN) ;extr function returns 1 if med is renewable, 0 if not
+1 NEW ORSLT,ORSTATUS
+2 SET ORSLT=0
+3 SET ORSTATUS=$PIECE($$STATUS^ORQOR2(EXORN),U,2)
+4 ;renewable if "active"
IF ORSTATUS="ACTIVE"
QUIT 1
+5 ;renewable if "on hold"
IF ORSTATUS="HOLD"
QUIT 1
+6 ;renewable if "expired"
IF ORSTATUS="EXPIRED"
QUIT 1
+7 QUIT ORSLT
+8 ;
EXCLN(ORNOW) ;clean up old entires in ^XTMP("ORB LAST EXPIRE")
+1 NEW ORN,ORDT
+2 SET ORN=1
+3 FOR
SET ORN=$ORDER(^XTMP("ORB LAST EXPIRE",ORN))
IF ORN=""
QUIT
Begin DoDot:1
+4 SET ORDT=$GET(^XTMP("ORB LAST EXPIRE",ORN))
+5 IF $LENGTH(ORDT)
IF (ORDT<ORNOW)
Begin DoDot:2
+6 KILL ^XTMP("ORB LAST EXPIRE",ORN)
End DoDot:2
End DoDot:1
+7 QUIT
