ORB3 ;SLC/CLA,WAT,TC - MAIN ROUTINE FOR OE/RR 3 NOTIFICATIONS ;Nov 18, 2020@09:02:55
;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,74,91,105,139,190,220,253,265,296,348,350,452,377,453**;Dec 17, 1997;Build 47
;;Per VA Directive 6402, this routine should not be modified.
;
;This routine invokes to following ICR(s):
;ICR 4156 ;REGISTRATION, COMBAT VETERAN STATUS
;ICR 5697 ;SCHEDULING, PCMM MHTC API's
;ICR 1252 ;Calls to SDUTL3
;ICR 1916 ;Call to SCAPMC
;ICR 5697 ;Call to SCMCMHTC
EN(ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORFORCE) ;
;
N ORBENT
S ORN=+$G(ORN)
S ORBENT=$$ENTITY^ORB31($G(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
;
;add hook for smart
N ORHOOK S ORHOOK=$$HOOK^ORBSMART(ORN,$G(ORBDFN),$G(ORNUM),.ORBADUZ,$G(ORBPMSG),$G(ORBPDATA))
Q:ORHOOK
;
;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,U,4)="NOT")!(ORN=54) D
.S ORBDUP=$$DUP^ORB31(ORN,$G(ORBDFN),$G(ORBPMSG),$G(ORNUM))
Q:+$G(ORBDUP)=1
;
N ORBDESC
S ORBDESC=" Send Alert Notification ("_(+ORN)_") "_$P($G(^ORD(100.9,+ORN,0)),U,1)_" "
;
N ORQUD S ORQUD=0
I ORN=90 D START S ORQUD=1
I ORQUD=0 D QUEUE^ORB31(ORN,$G(ORBDFN),$G(ORNUM),.ORBADUZ,$G(ORBPMSG),$G(ORBPDATA),$H,ORBDESC,$G(DGPMA),.ORFORCE)
Q
ZTSK ;
D START
S ZTREQ="@"
Q
UTL(ORBU,ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORFORCE) ;
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,"","","")_U_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),.ORFORCE) ;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),.ORFORCE) ;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
N ORBIDX,ORBFLAGS
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 ORBIDX=0 F S ORBIDX=$O(^ORD(100.9,ORN,5,ORBIDX)) Q:'ORBIDX D
.S ORBFLAGS=$P($G(^ORD(100.9,ORN,5,ORBIDX,0)),U)
.S:ORBFLAGS'="" ORBFLAGS(ORBFLAGS)="",ORBFLAGS=""
;
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 $D(ORBASPEC)>1 D SPECDUZS ;special recips
I $D(ORBADUZ)>1 D PKGDUZS ;pkg-supplied recips
D TITLE ;provider recips
S ORBXQAID=$P(ORBN,U,2)_","_ORBDFN_","_ORN
;
I ($D(XQA)>1)!($D(ORBDEV)>1)!($D(ORBSDEV)>1) D ;recips found
.S XQAFLG=$P(ORBN,U,5)
.S XQADFN=ORBDFN
.I XQAFLG="R" S XQAROU=$P(ORBN,U,6)_U_$P(ORBN,U,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,U,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 ORN=90 M XQATEXT=ORBPMSG
.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(ORBFLAGS("ONPP")) D COMDUP
.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,XQACNDEL,XQAREVUE
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["O" D ORDERER
I TITLES["P" D PRIMARY
I TITLES["A" D ATTEND
I TITLES["T" D TEAMS
I TITLES["E" D ENTERBY
I TITLES["R" D PCMMPRIM
I TITLES["S" D PCMMASSC
I TITLES["M" D PCMMTEAM
I TITLES["C" D PCMMMHTC
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
. ; RBD OR*3.0*453 Intercept User (Provider) to receive alert to see if it permanently routes to another User (Provider)
. ; Then check if that User can receive Alerts
. N ORTRDAT,ORTRNUM,ORTRREC,ORTRREC2 I +$G(ORNUM)>0 D
.. S ORTRDAT=$O(^OR(100,ORNUM,11,"B",$$NOW^XLFDT()),-1) I +ORTRDAT>0 D
... S ORTRNUM=$O(^OR(100,ORNUM,11,"B",ORTRDAT,""),-1) I +ORTRNUM>0 D
.... S ORTRREC2=$G(^OR(100,ORNUM,11,ORTRNUM,0)) I ORTRREC2]"" D
..... S:ORTRNUM=1 ORTRREC=ORTRREC2
..... S:ORTRNUM'=1 ORTRREC=$G(^OR(100,ORNUM,11,1,0))
..... I $P(ORTRREC,U,2)=ORBDUZ,$P(ORTRREC2,U,3) K ORBADUZ(ORBDUZ),XQA(ORBDUZ) S ORBDUZ=$P(ORTRREC2,U,3)
.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)
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)
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)",)
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
PCMMMHTC ;
I $D(ORBU) S ORBU(ORBUI)=" PCMM Mental Health Treatment Coordinator:",ORBUI=ORBUI+1
S ORBDUZ=+$$START^SCMCMHTC(ORBDFN)
I +$G(ORBDUZ)>0 D USER
Q
USER ;should USER (ORBDUZ) be a recip
;I '$$PATCH^XPDUTL("OR*3.0*498") D USER^ORB3USER(.XQA,ORBDUZ,ORN,.ORBU,.ORBUI,ORBDFN,+$G(ORNUM))
;I $$PATCH^XPDUTL("OR*3.0*498") D USER^ORB3USER(.XQA,ORBDUZ,ORN,.ORBU,.ORBUI,ORBDFN,+$G(ORNUM),$G(ORBADUZ(ORBDUZ)))
D USER^ORB3USER(.XQA,ORBDUZ,ORN,.ORBU,.ORBUI,ORBDFN,+$G(ORNUM))
I $D(ORFORCE(ORBDUZ)) S XQA(ORBDUZ)=""
Q
COMDUP ; Combine XQADATA from existing alert(s) with new alert, delete existing alert
;and then generate the new alert for the current individual user
N ORVAR,ORDUZ,ORAID,ORODATA
F ORVAR="XQA","XQADATA","XQAID","XQAFLG","XQAMSG","XQAROU","XQAARCH","XQASUPV","XQASURO","XQADFN","XQACNDEL","XQAREVUE","XQAOPT","XQAEXIT","XQAUSER" D
.Q:'$D(@ORVAR)
.I $D(@ORVAR)<10 S ORVAR(ORVAR)=$G(@ORVAR)
.I $D(@ORVAR)>9 M ORVAR(ORVAR)=@ORVAR
.S ORVAR(0,ORVAR)=""
S ORDUZ=0 F S ORDUZ=$O(XQA(ORDUZ)) Q:'+ORDUZ D
.N ORDATA,ORGEN
.K ^TMP($J,"ORB3DATA")
.D USER^XQALERT($NA(^TMP($J,"ORB3DATA")),ORDUZ)
.S ORAID=0 F S ORAID=$O(^TMP($J,"ORB3DATA",ORAID)) Q:'+ORAID D
..Q:$P($P(^TMP($J,"ORB3DATA",ORAID),U,2),";")'=($P(ORBN,U,2)_","_ORBDFN_","_ORN)
..I $P(ORBN,U,4)="PKG",$P(^TMP($J,"ORB3DATA",ORAID),U)'[ORVAR("XQAMSG") Q
..N XQAID,XQADATA,XQAOPT,XQAROU,XQAUSER,XQAKILL
..N XQADFN,XQAMSG,XQAFLG,XQADFN,XQAARCH,XQASUPV,XQASURO,XQAREVUE,XQACNDEL
..K ^TMP($J,"ORB3ADATA")
..D ALERTDAT^XQALBUTL($P(^TMP($J,"ORB3DATA",ORAID),U,2),$NA(^TMP($J,"ORB3ADATA")))
..S XQADATA=$G(^TMP($J,"ORB3ADATA",2))
..K ^TMP($J,"ORB3ADATA")
..I XQADATA'="" D Q:'$G(ORGEN)
...I $D(ORBFLAGS("CD")) D
....N OROLD,ORNEW,ORSPEC,ORIDX
....S OROLD=U_$S(XQADATA[";":$P(XQADATA,";",2),1:XQADATA)_U,ORNEW=U_$S(ORVAR("XQADATA")[";":$P(ORVAR("XQADATA"),";",2),1:ORVAR("XQADATA"))_U
....S ORSPEC(U)=""
....F ORIDX=2:1:$L(ORNEW,U) I OROLD[(U_$P(ORNEW,U,ORIDX)_U) S $P(ORNEW,U,ORIDX)=""
....S ORNEW=$$REPLACE^XLFSTR(ORNEW,.ORSPEC)
....I ORNEW="" K ORVAR("XQA",ORDUZ) Q
....S ORDATA=$S(XQADATA[";":$P(XQADATA,";",2),1:XQADATA)_$S($G(ORDATA)'="":U_ORDATA,1:"")
....S ORGEN=1
...I '$D(ORBFLAGS("CD")),XQADATA=$G(ORVAR("XQADATA")) S ORGEN=2
..S XQAUSER=ORDUZ,XQAID=$P(^TMP($J,"ORB3DATA",ORAID),U,2),XQAKILL=1
..D DELETE^XQALERT
.Q:$G(ORGEN)'=1
.I $G(XQADATA)'=""!($G(ORDATA)'="") S ORODATA=$G(XQADATA)_$S($G(ORDATA)'="":U_ORDATA,1:"")
.K ORVAR("XQA",ORDUZ)
.D XQRESTOR
.N XQA,XQADATA
.S XQA(ORDUZ)="",XQADATA=ORODATA D SETUP^XQALERT
K ^TMP($J,"ORB3DATA")
D XQRESTOR
Q
XQRESTOR ; Restore XQA* variables saved off in COMDUP
S ORVAR="" F S ORVAR=$O(ORVAR(0,ORVAR)) Q:$G(ORVAR)="" K @ORVAR
S ORVAR="?" F S ORVAR=$O(ORVAR(ORVAR)) Q:$G(ORVAR)="" D
.I $D(ORVAR(ORVAR))<10 S @ORVAR=ORVAR(ORVAR)
.I $D(ORVAR(ORVAR))>9 M @ORVAR=ORVAR(ORVAR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORB3 13863 printed Sep 23, 2025@20:03:32 Page 2
ORB3 ;SLC/CLA,WAT,TC - MAIN ROUTINE FOR OE/RR 3 NOTIFICATIONS ;Nov 18, 2020@09:02:55
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**31,74,91,105,139,190,220,253,265,296,348,350,452,377,453**;Dec 17, 1997;Build 47
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;This routine invokes to following ICR(s):
+5 ;ICR 4156 ;REGISTRATION, COMBAT VETERAN STATUS
+6 ;ICR 5697 ;SCHEDULING, PCMM MHTC API's
+7 ;ICR 1252 ;Calls to SDUTL3
+8 ;ICR 1916 ;Call to SCAPMC
+9 ;ICR 5697 ;Call to SCMCMHTC
EN(ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORFORCE) ;
+1 ;
+2 NEW ORBENT
+3 SET ORN=+$GET(ORN)
+4 SET ORBENT=$$ENTITY^ORB31($GET(ORNUM))
+5 ;
+6 if $$GET^XPAR(ORBENT,"ORB SYSTEM ENABLE/DISABLE",1,"I")="D"
QUIT
+7 if '$LENGTH($GET(^ORD(100.9,ORN,0)))
QUIT
+8 if +$$ONOFF^ORB3FN(ORN)=0
QUIT
+9 ;
+10 ;add hook for smart
+11 NEW ORHOOK
SET ORHOOK=$$HOOK^ORBSMART(ORN,$GET(ORBDFN),$GET(ORNUM),.ORBADUZ,$GET(ORBPMSG),$GET(ORBPDATA))
+12 if ORHOOK
QUIT
+13 ;
+14 ;if msg from notif file or oc notif (#54), quit if dup w/in past 1 min:
+15 NEW ORBDUP,ORBN
+16 SET ORBN=^ORD(100.9,ORN,0)
+17 IF ($PIECE(ORBN,U,4)="NOT")!(ORN=54)
Begin DoDot:1
+18 SET ORBDUP=$$DUP^ORB31(ORN,$GET(ORBDFN),$GET(ORBPMSG),$GET(ORNUM))
End DoDot:1
+19 if +$GET(ORBDUP)=1
QUIT
+20 ;
+21 NEW ORBDESC
+22 SET ORBDESC=" Send Alert Notification ("_(+ORN)_") "_$PIECE($GET(^ORD(100.9,+ORN,0)),U,1)_" "
+23 ;
+24 NEW ORQUD
SET ORQUD=0
+25 IF ORN=90
DO START
SET ORQUD=1
+26 IF ORQUD=0
DO QUEUE^ORB31(ORN,$GET(ORBDFN),$GET(ORNUM),.ORBADUZ,$GET(ORBPMSG),$GET(ORBPDATA),$HOROLOG,ORBDESC,$GET(DGPMA),.ORFORCE)
+27 QUIT
ZTSK ;
+1 DO START
+2 SET ZTREQ="@"
+3 QUIT
UTL(ORBU,ORN,ORBDFN,ORNUM,ORBADUZ,ORBPMSG,ORBPDATA,ORFORCE) ;
+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,"","","")_U_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),.ORFORCE)
+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),.ORFORCE)
+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 NEW ORBIDX,ORBFLAGS
+4 SET ORBUI=1
SET ORBADT=0
+5 if '$LENGTH($GET(ORBPMSG))
SET ORBPMSG=""
+6 IF '$LENGTH(ORBPDATA)
IF (+$GET(ORNUM)>0)
SET ORBPDATA=+$GET(ORNUM)_"@"
+7 SET ORBN=^ORD(100.9,ORN,0)
+8 SET ORBIDX=0
FOR
SET ORBIDX=$ORDER(^ORD(100.9,ORN,5,ORBIDX))
if 'ORBIDX
QUIT
Begin DoDot:1
+9 SET ORBFLAGS=$PIECE($GET(^ORD(100.9,ORN,5,ORBIDX,0)),U)
+10 if ORBFLAGS'=""
SET ORBFLAGS(ORBFLAGS)=""
SET ORBFLAGS=""
End DoDot:1
+11 ;
+12 SET ORBENT=$$ENTITY^ORB31(ORNUM)
+13 ;
+14 NEW DFN
SET DFN=ORBDFN
SET VA200=""
DO OERR^VADPT
+15 IF ('$LENGTH($GET(VA("BID"))))!('$LENGTH($GET(VADM(1))))
DO QUIT
QUIT
+16 ;A/D/T notif
IF (ORN=18)!(ORN=20)!(ORN=35)
SET ORBADT=1
+17 ;if not an A/D/T notif, get primary & attending from OERR^VADPT:
+18 IF ORBADT=0
SET ORBPRIM=+$PIECE(VAIN(2),U)
SET ORBATTD=+$PIECE(VAIN(11),U)
+19 ;A/D/T notif
IF ORBADT=1
DO ADT^ORB31(ORN,ORBDFN,.ORBPRIM,.ORBATTD,$GET(ORDGPMA))
+20 ;create debug msg
IF $DATA(ORBU)
Begin DoDot:1
+21 SET ORBU(ORBUI)="Processing notification: "_$PIECE(ORBN,U)
SET ORBUI=ORBUI+1
+22 SET ORBU(ORBUI)=" for patient: "_VADM(1)
SET ORBUI=ORBUI+1
+23 IF $GET(ORNUM)>0
SET ORBU(ORBUI)=" for order: "_ORNUM
SET ORBUI=ORBUI+1
End DoDot:1
+24 DO REGULAR^ORB3REG(ORN,.XQA,.ORBU,.ORBUI,.ORBDEV,ORBDFN)
+25 DO SPECIAL^ORB3SPEC(ORN,.ORBASPEC,.ORBU,.ORBUI,$GET(ORNUM),ORBDFN,$GET(ORBPDATA),.ORBSMSG,$GET(ORBPMSG),.ORBSDEV,$GET(ORBPRIM),$GET(ORBATTD))
+26 ;special recips
IF $DATA(ORBASPEC)>1
DO SPECDUZS
+27 ;pkg-supplied recips
IF $DATA(ORBADUZ)>1
DO PKGDUZS
+28 ;provider recips
DO TITLE
+29 SET ORBXQAID=$PIECE(ORBN,U,2)_","_ORBDFN_","_ORN
+30 ;
+31 ;recips found
IF ($DATA(XQA)>1)!($DATA(ORBDEV)>1)!($DATA(ORBSDEV)>1)
Begin DoDot:1
+32 SET XQAFLG=$PIECE(ORBN,U,5)
+33 SET XQADFN=ORBDFN
+34 IF XQAFLG="R"
SET XQAROU=$PIECE(ORBN,U,6)_U_$PIECE(ORBN,U,7)
+35 IF $GET(ORBPDATA)'=""
SET XQADATA=ORBPDATA
+36 SET ORPTNAM=$EXTRACT(VADM(1)_" ",1,9)
+37 ;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")
+38 ;WAT
SET XQAMSG=ORPTNAM_" ("_$EXTRACT(ORPTNAM)_$EXTRACT(VA("BID"),1,4)_")"_$GET(CVMRKR)_": "
+39 SET XQAMSG=XQAMSG_$SELECT(ORBPMSG'="":ORBPMSG,1:$PIECE(ORBN,U,3))
+40 SET XQAARCH=$$GET^XPAR(ORBENT,"ORB ARCHIVE PERIOD",ORN,"I")
+41 SET XQASUPV=$$GET^XPAR(ORBENT,"ORB FORWARD SUPERVISOR",ORN,"I")
+42 SET XQASURO=$$GET^XPAR(ORBENT,"ORB FORWARD SURROGATES",ORN,"I")
+43 SET XQAREVUE=$$GET^XPAR(ORBENT,"ORB FORWARD BACKUP REVIEWER",ORN,"I")
+44 SET XQACNDEL=$$GET^XPAR(ORBENT,"ORB REMOVE",ORN,"I")
+45 SET XQACNDEL=$SELECT(XQACNDEL=1:1,1:"")
+46 IF ORN=90
MERGE XQATEXT=ORBPMSG
+47 IF $DATA(ORBDEV)>1
DO REGDEV^ORB31(.ORBDEV)
+48 IF $DATA(ORBSDEV)>1
DO REGDEV^ORB31(.ORBSDEV)
+49 IF $DATA(ORBTDEV)>1
DO REGDEV^ORB31(.ORBTDEV)
+50 SET XQAID=ORBXQAID
+51 IF $DATA(ORBFLAGS("ONPP"))
DO COMDUP
+52 ;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,XQACNDEL,XQAREVUE
+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["O"
DO ORDERER
+8 IF TITLES["P"
DO PRIMARY
+9 IF TITLES["A"
DO ATTEND
+10 IF TITLES["T"
DO TEAMS
+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 IF TITLES["C"
DO PCMMMHTC
+16 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 ; RBD OR*3.0*453 Intercept User (Provider) to receive alert to see if it permanently routes to another User (Provider)
+7 ; Then check if that User can receive Alerts
+8 NEW ORTRDAT,ORTRNUM,ORTRREC,ORTRREC2
IF +$GET(ORNUM)>0
Begin DoDot:2
+9 SET ORTRDAT=$ORDER(^OR(100,ORNUM,11,"B",$$NOW^XLFDT()),-1)
IF +ORTRDAT>0
Begin DoDot:3
+10 SET ORTRNUM=$ORDER(^OR(100,ORNUM,11,"B",ORTRDAT,""),-1)
IF +ORTRNUM>0
Begin DoDot:4
+11 SET ORTRREC2=$GET(^OR(100,ORNUM,11,ORTRNUM,0))
IF ORTRREC2]""
Begin DoDot:5
+12 if ORTRNUM=1
SET ORTRREC=ORTRREC2
+13 if ORTRNUM'=1
SET ORTRREC=$GET(^OR(100,ORNUM,11,1,0))
+14 IF $PIECE(ORTRREC,U,2)=ORBDUZ
IF $PIECE(ORTRREC2,U,3)
KILL ORBADUZ(ORBDUZ),XQA(ORBDUZ)
SET ORBDUZ=$PIECE(ORTRREC2,U,3)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+15 DO USER
+16 ;if notif = Order Req E/S (#12) or Order Req Co-sign (#37) and
+17 ;user doesn't have ES authority, send to fellow team members w/ES:
+18 IF ((ORN=12)!(ORN=37))
IF ('$DATA(^XUSEC("ORES",ORBDUZ)))
Begin DoDot:2
+19 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Orderer can't elec sign, getting teams orderer belongs to:"
SET ORBUI=ORBUI+1
+20 ;get orderer's tms
DO TEAMPR^ORQPTQ1(.ORBLST,ORBDUZ)
+21 if +$GET(ORBLST(1))<1
QUIT
+22 ;get pt's tms
DO TMSPT^ORQPTQ1(.ORBPLST,ORBDFN)
+23 if +$GET(ORBPLST(1))<1
QUIT
+24 SET ORBI=""
FOR
SET ORBI=$ORDER(ORBLST(ORBI))
if ORBI=""
QUIT
Begin DoDot:3
+25 SET ORBPI=""
FOR
SET ORBPI=$ORDER(ORBPLST(ORBPI))
if ORBPI=""
QUIT
Begin DoDot:4
+26 SET ORBTM=$PIECE(ORBLST(ORBI),U)
SET ORBPTM=$PIECE(ORBPLST(ORBPI),U)
+27 ;if pt is on provider's team
IF ORBTM=ORBPTM
Begin DoDot:5
+28 IF +$GET(ORBPTM)>0
Begin DoDot:6
+29 SET ORBTNAME=$PIECE(ORBPLST(ORBPI),U,2)
+30 SET ORBTTYPE=$PIECE(ORBPLST(ORBPI),U,3)
+31 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Orderer's pt list "_ORBTNAME_" ["_ORBTTYPE_"] recipients: "
SET ORBUI=ORBUI+1
+32 NEW ORBLST2
DO TEAMPROV^ORQPTQ1(.ORBLST2,ORBPTM)
+33 if +$GET(ORBLST2(1))<1
QUIT
+34 SET ORBJ=""
FOR
SET ORBJ=$ORDER(ORBLST2(ORBJ))
if ORBJ=""
QUIT
Begin DoDot:7
+35 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
+36 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 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 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 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
PCMMMHTC ;
+1 IF $DATA(ORBU)
SET ORBU(ORBUI)=" PCMM Mental Health Treatment Coordinator:"
SET ORBUI=ORBUI+1
+2 SET ORBDUZ=+$$START^SCMCMHTC(ORBDFN)
+3 IF +$GET(ORBDUZ)>0
DO USER
+4 QUIT
USER ;should USER (ORBDUZ) be a recip
+1 ;I '$$PATCH^XPDUTL("OR*3.0*498") D USER^ORB3USER(.XQA,ORBDUZ,ORN,.ORBU,.ORBUI,ORBDFN,+$G(ORNUM))
+2 ;I $$PATCH^XPDUTL("OR*3.0*498") D USER^ORB3USER(.XQA,ORBDUZ,ORN,.ORBU,.ORBUI,ORBDFN,+$G(ORNUM),$G(ORBADUZ(ORBDUZ)))
+3 DO USER^ORB3USER(.XQA,ORBDUZ,ORN,.ORBU,.ORBUI,ORBDFN,+$GET(ORNUM))
+4 IF $DATA(ORFORCE(ORBDUZ))
SET XQA(ORBDUZ)=""
+5 QUIT
COMDUP ; Combine XQADATA from existing alert(s) with new alert, delete existing alert
+1 ;and then generate the new alert for the current individual user
+2 NEW ORVAR,ORDUZ,ORAID,ORODATA
+3 FOR ORVAR="XQA","XQADATA","XQAID","XQAFLG","XQAMSG","XQAROU","XQAARCH","XQASUPV","XQASURO","XQADFN","XQACNDEL","XQAREVUE","XQAOPT","XQAEXIT","XQAUSER"
Begin DoDot:1
+4 if '$DATA(@ORVAR)
QUIT
+5 IF $DATA(@ORVAR)<10
SET ORVAR(ORVAR)=$GET(@ORVAR)
+6 IF $DATA(@ORVAR)>9
MERGE ORVAR(ORVAR)=@ORVAR
+7 SET ORVAR(0,ORVAR)=""
End DoDot:1
+8 SET ORDUZ=0
FOR
SET ORDUZ=$ORDER(XQA(ORDUZ))
if '+ORDUZ
QUIT
Begin DoDot:1
+9 NEW ORDATA,ORGEN
+10 KILL ^TMP($JOB,"ORB3DATA")
+11 DO USER^XQALERT($NAME(^TMP($JOB,"ORB3DATA")),ORDUZ)
+12 SET ORAID=0
FOR
SET ORAID=$ORDER(^TMP($JOB,"ORB3DATA",ORAID))
if '+ORAID
QUIT
Begin DoDot:2
+13 if $PIECE($PIECE(^TMP($JOB,"ORB3DATA",ORAID),U,2),";")'=($PIECE(ORBN,U,2)_","_ORBDFN_","_ORN)
QUIT
+14 IF $PIECE(ORBN,U,4)="PKG"
IF $PIECE(^TMP($JOB,"ORB3DATA",ORAID),U)'[ORVAR("XQAMSG")
QUIT
+15 NEW XQAID,XQADATA,XQAOPT,XQAROU,XQAUSER,XQAKILL
+16 NEW XQADFN,XQAMSG,XQAFLG,XQADFN,XQAARCH,XQASUPV,XQASURO,XQAREVUE,XQACNDEL
+17 KILL ^TMP($JOB,"ORB3ADATA")
+18 DO ALERTDAT^XQALBUTL($PIECE(^TMP($JOB,"ORB3DATA",ORAID),U,2),$NAME(^TMP($JOB,"ORB3ADATA")))
+19 SET XQADATA=$GET(^TMP($JOB,"ORB3ADATA",2))
+20 KILL ^TMP($JOB,"ORB3ADATA")
+21 IF XQADATA'=""
Begin DoDot:3
+22 IF $DATA(ORBFLAGS("CD"))
Begin DoDot:4
+23 NEW OROLD,ORNEW,ORSPEC,ORIDX
+24 SET OROLD=U_$SELECT(XQADATA[";":$PIECE(XQADATA,";",2),1:XQADATA)_U
SET ORNEW=U_$SELECT(ORVAR("XQADATA")[";":$PIECE(ORVAR("XQADATA"),";",2),1:ORVAR("XQADATA"))_U
+25 SET ORSPEC(U)=""
+26 FOR ORIDX=2:1:$LENGTH(ORNEW,U)
IF OROLD[(U_$PIECE(ORNEW,U,ORIDX)_U)
SET $PIECE(ORNEW,U,ORIDX)=""
+27 SET ORNEW=$$REPLACE^XLFSTR(ORNEW,.ORSPEC)
+28 IF ORNEW=""
KILL ORVAR("XQA",ORDUZ)
QUIT
+29 SET ORDATA=$SELECT(XQADATA[";":$PIECE(XQADATA,";",2),1:XQADATA)_$SELECT($GET(ORDATA)'="":U_ORDATA,1:"")
+30 SET ORGEN=1
End DoDot:4
+31 IF '$DATA(ORBFLAGS("CD"))
IF XQADATA=$GET(ORVAR("XQADATA"))
SET ORGEN=2
End DoDot:3
if '$GET(ORGEN)
QUIT
+32 SET XQAUSER=ORDUZ
SET XQAID=$PIECE(^TMP($JOB,"ORB3DATA",ORAID),U,2)
SET XQAKILL=1
+33 DO DELETE^XQALERT
End DoDot:2
+34 if $GET(ORGEN)'=1
QUIT
+35 IF $GET(XQADATA)'=""!($GET(ORDATA)'="")
SET ORODATA=$GET(XQADATA)_$SELECT($GET(ORDATA)'="":U_ORDATA,1:"")
+36 KILL ORVAR("XQA",ORDUZ)
+37 DO XQRESTOR
+38 NEW XQA,XQADATA
+39 SET XQA(ORDUZ)=""
SET XQADATA=ORODATA
DO SETUP^XQALERT
End DoDot:1
+40 KILL ^TMP($JOB,"ORB3DATA")
+41 DO XQRESTOR
+42 QUIT
XQRESTOR ; Restore XQA* variables saved off in COMDUP
+1 SET ORVAR=""
FOR
SET ORVAR=$ORDER(ORVAR(0,ORVAR))
if $GET(ORVAR)=""
QUIT
KILL @ORVAR
+2 SET ORVAR="?"
FOR
SET ORVAR=$ORDER(ORVAR(ORVAR))
if $GET(ORVAR)=""
QUIT
Begin DoDot:1
+3 IF $DATA(ORVAR(ORVAR))<10
SET @ORVAR=ORVAR(ORVAR)
+4 IF $DATA(ORVAR(ORVAR))>9
MERGE @ORVAR=ORVAR(ORVAR)
End DoDot:1
+5 QUIT
