ORB3 ; slc/CLA,WAT - Main routine for OE/RR 3 notifications ;23-Nov-2011 11:43;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,74,91,105,139,190,1002,1004,220,253,265,296,1010**;Dec 17, 1997;Build 47
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;This routine invokes to following ICR(s):
;ICR 4156 ;REGISTRATION, COMBAT VETERAN STATUS
;Modified - IHS/CIA/MGH - 5/14/2010 - Line TITLE+15, IHSPRIM, IHSTEAM and IHSDP
EN(ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA) ;
;
N ORBENT
S ORBENT=$$ENTITY^ORB31(ORNUM)
;
Q:$$GET^XPAR(ORBENT,"ORB SYSTEM ENABLE/DISABLE",1,"I")="D"
Q:'$L($G(^ORD(100.9,ORN,0)))
Q:+$$ONOFF^ORB3FN(ORN)=0
;
S ORBPMSG=$E($G(ORBPMSG),1,51)
;
;if msg from notif file or oc notif (#54), quit if dup w/in past 1 min:
N ORBDUP,ORBN
S ORBN=^ORD(100.9,ORN,0)
I ($P(ORBN,"^",4)="NOT")!(ORN=54) D
.S ORBDUP=$$DUP^ORB31(ORN,ORBDFN,ORBPMSG,ORNUM)
Q:+$G(ORBDUP)=1
;
N ORBDESC
S ORBDESC=" Send Alert Notification ("_(+ORN)_") "_$P($G(^ORD(100.9,+ORN,0)),U,1)_" "
;
D QUEUE^ORB31(ORN,ORBDFN,$G(ORNUM),.ORBADUZ,$G(ORBPMSG),$G(ORBPDATA),$H,ORBDESC,$G(DGPMA))
Q
ZTSK ;
D START
S ZTREQ="@"
Q
UTL(ORBU,ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA) ;
Q:$G(ORBU)'=1
START Q:$G(ORN)=""!($G(ORBDFN)="")
Q:'$L($G(^ORD(100.9,ORN,0)))
N ORBNOW,ORBID,ORBLOCK,ORBDESC
S ORBNOW=$$NOW^XLFDT
S ORBLOCK=0
;
;lock to prevent concurrent processing by other resource slots:
I '$D(ORBU) D
.S ^XTMP("ORBLOCK",0)=$$FMADD^XLFDT(ORBNOW,1,"","","")_"^"_ORBNOW
.S ORBID=$P($P($G(ORBPDATA),"|",2),"@") ;get unique data id
.I $L(ORBID) D
..LOCK +^XTMP("ORBLOCK",ORBDFN,ORN,ORBID):60 E D Q
...S ORBDESC=" Requeue Alert Notification ("_(+ORN)_") "_$P($G(^ORD(100.9,+ORN,0)),U,1)_" "
...D QUEUE^ORB31(ORN,ORBDFN,$G(ORNUM),.ORBADUZ,$G(ORBPMSG),$G(ORBPDATA),$$HADD^XLFDT($H,"","",5,""),ORBDESC,$G(DGPMA)) ;requeue in 5 min.
...S ORBLOCK=1
.;
.I '$L(ORBID) D
..LOCK +^XTMP("ORBLOCK",ORBDFN,ORN):60 E D Q
...S ORBDESC=" Requeue Alert Notification ("_(+ORN)_") "_$P($G(^ORD(100.9,+ORN,0)),U,1)_" "
...D QUEUE^ORB31(ORN,ORBDFN,$G(ORNUM),.ORBADUZ,$G(ORBPMSG),$G(ORBPDATA),$$HADD^XLFDT($H,"","",5,""),ORBDESC,$G(DGPMA)) ;requeue in 5 min.
...S ORBLOCK=1
.;
I ORBLOCK=1 D QUIT Q
;
DOALERT ; Entry point for alert logic outside of TaskMan
N ORBDUZ,ORBN,ORBXQAID,ORPTNAM,ORBPRIM,ORBATTD,ORBDEV,ORBENT
N ORBUI,ORBASPEC,ORBSMSG,ORBADT,ORBSDEV,ORBDEL,ORBDI,ORBTDEV,ORY
S ORBUI=1,ORBADT=0
S:'$L($G(ORBPMSG)) ORBPMSG=""
I '$L(ORBPDATA),(+$G(ORNUM)>0) S ORBPDATA=+$G(ORNUM)_"@"
S ORBN=^ORD(100.9,ORN,0)
;
S ORBENT=$$ENTITY^ORB31(ORNUM)
;
N DFN S DFN=ORBDFN,VA200="" D OERR^VADPT
I ('$L($G(VA("BID"))))!('$L($G(VADM(1)))) D QUIT Q
I (ORN=18)!(ORN=20)!(ORN=35) S ORBADT=1 ;A/D/T notif
;if not an A/D/T notif, get primary & attending from OERR^VADPT:
I ORBADT=0 S ORBPRIM=+$P(VAIN(2),U),ORBATTD=+$P(VAIN(11),U)
I ORBADT=1 D ADT^ORB31(ORN,ORBDFN,.ORBPRIM,.ORBATTD,$G(ORDGPMA)) ;A/D/T notif
I $D(ORBU) D ;create debug msg
.S ORBU(ORBUI)="Processing notification: "_$P(ORBN,U),ORBUI=ORBUI+1
.S ORBU(ORBUI)=" for patient: "_VADM(1),ORBUI=ORBUI+1
.I $G(ORNUM)>0 S ORBU(ORBUI)=" for order: "_ORNUM,ORBUI=ORBUI+1
D REGULAR^ORB3REG(ORN,.XQA,.ORBU,.ORBUI,.ORBDEV,ORBDFN)
D SPECIAL^ORB3SPEC(ORN,.ORBASPEC,.ORBU,.ORBUI,$G(ORNUM),ORBDFN,$G(ORBPDATA),.ORBSMSG,$G(ORBPMSG),.ORBSDEV,$G(ORBPRIM),$G(ORBATTD))
I $L($G(ORBSMSG)) S ORBPMSG=$E(ORBSMSG,1,51)
I $D(ORBASPEC)>1 D SPECDUZS ;special recips
I $D(ORBADUZ)>1 D PKGDUZS ;pkg-supplied recips
D TITLE ;provider recips
S ORBXQAID=$P(ORBN,"^",2)_","_ORBDFN_","_ORN
;
I ($D(XQA)>1)!($D(ORBDEV)>1)!($D(ORBSDEV)>1) D ;recips found
.S XQAFLG=$P(ORBN,"^",5)
.S XQADFN=ORBDFN
.I XQAFLG="R" S XQAROU=$P(ORBN,"^",6)_"^"_$P(ORBN,"^",7)
.I $G(ORBPDATA)'="" S XQADATA=ORBPDATA
.S ORPTNAM=$E(VADM(1)_" ",1,9)
.I $G(ORN)=27 N CVMRKR,RSLT S RSLT=$$CVEDT^DGCV(DFN) I $P($G(RSLT),U)&($P($G(RSLT),U,3)) S CVMRKR=" CV "_$$FMTE^XLFDT($P($G(RSLT),U,2),"5DZ") ;WAT
.S XQAMSG=ORPTNAM_" "_"("_$E(ORPTNAM)_$E(VA("BID"),1,4)_")"_$G(CVMRKR)_": " ;WAT
.S XQAMSG=XQAMSG_$S(ORBPMSG'="":ORBPMSG,1:$P(ORBN,"^",3))
.S XQAARCH=$$GET^XPAR(ORBENT,"ORB ARCHIVE PERIOD",ORN,"I")
.S XQASUPV=$$GET^XPAR(ORBENT,"ORB FORWARD SUPERVISOR",ORN,"I")
.S XQASURO=$$GET^XPAR(ORBENT,"ORB FORWARD SURROGATES",ORN,"I")
.S XQAREVUE=$$GET^XPAR(ORBENT,"ORB FORWARD BACKUP REVIEWER",ORN,"I")
.S XQACNDEL=$$GET^XPAR(ORBENT,"ORB REMOVE",ORN,"I")
.S XQACNDEL=$S(XQACNDEL=1:1,1:"")
.I $D(ORBDEV)>1 D REGDEV^ORB31(.ORBDEV)
.I $D(ORBSDEV)>1 D REGDEV^ORB31(.ORBSDEV)
.I $D(ORBTDEV)>1 D REGDEV^ORB31(.ORBTDEV)
.S XQAID=ORBXQAID
.I $D(XQA) D SETUP^XQALERT ;if no [new] recips don't send alert
QUIT ;
K VA,VA200,VADM,VAERR,VAIN,XQA,XQADATA,XQAID,XQAFLG,XQAMSG,XQAROU,XQAARCH,XQASUPV,XQASURO,XQADFN
K ^XTMP("ORBUSER",$J)
I '$D(ORBU),$D(ORBLOCK) D
.I $G(ORBID)]"" LOCK -^XTMP("ORBLOCK",ORBDFN,ORN,ORBID)
.E LOCK -^XTMP("ORBLOCK",ORBDFN,ORN)
Q
PKGDUZS ;get DUZs from pkg-passed ORBADUZ() array
N ORBPDUZ
I $D(ORBU) D
.S ORBU(ORBUI)=" ",ORBUI=ORBUI+1
.I ORN=68 S ORBU(ORBUI)="Recipients with Lab Threshold Exceeded:",ORBUI=ORBUI+1
.E S ORBU(ORBUI)="Recipients defined when notif was triggered:",ORBUI=ORBUI+1
S ORBPDUZ=""
F S ORBPDUZ=$O(ORBADUZ(ORBPDUZ)) Q:ORBPDUZ="" S ORBDUZ=ORBPDUZ D USER
Q
SPECDUZS ;get DUZs rtn by SPECIAL^ORB3SPEC
N ORBSDUZ
I $D(ORBU) D
.S ORBU(ORBUI)=" ",ORBUI=ORBUI+1
.S ORBU(ORBUI)="Special recipients associated with the notification:",ORBUI=ORBUI+1
S ORBSDUZ=""
F S ORBSDUZ=$O(ORBASPEC(ORBSDUZ)) Q:ORBSDUZ="" S ORBDUZ=ORBSDUZ D USER
Q
TITLE ;get provider recips
N TITLES
I $D(ORBU) D
.S ORBU(ORBUI)=" ",ORBUI=ORBUI+1
.S ORBU(ORBUI)="Recipients determined by Provider Recipient parameter:",ORBUI=ORBUI+1
;
S TITLES=$$GET^XPAR(ORBENT,"ORB PROVIDER RECIPIENTS",ORN,"I")
I TITLES["P" D PRIMARY
I TITLES["A" D ATTEND
I TITLES["T" D TEAMS
I TITLES["O" D ORDERER
I TITLES["E" D ENTERBY
I TITLES["R" D PCMMPRIM
I TITLES["S" D PCMMASSC
I TITLES["M" D PCMMTEAM
;IHS/CIA/MGH Next 3 choices were for provider recipients
I TITLES["D" D IHSPRIM
I TITLES["I" D IHSTEAM
I TITLES["G" D IHSDP
Q
PRIMARY ;
I $D(ORBU),ORBADT=0 S ORBU(ORBUI)=" Inpt primary provider:",ORBUI=ORBUI+1
I $D(ORBU),ORBADT=1 S ORBU(ORBUI)=" Inpt primary provider: option cannot determine without A/D/T event data.",ORBUI=ORBUI+1
I +$G(ORBPRIM)>0 S ORBDUZ=ORBPRIM D USER
Q
ATTEND ;
I $D(ORBU),ORBADT=0 S ORBU(ORBUI)=" Attending physician:",ORBUI=ORBUI+1
I $D(ORBU),ORBADT=1 S ORBU(ORBUI)=" Attending physician: option cannot determine without A/D/T event data.",ORBUI=ORBUI+1
I +$G(ORBATTD)>0 S ORBDUZ=ORBATTD D USER
Q
TEAMS ;
I $D(ORBU) S ORBU(ORBUI)=" Teams/Personal Lists related to patient:",ORBUI=ORBUI+1
N ORBLST,ORBI,ORBJ,ORBTM,ORBTNAME,ORBTTYPE,ORBTD
D TMSPT^ORQPTQ1(.ORBLST,ORBDFN)
Q:+$G(ORBLST(1))<1
S ORBI="" F S ORBI=$O(ORBLST(ORBI)) Q:ORBI="" D
.S ORBTM=$P(ORBLST(ORBI),U),ORBTNAME=$P(ORBLST(ORBI),U,2)
.S ORBTTYPE=$P(ORBLST(ORBI),U,3)
.I $D(ORBU) D
..S ORBU(ORBUI)=" Patient list "_ORBTNAME_" ["_ORBTTYPE_"]:",ORBUI=ORBUI+1
.N ORBLST2 D TEAMPROV^ORQPTQ1(.ORBLST2,ORBTM)
.Q:+$G(ORBLST2(1))<1
.S ORBJ="" F S ORBJ=$O(ORBLST2(ORBJ)) Q:ORBJ="" D
..S ORBDUZ=$P(ORBLST2(ORBJ),U)_U_ORBTM I +$G(ORBDUZ)>0 D USER
.;
.S ORBTD=$P($$TMDEV^ORB31(ORBTM),U,2) ;Team's device
.I $L(ORBTD) D
..S ORBTDEV(ORBTD)=""
..I $D(ORBU) D
...S ORBU(ORBUI)=" Team's Device "_ORBTD_" is a recipient",ORBUI=ORBUI+1
Q
ORDERER ;
Q:+$G(ORNUM)<1
I $D(ORBU) S ORBU(ORBUI)=" Ordering provider:",ORBUI=ORBUI+1
N ORBLST,ORBI,ORBTM,ORBJ,ORBTNAME,ORBPLST,ORBPI,ORBPTM,ORBTTYPE
S ORBDUZ=$S(ORN=12:+$$UNSIGNOR^ORQOR2(ORNUM),1:$$ORDERER^ORQOR2(ORNUM))
I +$G(ORBDUZ)>0 D
.D USER
.;if notif = Order Req E/S (#12) or Order Req Co-sign (#37) and
.;user doesn't have ES authority, send to fellow team members w/ES:
.I ((ORN=12)!(ORN=37)),('$D(^XUSEC("ORES",ORBDUZ))) D
..I $D(ORBU) S ORBU(ORBUI)=" Orderer can't elec sign, getting teams orderer belongs to:",ORBUI=ORBUI+1
..D TEAMPR^ORQPTQ1(.ORBLST,ORBDUZ) ;get orderer's tms
..Q:+$G(ORBLST(1))<1
..D TMSPT^ORQPTQ1(.ORBPLST,ORBDFN) ;get pt's tms
..Q:+$G(ORBPLST(1))<1
..S ORBI="" F S ORBI=$O(ORBLST(ORBI)) Q:ORBI="" D
...S ORBPI="" F S ORBPI=$O(ORBPLST(ORBPI)) Q:ORBPI="" D
....S ORBTM=$P(ORBLST(ORBI),U),ORBPTM=$P(ORBPLST(ORBPI),U)
....I ORBTM=ORBPTM D ;if pt is on provider's team
.....I +$G(ORBPTM)>0 D
......S ORBTNAME=$P(ORBPLST(ORBPI),U,2)
......S ORBTTYPE=$P(ORBPLST(ORBPI),U,3)
......I $D(ORBU) S ORBU(ORBUI)=" Orderer's pt list "_ORBTNAME_" ["_ORBTTYPE_"] recipients: ",ORBUI=ORBUI+1
......N ORBLST2 D TEAMPROV^ORQPTQ1(.ORBLST2,ORBPTM)
......Q:+$G(ORBLST2(1))<1
......S ORBJ="" F S ORBJ=$O(ORBLST2(ORBJ)) Q:ORBJ="" D
.......S ORBDUZ=$P(ORBLST2(ORBJ),U)_U_ORBPTM I +$G(ORBDUZ)>0,($D(^XUSEC("ORES",+ORBDUZ))) D USER
Q
ENTERBY ;
I $D(ORBU) S ORBU(ORBUI)=" User entering order's most recent activity:",ORBUI=ORBUI+1
Q:+$G(ORNUM)<1
I $D(^OR(100,ORNUM,8,0)) D
.S ORBDUZ=$P(^OR(100,ORNUM,8,$P(^OR(100,ORNUM,8,0),U,3),0),U,13)
I +$G(ORBDUZ)>0 D USER
Q
PCMMPRIM ;
I $D(ORBU) S ORBU(ORBUI)=" PCMM Primary Care Practitioner:",ORBUI=ORBUI+1
S ORBDUZ=+$$OUTPTPR^SDUTL3(ORBDFN,$$NOW^XLFDT,1) ;DBIA #1252
I +$G(ORBDUZ)>0 D USER
Q
PCMMASSC ;
I $D(ORBU) S ORBU(ORBUI)=" PCMM Associate Provider:",ORBUI=ORBUI+1
S ORBDUZ=+$$OUTPTAP^SDUTL3(ORBDFN,$$NOW^XLFDT) ;DBIA #1252
I +$G(ORBDUZ)>0 D USER
Q
PCMMTEAM ;
N ORPCMM,ORPCMMDZ
I $D(ORBU) S ORBU(ORBUI)=" PCMM Team Position Assignments:",ORBUI=ORBUI+1
S ORPCMM=$$PRPT^SCAPMC(ORBDFN,,,,,,"^TMP(""ORPCMM"",$J)",) ;DBIA #1916
S ORPCMMDZ=0
F S ORPCMMDZ=$O(^TMP("ORPCMM",$J,"SCPR",ORPCMMDZ)) Q:'ORPCMMDZ D
.S ORBDUZ=ORPCMMDZ D USER
K ^TMP("ORPCMM",$J)
Q
;IHS/CIA/MGH
IHSPRIM ;Send alert to designated provider
I $D(ORBU) S ORBU(ORBUI)=" IHS Primary Care Provider:",ORBUI=ORBUI+1
S ORBDUZ=$$GET1^DIQ(9000001,ORBDFN,.14,"I") ;pcp ien
I +$G(ORBDUZ)>0 D USER
Q
IHSTEAM ;IHS/CIA/MGH
;Send alert to primary team
N ORIHS,ORIHDUZ
I $D(ORBU) S ORBU(ORBUI)=" IHS Primary Care Team:",ORBUI=ORBUI+1
S ORBDUZ=$$GET1^DIQ(9000001,ORBDFN,.14,"I")
I +$G(ORBDUZ)>0 D TEAM^BEHOPTPC(ORBDUZ)
S ORIHDUZ=""
F S ORIHDUZ=$O(^TMP("ORIHS",$J,ORIHDUZ)) Q:ORIHDUZ="" D
.S ORBDUZ=ORIHDUZ D USER
K ^TMP("ORIHS",$J)
Q
;IHS/CIA/MGH - Send alert to all designated providers
IHSDP N I,X,BDPQ,BEHOTYPE,BEHOCT,BEHOPR,BDPCPRV,BEHORIEN
Q:'$D(^BDPRECN("AA",ORBDFN))
I $D(ORBU) S ORBU(ORBUI)=" IHS Designated Providers:",ORBUI=ORBUI+1
S I=0,BDPQ=0,BEHOTYPE="",BEHOCT=0
F S BEHOTYPE=$O(^BDPRECN("AA",ORBDFN,BEHOTYPE)) Q:BEHOTYPE="" D
.S BEHOPR=0
.F S BEHOPR=$O(^BDPRECN("AA",ORBDFN,BEHOTYPE,BEHOPR)) Q:BEHOPR="" D
..S ORBDUZ=$P($G(^BDPRECN(BEHOPR,0)),U,3) ;Current Provider IEN
..D USER
Q
USER ;should USER (ORBDUZ) be a recip
D USER^ORB3USER(.XQA,ORBDUZ,ORN,.ORBU,.ORBUI,ORBDFN,+$G(ORNUM))
Q
ORB3 ; slc/CLA,WAT - Main routine for OE/RR 3 notifications ;23-Nov-2011 11:43;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,74,91,105,139,190,1002,1004,220,253,265,296,1010**;Dec 17, 1997;Build 47
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;This routine invokes to following ICR(s):
+5 ;ICR 4156 ;REGISTRATION, COMBAT VETERAN STATUS
+6 ;Modified - IHS/CIA/MGH - 5/14/2010 - Line TITLE+15, IHSPRIM, IHSTEAM and IHSDP
EN(ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA) ;
+1 ;
+2 NEW ORBENT
+3 SET ORBENT=$$ENTITY^ORB31(ORNUM)
+4 ;
+5 IF $$GET^XPAR(ORBENT,"ORB SYSTEM ENABLE/DISABLE",1,"I")="D"
QUIT
+6 IF '$LENGTH($GET(^ORD(100.9,ORN,0)))
QUIT
+7 IF +$$ONOFF^ORB3FN(ORN)=0
QUIT
+8 ;
+9 SET ORBPMSG=$EXTRACT($GET(ORBPMSG),1,51)
+10 ;
+11 ;if msg from notif file or oc notif (#54), quit if dup w/in past 1 min:
+12 NEW ORBDUP,ORBN
+13 SET ORBN=^ORD(100.9,ORN,0)
+14 IF ($PIECE(ORBN,"^",4)="NOT")!(ORN=54)
Begin DoDot:1
+15 SET ORBDUP=$$DUP^ORB31(ORN,ORBDFN,ORBPMSG,ORNUM)
End DoDot:1
+16 IF +$GET(ORBDUP)=1
QUIT
+17 ;
+18 NEW ORBDESC
+19 SET ORBDESC=" Send Alert Notification ("_(+ORN)_") "_$PIECE($GET(^ORD(100.9,+ORN,0)),U,1)_" "
+20 ;
+21 DO QUEUE^ORB31(ORN,ORBDFN,$GET(ORNUM),.ORBADUZ,$GET(ORBPMSG),$GET(ORBPDATA),$HOROLOG,ORBDESC,$GET(DGPMA))
+22 QUIT
ZTSK ;
+1 DO START
+2 SET ZTREQ="@"
+3 QUIT
UTL(ORBU,ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA) ;
+1 IF $GET(ORBU)'=1
QUIT
START IF $GET(ORN)=""!($GET(ORBDFN)="")
QUIT
+1 IF '$LENGTH($GET(^ORD(100.9,ORN,0)))
QUIT
+2 NEW ORBNOW,ORBID,ORBLOCK,ORBDESC
+3 SET ORBNOW=$$NOW^XLFDT
+4 SET ORBLOCK=0
+5 ;
+6 ;lock to prevent concurrent processing by other resource slots:
+7 IF '$DATA(ORBU)
Begin DoDot:1
+8 SET ^XTMP("ORBLOCK",0)=$$FMADD^XLFDT(ORBNOW,1,"","","")_"^"_ORBNOW
+9 ;get unique data id
SET ORBID=$PIECE($PIECE($GET(ORBPDATA),"|",2),"@")
+10 IF $LENGTH(ORBID)
Begin DoDot:2
+11 LOCK +^XTMP("ORBLOCK",ORBDFN,ORN,ORBID):60
IF '$TEST
Begin DoDot:3
+12 SET ORBDESC=" Requeue Alert Notification ("_(+ORN)_") "_$PIECE($GET(^ORD(100.9,+ORN,0)),U,1)_" "
+13 ;requeue in 5 min.
DO QUEUE^ORB31(ORN,ORBDFN,$GET(ORNUM),.ORBADUZ,$GET(ORBPMSG),$GET(ORBPDATA),$$HADD^XLFDT($HOROLOG,"","",5,""),ORBDESC,$GET(DGPMA))
+14 SET ORBLOCK=1
End DoDot:3
QUIT
End DoDot:2
+15 ;
+16 IF '$LENGTH(ORBID)
Begin DoDot:2
+17 LOCK +^XTMP("ORBLOCK",ORBDFN,ORN):60
IF '$TEST
Begin DoDot:3
+18 SET ORBDESC=" Requeue Alert Notification ("_(+ORN)_") "_$PIECE($GET(^ORD(100.9,+ORN,0)),U,1)_" "
+19 ;requeue in 5 min.
DO QUEUE^ORB31(ORN,ORBDFN,$GET(ORNUM),.ORBADUZ,$GET(ORBPMSG),$GET(ORBPDATA),$$HADD^XLFDT($HOROLOG,"","",5,""),ORBDESC,$GET(DGPMA))
+20 SET ORBLOCK=1
End DoDot:3
QUIT
End DoDot:2
+21 ;
End DoDot:1
+22 IF ORBLOCK=1
DO QUIT
QUIT
+23 ;
DOALERT ; Entry point for alert logic outside of TaskMan
+1 NEW ORBDUZ,ORBN,ORBXQAID,ORPTNAM,ORBPRIM,ORBATTD,ORBDEV,ORBENT
+2 NEW ORBUI,ORBASPEC,ORBSMSG,ORBADT,ORBSDEV,ORBDEL,ORBDI,ORBTDEV,ORY
+3 SET ORBUI=1
SET ORBADT=0
+4 IF '$LENGTH($GET(ORBPMSG))
SET ORBPMSG=""
+5 IF '$LENGTH(ORBPDATA)
IF (+$GET(ORNUM)>0)
SET ORBPDATA=+$GET(ORNUM)_"@"
+6 SET ORBN=^ORD(100.9,ORN,0)
+7 ;
+8 SET ORBENT=$$ENTITY^ORB31(ORNUM)
+9 ;
+10 NEW DFN
SET DFN=ORBDFN
SET VA200=""
DO OERR^VADPT
+11 IF ('$LENGTH($GET(VA("BID"))))!('$LENGTH($GET(VADM(1))))
DO QUIT
QUIT
+12 ;A/D/T notif
IF (ORN=18)!(ORN=20)!(ORN=35)
SET ORBADT=1
+13 ;if not an A/D/T notif, get primary & attending from OERR^VADPT:
+14 IF ORBADT=0
SET ORBPRIM=+$PIECE(VAIN(2),U)
SET ORBATTD=+$PIECE(VAIN(11),U)
+15 ;A/D/T notif
IF ORBADT=1
DO ADT^ORB31(ORN,ORBDFN,.ORBPRIM,.ORBATTD,$GET(ORDGPMA))
+16 ;create debug msg
IF $DATA(ORBU)
Begin DoDot:1
+17 SET ORBU(ORBUI)="Processing notification: "_$PIECE(ORBN,U)
SET ORBUI=ORBUI+1
+18 SET ORBU(ORBUI)=" for patient: "_VADM(1)
SET ORBUI=ORBUI+1
+19 IF $GET(ORNUM)>0
SET ORBU(ORBUI)=" for order: "_ORNUM
SET ORBUI=ORBUI+1
End DoDot:1
+20 DO REGULAR^ORB3REG(ORN,.XQA,.ORBU,.ORBUI,.ORBDEV,ORBDFN)
+21 DO SPECIAL^ORB3SPEC(ORN,.ORBASPEC,.ORBU,.ORBUI,$GET(ORNUM),ORBDFN,$GET(ORBPDATA),.ORBSMSG,$GET(ORBPMSG),.ORBSDEV,$GET(ORBPRIM),$GET(ORBATTD))
+22 IF $LENGTH($GET(ORBSMSG))
SET ORBPMSG=$EXTRACT(ORBSMSG,1,51)
+23 ;special recips
IF $DATA(ORBASPEC)>1
DO SPECDUZS
+24 ;pkg-supplied recips
IF $DATA(ORBADUZ)>1
DO PKGDUZS
+25 ;provider recips
DO TITLE
+26 SET ORBXQAID=$PIECE(ORBN,"^",2)_","_ORBDFN_","_ORN
+27 ;
+28 ;recips found
IF ($DATA(XQA)>1)!($DATA(ORBDEV)>1)!($DATA(ORBSDEV)>1)
Begin DoDot:1
+29 SET XQAFLG=$PIECE(ORBN,"^",5)
+30 SET XQADFN=ORBDFN
+31 IF XQAFLG="R"
SET XQAROU=$PIECE(ORBN,"^",6)_"^"_$PIECE(ORBN,"^",7)
+32 IF $GET(ORBPDATA)'=""
SET XQADATA=ORBPDATA
+33 SET ORPTNAM=$EXTRACT(VADM(1)_" ",1,9)
+34 ;WAT
IF $GET(ORN)=27
NEW CVMRKR,RSLT
SET RSLT=$$CVEDT^DGCV(DFN)
IF $PIECE($GET(RSLT),U)&($PIECE($GET(RSLT),U,3))
SET CVMRKR=" CV "_$$FMTE^XLFDT($PIECE($GET(RSLT),U,2),"5DZ")
+35 ;WAT
SET XQAMSG=ORPTNAM_" "_"("_$EXTRACT(ORPTNAM)_$EXTRACT(VA("BID"),1,4)_")"_$GET(CVMRKR)_": "
+36 SET XQAMSG=XQAMSG_$SELECT(ORBPMSG'="":ORBPMSG,1:$PIECE(ORBN,"^",3))
+37 SET XQAARCH=$$GET^XPAR(ORBENT,"ORB ARCHIVE PERIOD",ORN,"I")
+38 SET XQASUPV=$$GET^XPAR(ORBENT,"ORB FORWARD SUPERVISOR",ORN,"I")
+39 SET XQASURO=$$GET^XPAR(ORBENT,"ORB FORWARD SURROGATES",ORN,"I")
+40 SET XQAREVUE=$$GET^XPAR(ORBENT,"ORB FORWARD BACKUP REVIEWER",ORN,"I")
+41 SET XQACNDEL=$$GET^XPAR(ORBENT,"ORB REMOVE",ORN,"I")
+42 SET XQACNDEL=$SELECT(XQACNDEL=1:1,1:"")
+43 IF $DATA(ORBDEV)>1
DO REGDEV^ORB31(.ORBDEV)
+44 IF $DATA(ORBSDEV)>1
DO REGDEV^ORB31(.ORBSDEV)
+45 IF $DATA(ORBTDEV)>1
DO REGDEV^ORB31(.ORBTDEV)
+46 SET XQAID=ORBXQAID
+47 ;if no [new] recips don't send alert
IF $DATA(XQA)
DO SETUP^XQALERT
End DoDot:1
QUIT ;
+1 KILL VA,VA200,VADM,VAERR,VAIN,XQA,XQADATA,XQAID,XQAFLG,XQAMSG,XQAROU,XQAARCH,XQASUPV,XQASURO,XQADFN
+2 KILL ^XTMP("ORBUSER",$JOB)
+3 IF '$DATA(ORBU)
IF $DATA(ORBLOCK)
Begin DoDot:1
+4 IF $GET(ORBID)]""
LOCK -^XTMP("ORBLOCK",ORBDFN,ORN,ORBID)
+5 IF '$TEST
LOCK -^XTMP("ORBLOCK",ORBDFN,ORN)
End DoDot:1
+6 QUIT
PKGDUZS ;get DUZs from pkg-passed ORBADUZ() array
+1 NEW ORBPDUZ
+2 IF $DATA(ORBU)
Begin DoDot:1
+3 SET ORBU(ORBUI)=" "
SET ORBUI=ORBUI+1
+4 IF ORN=68
SET ORBU(ORBUI)="Recipients with Lab Threshold Exceeded:"
SET ORBUI=ORBUI+1
+5 IF '$TEST
SET ORBU(ORBUI)="Recipients defined when notif was triggered:"
SET ORBUI=ORBUI+1
End DoDot:1
+6 SET ORBPDUZ=""
+7 FOR
SET ORBPDUZ=$ORDER(ORBADUZ(ORBPDUZ))
IF ORBPDUZ=""
QUIT
SET ORBDUZ=ORBPDUZ
DO USER
+8 QUIT
SPECDUZS ;get DUZs rtn by SPECIAL^ORB3SPEC
+1 NEW ORBSDUZ
+2 IF $DATA(ORBU)
Begin DoDot:1
+3 SET ORBU(ORBUI)=" "
SET ORBUI=ORBUI+1
+4 SET ORBU(ORBUI)="Special recipients associated with the notification:"
SET ORBUI=ORBUI+1
End DoDot:1
+5 SET ORBSDUZ=""
+6 FOR
SET ORBSDUZ=$ORDER(ORBASPEC(ORBSDUZ))
IF ORBSDUZ=""
QUIT
SET ORBDUZ=ORBSDUZ
DO USER
+7 QUIT
TITLE ;get provider recips
+1 NEW TITLES
+2 IF $DATA(ORBU)
Begin DoDot:1
+3 SET ORBU(ORBUI)=" "
SET ORBUI=ORBUI+1
+4 SET ORBU(ORBUI)="Recipients determined by Provider Recipient parameter:"
SET ORBUI=ORBUI+1
End DoDot:1
+5 ;
+6 SET TITLES=$$GET^XPAR(ORBENT,"ORB PROVIDER RECIPIENTS",ORN,"I")
+7 IF TITLES["P"
DO PRIMARY
+8 IF TITLES["A"
DO ATTEND
+9 IF TITLES["T"
DO TEAMS
+10 IF TITLES["O"
DO ORDERER
+11 IF TITLES["E"
DO ENTERBY
+12 IF TITLES["R"
DO PCMMPRIM
+13 IF TITLES["S"
DO PCMMASSC
+14 IF TITLES["M"
DO PCMMTEAM
+15 ;IHS/CIA/MGH Next 3 choices were for provider recipients
+16 IF TITLES["D"
DO IHSPRIM
+17 IF TITLES["I"
DO IHSTEAM
+18 IF TITLES["G"
DO IHSDP
+19 QUIT
PRIMARY ;
+1 IF $DATA(ORBU)
IF ORBADT=0
SET ORBU(ORBUI)=" Inpt primary provider:"
SET ORBUI=ORBUI+1
+2 IF $DATA(ORBU)
IF ORBADT=1
SET ORBU(ORBUI)=" Inpt primary provider: option cannot determine without A/D/T event data."
SET ORBUI=ORBUI+1
+3 IF +$GET(ORBPRIM)>0
SET ORBDUZ=ORBPRIM
DO USER
+4 QUIT
ATTEND ;
+1 IF $DATA(ORBU)
IF ORBADT=0
SET ORBU(ORBUI)=" Attending physician:"
SET ORBUI=ORBUI+1
+2 IF $DATA(ORBU)
IF ORBADT=1
SET ORBU(ORBUI)=" Attending physician: option cannot determine without A/D/T event data."
SET ORBUI=ORBUI+1
+3 IF +$GET(ORBATTD)>0
SET ORBDUZ=ORBATTD
DO USER
+4 QUIT
TEAMS ;
+1 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Teams/Personal Lists related to patient:"
SET ORBUI=ORBUI+1
+2 NEW ORBLST,ORBI,ORBJ,ORBTM,ORBTNAME,ORBTTYPE,ORBTD
+3 DO TMSPT^ORQPTQ1(.ORBLST,ORBDFN)
+4 IF +$GET(ORBLST(1))<1
QUIT
+5 SET ORBI=""
FOR
SET ORBI=$ORDER(ORBLST(ORBI))
IF ORBI=""
QUIT
Begin DoDot:1
+6 SET ORBTM=$PIECE(ORBLST(ORBI),U)
SET ORBTNAME=$PIECE(ORBLST(ORBI),U,2)
+7 SET ORBTTYPE=$PIECE(ORBLST(ORBI),U,3)
+8 IF $DATA(ORBU)
Begin DoDot:2
+9 SET ORBU(ORBUI)=" Patient list "_ORBTNAME_" ["_ORBTTYPE_"]:"
SET ORBUI=ORBUI+1
End DoDot:2
+10 NEW ORBLST2
DO TEAMPROV^ORQPTQ1(.ORBLST2,ORBTM)
+11 IF +$GET(ORBLST2(1))<1
QUIT
+12 SET ORBJ=""
FOR
SET ORBJ=$ORDER(ORBLST2(ORBJ))
IF ORBJ=""
QUIT
Begin DoDot:2
+13 SET ORBDUZ=$PIECE(ORBLST2(ORBJ),U)_U_ORBTM
IF +$GET(ORBDUZ)>0
DO USER
End DoDot:2
+14 ;
+15 ;Team's device
SET ORBTD=$PIECE($$TMDEV^ORB31(ORBTM),U,2)
+16 IF $LENGTH(ORBTD)
Begin DoDot:2
+17 SET ORBTDEV(ORBTD)=""
+18 IF $DATA(ORBU)
Begin DoDot:3
+19 SET ORBU(ORBUI)=" Team's Device "_ORBTD_" is a recipient"
SET ORBUI=ORBUI+1
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
ORDERER ;
+1 IF +$GET(ORNUM)<1
QUIT
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Ordering provider:"
SET ORBUI=ORBUI+1
+3 NEW ORBLST,ORBI,ORBTM,ORBJ,ORBTNAME,ORBPLST,ORBPI,ORBPTM,ORBTTYPE
+4 SET ORBDUZ=$SELECT(ORN=12:+$$UNSIGNOR^ORQOR2(ORNUM),1:$$ORDERER^ORQOR2(ORNUM))
+5 IF +$GET(ORBDUZ)>0
Begin DoDot:1
+6 DO USER
+7 ;if notif = Order Req E/S (#12) or Order Req Co-sign (#37) and
+8 ;user doesn't have ES authority, send to fellow team members w/ES:
+9 IF ((ORN=12)!(ORN=37))
IF ('$DATA(^XUSEC("ORES",ORBDUZ)))
Begin DoDot:2
+10 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Orderer can't elec sign, getting teams orderer belongs to:"
SET ORBUI=ORBUI+1
+11 ;get orderer's tms
DO TEAMPR^ORQPTQ1(.ORBLST,ORBDUZ)
+12 IF +$GET(ORBLST(1))<1
QUIT
+13 ;get pt's tms
DO TMSPT^ORQPTQ1(.ORBPLST,ORBDFN)
+14 IF +$GET(ORBPLST(1))<1
QUIT
+15 SET ORBI=""
FOR
SET ORBI=$ORDER(ORBLST(ORBI))
IF ORBI=""
QUIT
Begin DoDot:3
+16 SET ORBPI=""
FOR
SET ORBPI=$ORDER(ORBPLST(ORBPI))
IF ORBPI=""
QUIT
Begin DoDot:4
+17 SET ORBTM=$PIECE(ORBLST(ORBI),U)
SET ORBPTM=$PIECE(ORBPLST(ORBPI),U)
+18 ;if pt is on provider's team
IF ORBTM=ORBPTM
Begin DoDot:5
+19 IF +$GET(ORBPTM)>0
Begin DoDot:6
+20 SET ORBTNAME=$PIECE(ORBPLST(ORBPI),U,2)
+21 SET ORBTTYPE=$PIECE(ORBPLST(ORBPI),U,3)
+22 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Orderer's pt list "_ORBTNAME_" ["_ORBTTYPE_"] recipients: "
SET ORBUI=ORBUI+1
+23 NEW ORBLST2
DO TEAMPROV^ORQPTQ1(.ORBLST2,ORBPTM)
+24 IF +$GET(ORBLST2(1))<1
QUIT
+25 SET ORBJ=""
FOR
SET ORBJ=$ORDER(ORBLST2(ORBJ))
IF ORBJ=""
QUIT
Begin DoDot:7
+26 SET ORBDUZ=$PIECE(ORBLST2(ORBJ),U)_U_ORBPTM
IF +$GET(ORBDUZ)>0
IF ($DATA(^XUSEC("ORES",+ORBDUZ)))
DO USER
End DoDot:7
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
ENTERBY ;
+1 IF $DATA(ORBU)
SET ORBU(ORBUI)=" User entering order's most recent activity:"
SET ORBUI=ORBUI+1
+2 IF +$GET(ORNUM)<1
QUIT
+3 IF $DATA(^OR(100,ORNUM,8,0))
Begin DoDot:1
+4 SET ORBDUZ=$PIECE(^OR(100,ORNUM,8,$PIECE(^OR(100,ORNUM,8,0),U,3),0),U,13)
End DoDot:1
+5 IF +$GET(ORBDUZ)>0
DO USER
+6 QUIT
PCMMPRIM ;
+1 IF $DATA(ORBU)
SET ORBU(ORBUI)=" PCMM Primary Care Practitioner:"
SET ORBUI=ORBUI+1
+2 ;DBIA #1252
SET ORBDUZ=+$$OUTPTPR^SDUTL3(ORBDFN,$$NOW^XLFDT,1)
+3 IF +$GET(ORBDUZ)>0
DO USER
+4 QUIT
PCMMASSC ;
+1 IF $DATA(ORBU)
SET ORBU(ORBUI)=" PCMM Associate Provider:"
SET ORBUI=ORBUI+1
+2 ;DBIA #1252
SET ORBDUZ=+$$OUTPTAP^SDUTL3(ORBDFN,$$NOW^XLFDT)
+3 IF +$GET(ORBDUZ)>0
DO USER
+4 QUIT
PCMMTEAM ;
+1 NEW ORPCMM,ORPCMMDZ
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" PCMM Team Position Assignments:"
SET ORBUI=ORBUI+1
+3 ;DBIA #1916
SET ORPCMM=$$PRPT^SCAPMC(ORBDFN,,,,,,"^TMP(""ORPCMM"",$J)",)
+4 SET ORPCMMDZ=0
+5 FOR
SET ORPCMMDZ=$ORDER(^TMP("ORPCMM",$JOB,"SCPR",ORPCMMDZ))
IF 'ORPCMMDZ
QUIT
Begin DoDot:1
+6 SET ORBDUZ=ORPCMMDZ
DO USER
End DoDot:1
+7 KILL ^TMP("ORPCMM",$JOB)
+8 QUIT
+9 ;IHS/CIA/MGH
IHSPRIM ;Send alert to designated provider
+1 IF $DATA(ORBU)
SET ORBU(ORBUI)=" IHS Primary Care Provider:"
SET ORBUI=ORBUI+1
+2 ;pcp ien
SET ORBDUZ=$$GET1^DIQ(9000001,ORBDFN,.14,"I")
+3 IF +$GET(ORBDUZ)>0
DO USER
+4 QUIT
IHSTEAM ;IHS/CIA/MGH
+1 ;Send alert to primary team
+2 NEW ORIHS,ORIHDUZ
+3 IF $DATA(ORBU)
SET ORBU(ORBUI)=" IHS Primary Care Team:"
SET ORBUI=ORBUI+1
+4 SET ORBDUZ=$$GET1^DIQ(9000001,ORBDFN,.14,"I")
+5 IF +$GET(ORBDUZ)>0
DO TEAM^BEHOPTPC(ORBDUZ)
+6 SET ORIHDUZ=""
+7 FOR
SET ORIHDUZ=$ORDER(^TMP("ORIHS",$JOB,ORIHDUZ))
IF ORIHDUZ=""
QUIT
Begin DoDot:1
+8 SET ORBDUZ=ORIHDUZ
DO USER
End DoDot:1
+9 KILL ^TMP("ORIHS",$JOB)
+10 QUIT
+11 ;IHS/CIA/MGH - Send alert to all designated providers
IHSDP NEW I,X,BDPQ,BEHOTYPE,BEHOCT,BEHOPR,BDPCPRV,BEHORIEN
+1 IF '$DATA(^BDPRECN("AA",ORBDFN))
QUIT
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" IHS Designated Providers:"
SET ORBUI=ORBUI+1
+3 SET I=0
SET BDPQ=0
SET BEHOTYPE=""
SET BEHOCT=0
+4 FOR
SET BEHOTYPE=$ORDER(^BDPRECN("AA",ORBDFN,BEHOTYPE))
IF BEHOTYPE=""
QUIT
Begin DoDot:1
+5 SET BEHOPR=0
+6 FOR
SET BEHOPR=$ORDER(^BDPRECN("AA",ORBDFN,BEHOTYPE,BEHOPR))
IF BEHOPR=""
QUIT
Begin DoDot:2
+7 ;Current Provider IEN
SET ORBDUZ=$PIECE($GET(^BDPRECN(BEHOPR,0)),U,3)
+8 DO USER
End DoDot:2
End DoDot:1
+9 QUIT
USER ;should USER (ORBDUZ) be a recip
+1 DO USER^ORB3USER(.XQA,ORBDUZ,ORN,.ORBU,.ORBUI,ORBDFN,+$GET(ORNUM))
+2 QUIT
