- 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 Jan 18, 2025@03:28:25 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