Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORB3TIM2

ORB3TIM2.m

Go to the documentation of this file.
  1. ORB3TIM2 ;SLC/CLA - Routine to trigger time-related notifications ; 9/27/17 1:13pm
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**102,215,251,265,356,350,450**;Dec 17, 1997;Build 14
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;DBIA SECTION
  1. ;10035 - ^DPT(
  1. ;10003 - ^%DPT
  1. ;10006 - ^DIC
  1. ; 325 - ^VADPT2
  1. ;10103 - ^XLFDT
  1. ; 2263 - ^XPAR
  1. ;
  1. EXPIR ;trigger expiring order notifs
  1. N EDT,EXDT,EXORN,ORBDNR,ORPT,ORBRSLT,RXORD,ORLASTDT,X,Y,%DT
  1. N OIFILE,ORBY,ORBZ,ORBI,ORSCH,ORSCHFIL,ONETIME,ORST,ORNG,ORDT,ORDW,ORHOL
  1. N EXOI,ORBLST,ORBERR,OITXT,PTLOC,ORSDT,ORNOW,ORLDT
  1. ;
  1. S ORNOW=$$NOW^XLFDT
  1. ;
  1. I '$D(^XTMP("ORB LAST EXPIRE")) D ;holds last dt EXPIR processed
  1. .S ^XTMP("ORB LAST EXPIRE",0)=$$FMADD^XLFDT(ORNOW,7,"","","")_U
  1. ;
  1. ;determine number of days to return orders using day of week & holidays
  1. F ORNG=1:1 D I ORHOL=0,ORDW=0 Q
  1. .S ORDW=$S($H-4+ORNG#7>4:1,1:0) ;if Sat or Sun, ORDW=0
  1. .S ORDT=$$FMADD^XLFDT(DT,ORNG)
  1. .K DIC S DIC="^HOLIDAY(",X=ORDT D ^DIC
  1. .S ORHOL=$S(+$G(Y)>0:1,1:0) ;if ORDT is a holiday, ORHOL=0
  1. S %DT="",X="T+"_ORNG D ^%DT
  1. S EDT=Y_".2400"
  1. K DIC
  1. ;
  1. ;get DNR OIs:
  1. S OIFILE=$$TERMLKUP^ORB31(.ORBY,"DNR")
  1. ;
  1. ;get local admin schedules for ONE TIME MED:
  1. S ORSCHFIL=$$TERMLKUP^ORB31(.ORBZ,"ONE TIME MED")
  1. ;
  1. ;examine expiring orders:
  1. S ORLASTDT=$P(^XTMP("ORB LAST EXPIRE",0),U,2)
  1. S EXDT=$S($L(ORLASTDT):ORLASTDT,1:ORNOW)
  1. F S EXDT=$O(^OR(100,"AE",EXDT)) Q:(EXDT="") D Q:ORBRSLT<0
  1. .S ORBRSLT=$$FMDIFF^XLFDT(EDT,$P(EXDT,".")_".2400",2) ;diff in seconds
  1. .Q:ORBRSLT<0
  1. .S EXORN="" F S EXORN=$O(^OR(100,"AE",EXDT,EXORN)) Q:EXORN="" D
  1. ..;
  1. ..;*356 Protect, if x-ref dangles.
  1. ..I '$D(^OR(100,EXORN)) K ^OR(100,"AE",EXDT,EXORN) Q
  1. ..;
  1. ..;Quit if isn't at least next day after order's Date of Last Activity:
  1. ..S ORLDT=$P(^OR(100,EXORN,3),U)
  1. ..Q:$$FMDIFF^XLFDT(ORNOW,ORLDT)<1
  1. ..;
  1. ..Q:$D(^XTMP("ORB LAST EXPIRE",EXORN)) ;quit if order already processed
  1. ..S ^XTMP("ORB LAST EXPIRE",EXORN)=EXDT
  1. ..;
  1. ..S ORPT=$$PT^ORQOR2(EXORN) ; get pt assoc w/order
  1. ..Q:+$G(ORPT)<1
  1. ..;
  1. ..Q:+$G(^DPT(ORPT,.35))>0 ; quit if pt deceased - DBIA #10035
  1. ..;
  1. ..S PTLOC=$G(^DPT(+$G(ORPT),.1)),PTLOC=$S($L(PTLOC):PTLOC,1:"OUTPT")
  1. ..;
  1. ..; is expiring order a DNR order:
  1. ..I $D(ORBY),(+$G(OIFILE)=101.43) D
  1. ...F ORBI=1:1:ORBY D
  1. ....S ORBDNR=$P(ORBY(ORBI),U) I ORBDNR=$$OI^ORQOR2(EXORN) D
  1. .....S ORST=$P($$STATUS^ORQOR2(EXORN),U,2)
  1. .....I ORST'="DISCONTINUED",ORST'="COMPLETE",ORST'="EXPIRED",ORST'="CANCELLED",ORST'="DISCONTINUED/EDIT" D
  1. ......D EN^ORB3(45,ORPT,EXORN,"","",EXORN_"@") ;trigger DNR notif
  1. ..;
  1. ..; is expiring order a flagged oi:
  1. ..;S EXOI=$$OI^ORQOR2(EXORN) I +$G(EXOI)>0 D
  1. ..;patch 450, all items not being checked
  1. ..S EXOIC=0
  1. ..F S EXOIC=$O(^OR(100,EXORN,.1,EXOIC)) Q:EXOIC="" D
  1. ...S EXOI=$G(^OR(100,EXORN,.1,EXOIC,0))
  1. ...I $L(PTLOC),PTLOC'="OUTPT",+$G(EXOI)>0 D
  1. ....D ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - INPT","`"_EXOI,.ORBERR)
  1. ....I 'ORBERR,'$G(ORBLST) D ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - INPT PR","`"_EXOI,.ORBERR)
  1. ....I 'ORBERR,$G(ORBLST)>0 D
  1. .....S OITXT=$P(^ORD(101.43,EXOI,0),U)
  1. .....S ORSDT=$P(^OR(100,EXORN,0),U,8),ORSDT=$$FMTE^XLFDT(ORSDT,"2P")
  1. .....D EN^ORB3(64,ORPT,EXORN,"","["_PTLOC_"] Order expiring: "_OITXT_" "_ORSDT,EXOI) ;trigger Expiring Flagged OI - INPT notification
  1. ...;
  1. ...I $L(PTLOC),PTLOC="OUTPT" D
  1. ....D ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - OUTPT","`"_EXOI,.ORBERR)
  1. ....;*356 Add OUTPT PR
  1. ....I 'ORBERR,'$G(ORBLST) D ENVAL^XPAR(.ORBLST,"ORB OI EXPIRING - OUTPT PR","`"_EXOI,.ORBERR)
  1. ....I 'ORBERR,$G(ORBLST)>0 D
  1. .....S OITXT=$P(^ORD(101.43,EXOI,0),U)
  1. .....S ORSDT=$P(^OR(100,EXORN,0),U,8),ORSDT=$$FMTE^XLFDT(ORSDT,"2P")
  1. .....D EN^ORB3(65,ORPT,EXORN,"","["_PTLOC_"] Order expiring: "_OITXT_" "_ORSDT,EXOI) ;trigger Expiring Flagged OI - OUTPT notification
  1. ..;
  1. ..;is expiring order a med order:
  1. ..S RXORD=$$DGRX^ORQOR2(EXORN)
  1. ..I $L(RXORD) D ;if expiring order is a med order
  1. ...;
  1. ...N DFN S DFN=ORPT
  1. ...D ADM^VADPT2
  1. ...;
  1. ...I (RXORD="OUTPATIENT MEDICATIONS")!(+$G(VADMVT)<1&(RXORD'?1"CLINIC ".E)) D
  1. ....D EN^ORB3(72,ORPT,EXORN,"","",EXORN_"@") ;trigger outpt notif
  1. ...;
  1. ...Q:RXORD="OUTPATIENT MEDICATIONS" ;quit if an outpt med
  1. ...Q:+$G(VADMVT)<1&(RXORD'?1"CLINIC ".E) ;quit if an outpt
  1. ...;
  1. ...K VADMVT
  1. ...;
  1. ...;is schedule for the order a ONE TIME MED:
  1. ...S ONETIME=0
  1. ...I $D(ORBZ),(+$G(ORSCHFIL)=51.1) F ORBI=1:1:ORBZ D
  1. ....S ORSCH=$P(ORBZ(ORBI),U,2)
  1. ....I ORSCH=$$VALUE^ORCSAVE2(EXORN,"SCHEDULE") S ONETIME=1 Q
  1. ...Q:+$G(ONETIME)=1 ;quit if one time med
  1. ...;
  1. ...;check if this is an IMO order and what it is,send an M.E.-OUTPT alert
  1. ...I RXORD?1"CLINIC ".E D Q
  1. ....N ORDLG,ORDG,ORDLGNM,FLAG,ORX
  1. ....S FLAG=0
  1. ....S ORDLG=$P($G(^OR(100,EXORN,0)),U,5) Q:$P(ORDLG,";",2)'="ORD(101.41,"
  1. ....S ORDLGNM=$P($G(^ORD(101.41,+ORDLG,0)),U)
  1. ....S ORDG=$P($G(^ORD(101.41,+ORDLG,0)),U,2)
  1. ....I ORDLGNM="PSJ OR PAT OE"!(ORDLGNM="PSJI OR PAT FLUID OE") S FLAG=1
  1. ....I 'FLAG F ORX="INPATIENT MEDICATIONS","IV MEDICATIONS","UNIT DOSE MEDICATIONS","CLINIC ORDERS","CLINIC INFUSIONS","CLINIC MEDICATIONS" I $$UPPER^ORU(ORDG)=ORX D
  1. .....S FLAG=1
  1. .....I ORX="IV MEDICATIONS",(+$$IVRENEW(EXORN)=0) S FLAG=0
  1. .....I ORX="UNIT DOSE MEDICATIONS",(+$$UDRENEW(EXORN,EXDT)=0) S FLAG=0
  1. ....I FLAG D EN^ORB3(72,ORPT,EXORN,"","",EXORN_"@") ;trigger outpt notif
  1. ...;
  1. ...;quit if inpt/unit dose med and med is not renewable:
  1. ...I RXORD="UNIT DOSE MEDICATIONS",(+$$UDRENEW(EXORN,EXDT)=0) Q
  1. ...;
  1. ...;quit if IV med and med is not renewable:
  1. ...I RXORD="IV MEDICATIONS",(+$$IVRENEW(EXORN)=0) Q
  1. ...;
  1. ...D EN^ORB3(47,ORPT,EXORN,"","",EXORN_"@") ;trigger notif
  1. S ^XTMP("ORB LAST EXPIRE",0)=$$FMADD^XLFDT(ORNOW,7,"","","")_U_$$NOW^XLFDT
  1. D EXCLN(ORNOW)
  1. Q
  1. UDRENEW(EXORN,EXDT) ;extr function returns 1 if med is renewable, 0 if not
  1. N ORNOW,ORSLT,ORSTATUS
  1. S ORSLT=0
  1. S ORSTATUS=$P($$STATUS^ORQOR2(EXORN),U,2)
  1. I ORSTATUS="ACTIVE" Q 1 ;renewable if "active"
  1. I ORSTATUS="HOLD" Q 1 ;renewable if "on hold"
  1. I ORSTATUS="EXPIRED" D
  1. .S ORNOW=$$NOW^XLFDT
  1. .;renewable if expired w/in past 4 days:
  1. .I $$FMDIFF^XLFDT(ORNOW,EXDT,1)<4 S ORSLT=1
  1. Q ORSLT
  1. ;
  1. IVRENEW(EXORN) ;extr function returns 1 if med is renewable, 0 if not
  1. N ORSLT,ORSTATUS
  1. S ORSLT=0
  1. S ORSTATUS=$P($$STATUS^ORQOR2(EXORN),U,2)
  1. I ORSTATUS="ACTIVE" Q 1 ;renewable if "active"
  1. I ORSTATUS="HOLD" Q 1 ;renewable if "on hold"
  1. I ORSTATUS="EXPIRED" Q 1 ;renewable if "expired"
  1. Q ORSLT
  1. ;
  1. EXCLN(ORNOW) ;clean up old entires in ^XTMP("ORB LAST EXPIRE")
  1. N ORN,ORDT
  1. S ORN=1
  1. F S ORN=$O(^XTMP("ORB LAST EXPIRE",ORN)) Q:ORN="" D
  1. .S ORDT=$G(^XTMP("ORB LAST EXPIRE",ORN))
  1. .I $L(ORDT),(ORDT<ORNOW) D
  1. ..K ^XTMP("ORB LAST EXPIRE",ORN)
  1. Q