ORB3SPEC ; slc/CLA,TC - Support routine for ORB3 ; 9/27/17 4:34pm
;;3.0;ORDER ENTRY/RESULTS REPORTING;**139,220,215,280,348,423,450**;Dec 17, 1997;Build 14
SPECIAL(ORN,ORBASPEC,ORBU,ORBUI,ORNUM,ORDFN,ORDATA,ORBSMSG,ORBMSG,ORBSDEV,ORBPRIM,ORBATTD) ;
;;Per VA Directive 6402, this routine should not be modified.
;
;DBIA SECTION
; 10114 - ^%ZIS(1
; 10035 - ^DPT(
; 10060 - ^VA(200
; 1960 - ^SCAPMC
; 5697 - ^SCMCMHTC
; 1252 - ^SDUTL3
; 10103 - ^XLFDT
; 2263 - ^XPAR
;
;process special notifs to get recips (users,teams,devices)
; ORN: notif ien
; ORBASPEC: recip DUZ array
; ORBU: recip debug array
; ORBUI: ORBU cntr
; ORNUM: order no
; ORDFN: pt id
; ORDATA: pkg data
; ORBSMSG: special notif msg rtn by SPECIAL
; ORBMSG: original notif msg
; ORBSDEV: array of recip devices
; ORBPRIM: pt's inpt primary care provider
; ORBATTD: pt's attending physician
;
N ORPAR,ORPTLOC
S ORPTLOC=$S($L($G(^DPT(ORDFN,.1))):"I",1:"O") ;DBIA #10035
I +$G(ORNUM) S ORPTLOC=$$ISCLORIP^ORB3F1(+$G(ORNUM),ORPTLOC)
;
I ORPTLOC="I" D ;inpt flagged OI notifs
.I ORN=32 S ORPAR="ORB OI RESULTS - INPT" D OI
.I ORN=41 S ORPAR="ORB OI ORDERED - INPT" D OI
.I ORN=64 S ORPAR="ORB OI EXPIRING - INPT" D OI
;
I ORPTLOC="O" D ;outpt flagged OI notifs
.I ORN=60 S ORPAR="ORB OI RESULTS - OUTPT" D OI
.I ORN=61 S ORPAR="ORB OI ORDERED - OUTPT" D OI
.I ORN=65 S ORPAR="ORB OI EXPIRING - OUTPT" D OI
;
I ORN=3!(ORN=14)!(ORN=44)!(ORN=57) D ;lab results notifs
.D LRALRTS(ORN,ORDFN,ORDATA,.ORBSMSG,ORBMSG)
;
I ORN=33 D ;requested results notif
.I $D(ORBU) D
..S ORBU(ORBUI)=" ",ORBUI=ORBUI+1
..S ORBU(ORBUI)="Potential Orderer-flagged Results recipient: ",ORBUI=ORBUI+1
.N RECIP
.S RECIP=$$RSLTFLG^ORQOR2(ORNUM)
.I +$G(RECIP)>0 D
..S ORBASPEC(+$G(RECIP))=""
..I $D(ORBU) N NODE S NODE=$G(^VA(200,+$G(RECIP),0)) I $L(NODE) D
...S ORBU(ORBUI)=" "_$P(NODE,U)_" is a potential recipient.",ORBUI=ORBUI+1
Q
OI ;get potential recips for OI-flagged notifs
N OROI,ORLST,ORERR,ORBX,ORBZ,ORBE,ORBDUZ,ORBDEV,ORBUF
S OROI=+$G(^OR(100,+$G(ORNUM),.1,1,0)) ;get oi
I ORN=41,$G(ORDATA) S OROI=ORDATA
I ORN=61,$G(ORDATA) S OROI=ORDATA
I ORN=64,$G(ORDATA) S OROI=ORDATA
I ORN=65,$G(ORDATA) S OROI=ORDATA
Q:+$G(OROI)<0
I $D(ORBU) D
.S ORBU(ORBUI)=" ",ORBUI=ORBUI+1
.S ORBU(ORBUI)="Special potential recipients from parameter: "_ORPAR,ORBUI=ORBUI+1
S ORBE=0,ORBX=0
;
;process special recip users, teams and devices:
D ENVAL^XPAR(.ORLST,ORPAR,"`"_OROI,.ORERR)
I 'ORERR,$G(ORLST)>0 D
.F ORBX=1:1:ORLST S ORBE=$O(ORLST(ORBE)),ORBZ=$P(ORBE,";",2),ORBUF=0 D
..;
..; process USERS:
..I ORBZ="VA(200," S ORBDUZ=$P(ORBE,";") I $L(ORBDUZ) D
...I ORLST(ORBE,OROI)=1 S ORBASPEC(ORBDUZ)="",ORBUF=1
...I ORLST(ORBE,OROI)=0,$$PPLINK^ORQPTQ1(ORBDUZ,ORDFN) S ORBASPEC(ORBDUZ)="",ORBUF=1
...I $D(ORBU),ORBUF=1 N NODE S NODE=$G(^VA(200,ORBDUZ,0)) I $L(NODE) D
....S ORBU(ORBUI)=" "_$P(NODE,U)_" is a potential recipient.",ORBUI=ORBUI+1
..;
..; process DEVICES:
..I ORBZ="%ZIS(1," S ORBDEV=$P(ORBE,";") I $L(ORBDEV),$D(^%ZIS(1,ORBDEV))>0 D
...S ORBDEV=$G(^%ZIS(1,ORBDEV,0)) I $D(ORBDEV) D
....I ORLST(ORBE,OROI)=1 S ORBSDEV($P(ORBDEV,U))="",ORBUF=1
....I ORLST(ORBE,OROI)=0,$$PDLINK^ORQPTQ1(ORBDEV,ORDFN) S ORBSDEV($P(ORBDEV,U))="",ORBUF=1
....I $D(ORBU),ORBUF=1 D
.....S ORBU(ORBUI)=" "_$P(ORBDEV,U)_" is a device recipient.",ORBUI=ORBUI+1
..;
..; process TEAMS:
..I ORBZ="OR(100.21," D SPECTEAM(ORBE)
D TITLE(OROI,ORPAR)
Q
SPECTEAM(ORBE) ;get special team recips
N ORBLST,IJ,ORBTM
S ORBTM=$P(ORBE,";")
D TEAMPROV^ORQPTQ1(.ORBLST,ORBTM)
I $D(ORBU) N TNODE S TNODE=$G(^OR(100.21,ORBTM,0)) I $L(TNODE) D
.S ORBU(ORBUI)=" Team potential recipients from team "_$P(TNODE,U)_":",ORBUI=ORBUI+1
I +$G(ORBLST(1))>0 S IJ="" F S IJ=$O(ORBLST(IJ)) Q:IJ="" D
.S ORBDUZ=$P(ORBLST(IJ),U),ORBUF=0 I $L(ORBDUZ) D
..I ORLST(ORBE,OROI)=1 S ORBASPEC(ORBDUZ_U_ORBTM)="",ORBUF=1
..I ORLST(ORBE,OROI)=0,$D(^OR(100.21,ORBTM,10,"B",ORDFN_";DPT(")) S ORBASPEC(ORBDUZ_U_ORBTM)="",ORBUF=1
..I $D(ORBU),ORBUF=1 N NODE S NODE=$G(^VA(200,ORBDUZ,0)) I $L(NODE) D
...S ORBU(ORBUI)=" "_$P(NODE,U),ORBUI=ORBUI+1
;
S ORBTD=$P($$TMDEV^ORB31(ORBTM),U,2) ;tm's device
I $L(ORBTD) D
.S ORBSDEV(ORBTD)=""
.I $D(ORBU) D
..S ORBU(ORBUI)=" Team's Device "_ORBTD_" is a recipient",ORBUI=ORBUI+1
Q
LRALRTS(ORN,ORDFN,ORDATA,ORBSMSG,ORBMSG) ;find & delete matching alerts and gather recips
; ORN: notif ien
; ORDFN: pt id
; ORDATA: pkg data
; ORBSMSG: special notif msg rtn by LRALRTS
; ORBMSG: original notif msg
;
Q:+$G(ORN)<1
Q:+$G(ORDFN)<1
Q:+$G(ORDATA)<1
N LRID,ORY,I,J,XQAID,XQ0,XQ1,ORNE,RECIP,ORDATAE,LRIDE,STDATE
N ORTST,ORBMSGE,ORBMSGX,TXQAID,XQF,ORBHX,ORX,ORBI,ORTSTE
;
S LRID=$P($P(ORDATA,"|",2),"@") ;get lab unique results id (OE IDE)
Q:+$G(LRID)<1
;
;get pt's alerts within 24 hours:
S STDATE=$$FMADD^XLFDT($$NOW^XLFDT,"","-24","","")
D PATIENT^XQALERT("ORY",ORDFN,STDATE,"") ;get pt's alerts
;
;look for pt's alerts with same notif ien and unique lab results id:
F I=1:1:ORY D
.S XQAID=$P(ORY(I),U,2)
.S ORBMSGX=$P(ORY(I),U)
.S ORNE=$P($P(XQAID,";"),",",3) ;get notif ien
.Q:ORNE'=ORN
.;
.;find matching alert:
.D AHISTORY^XQALBUTL(XQAID,"ORBHX")
.S ORDATAE=$G(ORBHX(2))
.Q:'$L(ORDATAE)
.S LRIDE=$P($P(ORDATAE,"|",2),"@") ;get lab rslts id from existng alert
.Q:LRIDE'=LRID
.;
.S:ORBMSG["[" ORTST=$P($P(ORBMSG,"[",2),"]")
.I ORBMSG'["[" D
..S:ORBMSG["labs: " ORTST=$P(ORBMSG,"labs: ",2)
..S:ORBMSG["results: " ORTST=$P(ORBMSG,"results: ",2)
.;
.S ORBMSGE=$P(ORBMSGX,"): ",2)
.S:ORBMSGE["[" ORTSTE=$P($P(ORBMSGE,"[",2),"]") ;added to fix CQ #17548 (Part A) for CPRS v28.1 (TC).
.;added to fix CQ #19497: undefined ORTSTE variable [v28.17] (TC)
.I ORBMSGE'["[" D
..S:ORBMSGE["labs: " ORTSTE=$P(ORBMSGE,"labs: ",2)
..S:ORBMSGE["results: " ORTSTE=$P(ORBMSGE,"results: ",2)
.E S ORTSTE=""
.;
.S ORX=0
.;if alert has recips, get recips from existing alert:
.S:$L($G(ORBHX(20,0))) ORX=$P(ORBHX(20,0),U,4)
.F ORBI=1:1:ORX D
..S RECIP=+ORBHX(20,ORBI,0)
..S ORBASPEC(RECIP)="" ;add recip to new alert recip list
.;
.;delete existing alert:
.S XQAKILL=0 ;delete for all recips
.D DELETE^XQALERT
.K XQAKILL,XQAID
;
;if NO prev alert msg for this pt, notif, lab unique id:
I '$L($G(ORBMSGE)) S ORBSMSG=ORBMSG
;
;if prev alert msg for this pt, notif, lab unique id:
I $L($G(ORBMSGE)) D
.;S:ORBMSGE["[" ORBSMSG=$P(ORBMSGE,"]")_", "_ORTST_"]"
.S ORBSMSG=$S(ORBMSGE["["&(ORTSTE'=ORTST):$P(ORBMSGE,"]")_", "_ORTST_"]",(ORBMSGE'["[")&(ORTSTE'=ORTST):ORBMSGE_", "_ORTST,1:ORBMSGE) ;added to fix CQ #17548 (Part A) for CPRS v28.1 (TC).
.;S:ORBMSGE'["[" ORBSMSG=ORBMSGE_", "_ORTST
;
Q
;
TITLE(OROI,ORPAR) ;get provider recips
N ORTIT
I $D(ORBU) D
.S ORBU(ORBUI)=" ",ORBUI=ORBUI+1
.S ORBU(ORBUI)="Special potential recipients from parameter: "_ORPAR_" PR",ORBUI=ORBUI+1
;
;process special recip users, teams and devices for Provider Recipients
S ORTIT=$$GET^XPAR("ALL",ORPAR_" PR","`"_OROI,"E")
Q:'$L(ORTIT)
I ORTIT["P" D PRIMARY
I ORTIT["A" D ATTEND
I ORTIT["T" D TEAMS
I ORTIT["O" D ORDERER
I ORTIT["E" D ENTERBY
I ORTIT["R" D PCMMPRIM
I ORTIT["S" D PCMMASSC
I ORTIT["M" D PCMMTEAM
I ORTIT["C" D PCMMMHTC
Q
PRIMARY ;
I $D(ORBU),+$G(ORBPRIM)>0 S ORBU(ORBUI)=" Flagged OI Inpt primary provider:",ORBUI=ORBUI+1
I $D(ORBU),+$G(ORBPRIM)<1 S ORBU(ORBUI)=" Flagged OI Inpt primary provider: option cannot determine without A/D/T event data.",ORBUI=ORBUI+1
I +$G(ORBPRIM)>0 S ORBASPEC(ORBPRIM)=""
Q
ATTEND ;
I $D(ORBU),+$G(ORBATTD)>0 S ORBU(ORBUI)=" Flagged OI Attending physician:",ORBUI=ORBUI+1
I $D(ORBU),+$G(ORBATTD)<1 S ORBU(ORBUI)=" Flagged OI Attending physician: option cannot determine without A/D/T event data.",ORBUI=ORBUI+1
I +$G(ORBATTD)>0 S ORBASPEC(ORBATTD)=""
Q
TEAMS ;
N ORBLST,ORBI,ORBJ,ORBTM,ORBTNAME,ORBTTYPE,ORBTD
I $D(ORBU) S ORBU(ORBUI)=" Flagged OI Teams/Personal Lists related to patient:",ORBUI=ORBUI+1
D TMSPT^ORQPTQ1(.ORBLST,ORDFN)
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 S ORBASPEC(ORBDUZ)=""
.S ORBTD=$P($$TMDEV^ORB31(ORBTM),U,2) ;tm's device
.I $L(ORBTD) D
..S ORBSDEV(ORBTD)=""
..I $D(ORBU) D
...S ORBU(ORBUI)=" Team's Device "_ORBTD_" is a recipient",ORBUI=ORBUI+1
Q
ORDERER ;
N ORBDUZ
I $D(ORBU) S ORBU(ORBUI)=" Flagged OI Ordering provider:",ORBUI=ORBUI+1
Q:+$G(ORNUM)<1
S ORBDUZ=$$ORDERER^ORQOR2(ORNUM)
I +$G(ORBDUZ)>0 D
.S ORBASPEC(ORBDUZ)=""
Q
ENTERBY ;
N ORBDUZ
I $D(ORBU) S ORBU(ORBUI)=" Flagged OI 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 S ORBASPEC(ORBDUZ)=""
Q
PCMMPRIM ;
N ORBDUZ
I $D(ORBU) S ORBU(ORBUI)=" Flagged OI PCMM Primary Care Practitioner:",ORBUI=ORBUI+1
S ORBDUZ=+$$OUTPTPR^SDUTL3(ORDFN,$$NOW^XLFDT,1) ;DBIA #1252
I +$G(ORBDUZ)>0 S ORBASPEC(ORBDUZ)=""
Q
PCMMASSC ;
N ORBDUZ
I $D(ORBU) S ORBU(ORBUI)=" Flagged OI PCMM Associate Provider:",ORBUI=ORBUI+1
S ORBDUZ=+$$OUTPTAP^SDUTL3(ORDFN,$$NOW^XLFDT) ;DBIA #1252
I +$G(ORBDUZ)>0 S ORBASPEC(ORBDUZ)=""
Q
PCMMTEAM ;
N ORPCMM,ORPCMMDZ,ORBDUZ
I $D(ORBU) S ORBU(ORBUI)=" Flagged OI PCMM Team Position Assignments:",ORBUI=ORBUI+1
S ORPCMM=$$PRPT^SCAPMC(ORDFN,,,,,,"^TMP(""ORPCMM"",$J)",) ;DBIA #1916
S ORPCMMDZ=0
F S ORPCMMDZ=$O(^TMP("ORPCMM",$J,"SCPR",ORPCMMDZ)) Q:'ORPCMMDZ D
.S ORBDUZ=ORPCMMDZ S ORBASPEC(ORBDUZ)=""
K ^TMP("ORPCMM",$J)
Q
PCMMMHTC ;
N ORBDUZ
I $D(ORBU) S ORBU(ORBUI)=" Flagged OI PCMM Mental Health Treatment Coordinator:",ORBUI=ORBUI+1
S ORBDUZ=+$$START^SCMCMHTC(ORBDFN) ;DBIA #5697
I +$G(ORBDUZ)>0 S ORBASPEC(ORBDUZ)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORB3SPEC 10304 printed Dec 13, 2024@02:27:29 Page 2
ORB3SPEC ; slc/CLA,TC - Support routine for ORB3 ; 9/27/17 4:34pm
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**139,220,215,280,348,423,450**;Dec 17, 1997;Build 14
SPECIAL(ORN,ORBASPEC,ORBU,ORBUI,ORNUM,ORDFN,ORDATA,ORBSMSG,ORBMSG,ORBSDEV,ORBPRIM,ORBATTD) ;
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;DBIA SECTION
+4 ; 10114 - ^%ZIS(1
+5 ; 10035 - ^DPT(
+6 ; 10060 - ^VA(200
+7 ; 1960 - ^SCAPMC
+8 ; 5697 - ^SCMCMHTC
+9 ; 1252 - ^SDUTL3
+10 ; 10103 - ^XLFDT
+11 ; 2263 - ^XPAR
+12 ;
+13 ;process special notifs to get recips (users,teams,devices)
+14 ; ORN: notif ien
+15 ; ORBASPEC: recip DUZ array
+16 ; ORBU: recip debug array
+17 ; ORBUI: ORBU cntr
+18 ; ORNUM: order no
+19 ; ORDFN: pt id
+20 ; ORDATA: pkg data
+21 ; ORBSMSG: special notif msg rtn by SPECIAL
+22 ; ORBMSG: original notif msg
+23 ; ORBSDEV: array of recip devices
+24 ; ORBPRIM: pt's inpt primary care provider
+25 ; ORBATTD: pt's attending physician
+26 ;
+27 NEW ORPAR,ORPTLOC
+28 ;DBIA #10035
SET ORPTLOC=$SELECT($LENGTH($GET(^DPT(ORDFN,.1))):"I",1:"O")
+29 IF +$GET(ORNUM)
SET ORPTLOC=$$ISCLORIP^ORB3F1(+$GET(ORNUM),ORPTLOC)
+30 ;
+31 ;inpt flagged OI notifs
IF ORPTLOC="I"
Begin DoDot:1
+32 IF ORN=32
SET ORPAR="ORB OI RESULTS - INPT"
DO OI
+33 IF ORN=41
SET ORPAR="ORB OI ORDERED - INPT"
DO OI
+34 IF ORN=64
SET ORPAR="ORB OI EXPIRING - INPT"
DO OI
End DoDot:1
+35 ;
+36 ;outpt flagged OI notifs
IF ORPTLOC="O"
Begin DoDot:1
+37 IF ORN=60
SET ORPAR="ORB OI RESULTS - OUTPT"
DO OI
+38 IF ORN=61
SET ORPAR="ORB OI ORDERED - OUTPT"
DO OI
+39 IF ORN=65
SET ORPAR="ORB OI EXPIRING - OUTPT"
DO OI
End DoDot:1
+40 ;
+41 ;lab results notifs
IF ORN=3!(ORN=14)!(ORN=44)!(ORN=57)
Begin DoDot:1
+42 DO LRALRTS(ORN,ORDFN,ORDATA,.ORBSMSG,ORBMSG)
End DoDot:1
+43 ;
+44 ;requested results notif
IF ORN=33
Begin DoDot:1
+45 IF $DATA(ORBU)
Begin DoDot:2
+46 SET ORBU(ORBUI)=" "
SET ORBUI=ORBUI+1
+47 SET ORBU(ORBUI)="Potential Orderer-flagged Results recipient: "
SET ORBUI=ORBUI+1
End DoDot:2
+48 NEW RECIP
+49 SET RECIP=$$RSLTFLG^ORQOR2(ORNUM)
+50 IF +$GET(RECIP)>0
Begin DoDot:2
+51 SET ORBASPEC(+$GET(RECIP))=""
+52 IF $DATA(ORBU)
NEW NODE
SET NODE=$GET(^VA(200,+$GET(RECIP),0))
IF $LENGTH(NODE)
Begin DoDot:3
+53 SET ORBU(ORBUI)=" "_$PIECE(NODE,U)_" is a potential recipient."
SET ORBUI=ORBUI+1
End DoDot:3
End DoDot:2
End DoDot:1
+54 QUIT
OI ;get potential recips for OI-flagged notifs
+1 NEW OROI,ORLST,ORERR,ORBX,ORBZ,ORBE,ORBDUZ,ORBDEV,ORBUF
+2 ;get oi
SET OROI=+$GET(^OR(100,+$GET(ORNUM),.1,1,0))
+3 IF ORN=41
IF $GET(ORDATA)
SET OROI=ORDATA
+4 IF ORN=61
IF $GET(ORDATA)
SET OROI=ORDATA
+5 IF ORN=64
IF $GET(ORDATA)
SET OROI=ORDATA
+6 IF ORN=65
IF $GET(ORDATA)
SET OROI=ORDATA
+7 if +$GET(OROI)<0
QUIT
+8 IF $DATA(ORBU)
Begin DoDot:1
+9 SET ORBU(ORBUI)=" "
SET ORBUI=ORBUI+1
+10 SET ORBU(ORBUI)="Special potential recipients from parameter: "_ORPAR
SET ORBUI=ORBUI+1
End DoDot:1
+11 SET ORBE=0
SET ORBX=0
+12 ;
+13 ;process special recip users, teams and devices:
+14 DO ENVAL^XPAR(.ORLST,ORPAR,"`"_OROI,.ORERR)
+15 IF 'ORERR
IF $GET(ORLST)>0
Begin DoDot:1
+16 FOR ORBX=1:1:ORLST
SET ORBE=$ORDER(ORLST(ORBE))
SET ORBZ=$PIECE(ORBE,";",2)
SET ORBUF=0
Begin DoDot:2
+17 ;
+18 ; process USERS:
+19 IF ORBZ="VA(200,"
SET ORBDUZ=$PIECE(ORBE,";")
IF $LENGTH(ORBDUZ)
Begin DoDot:3
+20 IF ORLST(ORBE,OROI)=1
SET ORBASPEC(ORBDUZ)=""
SET ORBUF=1
+21 IF ORLST(ORBE,OROI)=0
IF $$PPLINK^ORQPTQ1(ORBDUZ,ORDFN)
SET ORBASPEC(ORBDUZ)=""
SET ORBUF=1
+22 IF $DATA(ORBU)
IF ORBUF=1
NEW NODE
SET NODE=$GET(^VA(200,ORBDUZ,0))
IF $LENGTH(NODE)
Begin DoDot:4
+23 SET ORBU(ORBUI)=" "_$PIECE(NODE,U)_" is a potential recipient."
SET ORBUI=ORBUI+1
End DoDot:4
End DoDot:3
+24 ;
+25 ; process DEVICES:
+26 IF ORBZ="%ZIS(1,"
SET ORBDEV=$PIECE(ORBE,";")
IF $LENGTH(ORBDEV)
IF $DATA(^%ZIS(1,ORBDEV))>0
Begin DoDot:3
+27 SET ORBDEV=$GET(^%ZIS(1,ORBDEV,0))
IF $DATA(ORBDEV)
Begin DoDot:4
+28 IF ORLST(ORBE,OROI)=1
SET ORBSDEV($PIECE(ORBDEV,U))=""
SET ORBUF=1
+29 IF ORLST(ORBE,OROI)=0
IF $$PDLINK^ORQPTQ1(ORBDEV,ORDFN)
SET ORBSDEV($PIECE(ORBDEV,U))=""
SET ORBUF=1
+30 IF $DATA(ORBU)
IF ORBUF=1
Begin DoDot:5
+31 SET ORBU(ORBUI)=" "_$PIECE(ORBDEV,U)_" is a device recipient."
SET ORBUI=ORBUI+1
End DoDot:5
End DoDot:4
End DoDot:3
+32 ;
+33 ; process TEAMS:
+34 IF ORBZ="OR(100.21,"
DO SPECTEAM(ORBE)
End DoDot:2
End DoDot:1
+35 DO TITLE(OROI,ORPAR)
+36 QUIT
SPECTEAM(ORBE) ;get special team recips
+1 NEW ORBLST,IJ,ORBTM
+2 SET ORBTM=$PIECE(ORBE,";")
+3 DO TEAMPROV^ORQPTQ1(.ORBLST,ORBTM)
+4 IF $DATA(ORBU)
NEW TNODE
SET TNODE=$GET(^OR(100.21,ORBTM,0))
IF $LENGTH(TNODE)
Begin DoDot:1
+5 SET ORBU(ORBUI)=" Team potential recipients from team "_$PIECE(TNODE,U)_":"
SET ORBUI=ORBUI+1
End DoDot:1
+6 IF +$GET(ORBLST(1))>0
SET IJ=""
FOR
SET IJ=$ORDER(ORBLST(IJ))
if IJ=""
QUIT
Begin DoDot:1
+7 SET ORBDUZ=$PIECE(ORBLST(IJ),U)
SET ORBUF=0
IF $LENGTH(ORBDUZ)
Begin DoDot:2
+8 IF ORLST(ORBE,OROI)=1
SET ORBASPEC(ORBDUZ_U_ORBTM)=""
SET ORBUF=1
+9 IF ORLST(ORBE,OROI)=0
IF $DATA(^OR(100.21,ORBTM,10,"B",ORDFN_";DPT("))
SET ORBASPEC(ORBDUZ_U_ORBTM)=""
SET ORBUF=1
+10 IF $DATA(ORBU)
IF ORBUF=1
NEW NODE
SET NODE=$GET(^VA(200,ORBDUZ,0))
IF $LENGTH(NODE)
Begin DoDot:3
+11 SET ORBU(ORBUI)=" "_$PIECE(NODE,U)
SET ORBUI=ORBUI+1
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;
+13 ;tm's device
SET ORBTD=$PIECE($$TMDEV^ORB31(ORBTM),U,2)
+14 IF $LENGTH(ORBTD)
Begin DoDot:1
+15 SET ORBSDEV(ORBTD)=""
+16 IF $DATA(ORBU)
Begin DoDot:2
+17 SET ORBU(ORBUI)=" Team's Device "_ORBTD_" is a recipient"
SET ORBUI=ORBUI+1
End DoDot:2
End DoDot:1
+18 QUIT
LRALRTS(ORN,ORDFN,ORDATA,ORBSMSG,ORBMSG) ;find & delete matching alerts and gather recips
+1 ; ORN: notif ien
+2 ; ORDFN: pt id
+3 ; ORDATA: pkg data
+4 ; ORBSMSG: special notif msg rtn by LRALRTS
+5 ; ORBMSG: original notif msg
+6 ;
+7 if +$GET(ORN)<1
QUIT
+8 if +$GET(ORDFN)<1
QUIT
+9 if +$GET(ORDATA)<1
QUIT
+10 NEW LRID,ORY,I,J,XQAID,XQ0,XQ1,ORNE,RECIP,ORDATAE,LRIDE,STDATE
+11 NEW ORTST,ORBMSGE,ORBMSGX,TXQAID,XQF,ORBHX,ORX,ORBI,ORTSTE
+12 ;
+13 ;get lab unique results id (OE IDE)
SET LRID=$PIECE($PIECE(ORDATA,"|",2),"@")
+14 if +$GET(LRID)<1
QUIT
+15 ;
+16 ;get pt's alerts within 24 hours:
+17 SET STDATE=$$FMADD^XLFDT($$NOW^XLFDT,"","-24","","")
+18 ;get pt's alerts
DO PATIENT^XQALERT("ORY",ORDFN,STDATE,"")
+19 ;
+20 ;look for pt's alerts with same notif ien and unique lab results id:
+21 FOR I=1:1:ORY
Begin DoDot:1
+22 SET XQAID=$PIECE(ORY(I),U,2)
+23 SET ORBMSGX=$PIECE(ORY(I),U)
+24 ;get notif ien
SET ORNE=$PIECE($PIECE(XQAID,";"),",",3)
+25 if ORNE'=ORN
QUIT
+26 ;
+27 ;find matching alert:
+28 DO AHISTORY^XQALBUTL(XQAID,"ORBHX")
+29 SET ORDATAE=$GET(ORBHX(2))
+30 if '$LENGTH(ORDATAE)
QUIT
+31 ;get lab rslts id from existng alert
SET LRIDE=$PIECE($PIECE(ORDATAE,"|",2),"@")
+32 if LRIDE'=LRID
QUIT
+33 ;
+34 if ORBMSG["["
SET ORTST=$PIECE($PIECE(ORBMSG,"[",2),"]")
+35 IF ORBMSG'["["
Begin DoDot:2
+36 if ORBMSG["labs
SET ORTST=$PIECE(ORBMSG,"labs: ",2)
+37 if ORBMSG["results
SET ORTST=$PIECE(ORBMSG,"results: ",2)
End DoDot:2
+38 ;
+39 SET ORBMSGE=$PIECE(ORBMSGX,"): ",2)
+40 ;added to fix CQ #17548 (Part A) for CPRS v28.1 (TC).
if ORBMSGE["["
SET ORTSTE=$PIECE($PIECE(ORBMSGE,"[",2),"]")
+41 ;added to fix CQ #19497: undefined ORTSTE variable [v28.17] (TC)
+42 IF ORBMSGE'["["
Begin DoDot:2
+43 if ORBMSGE["labs
SET ORTSTE=$PIECE(ORBMSGE,"labs: ",2)
+44 if ORBMSGE["results
SET ORTSTE=$PIECE(ORBMSGE,"results: ",2)
End DoDot:2
+45 IF '$TEST
SET ORTSTE=""
+46 ;
+47 SET ORX=0
+48 ;if alert has recips, get recips from existing alert:
+49 if $LENGTH($GET(ORBHX(20,0)))
SET ORX=$PIECE(ORBHX(20,0),U,4)
+50 FOR ORBI=1:1:ORX
Begin DoDot:2
+51 SET RECIP=+ORBHX(20,ORBI,0)
+52 ;add recip to new alert recip list
SET ORBASPEC(RECIP)=""
End DoDot:2
+53 ;
+54 ;delete existing alert:
+55 ;delete for all recips
SET XQAKILL=0
+56 DO DELETE^XQALERT
+57 KILL XQAKILL,XQAID
End DoDot:1
+58 ;
+59 ;if NO prev alert msg for this pt, notif, lab unique id:
+60 IF '$LENGTH($GET(ORBMSGE))
SET ORBSMSG=ORBMSG
+61 ;
+62 ;if prev alert msg for this pt, notif, lab unique id:
+63 IF $LENGTH($GET(ORBMSGE))
Begin DoDot:1
+64 ;S:ORBMSGE["[" ORBSMSG=$P(ORBMSGE,"]")_", "_ORTST_"]"
+65 ;added to fix CQ #17548 (Part A) for CPRS v28.1 (TC).
SET ORBSMSG=$SELECT(ORBMSGE["["&(ORTSTE'=ORTST):$PIECE(ORBMSGE,"]")_", "_ORTST_"]",(ORBMSGE'["[")&(ORTSTE'=ORTST):ORBMSGE_", "_ORTST,1:ORBMSGE)
+66 ;S:ORBMSGE'["[" ORBSMSG=ORBMSGE_", "_ORTST
End DoDot:1
+67 ;
+68 QUIT
+69 ;
TITLE(OROI,ORPAR) ;get provider recips
+1 NEW ORTIT
+2 IF $DATA(ORBU)
Begin DoDot:1
+3 SET ORBU(ORBUI)=" "
SET ORBUI=ORBUI+1
+4 SET ORBU(ORBUI)="Special potential recipients from parameter: "_ORPAR_" PR"
SET ORBUI=ORBUI+1
End DoDot:1
+5 ;
+6 ;process special recip users, teams and devices for Provider Recipients
+7 SET ORTIT=$$GET^XPAR("ALL",ORPAR_" PR","`"_OROI,"E")
+8 if '$LENGTH(ORTIT)
QUIT
+9 IF ORTIT["P"
DO PRIMARY
+10 IF ORTIT["A"
DO ATTEND
+11 IF ORTIT["T"
DO TEAMS
+12 IF ORTIT["O"
DO ORDERER
+13 IF ORTIT["E"
DO ENTERBY
+14 IF ORTIT["R"
DO PCMMPRIM
+15 IF ORTIT["S"
DO PCMMASSC
+16 IF ORTIT["M"
DO PCMMTEAM
+17 IF ORTIT["C"
DO PCMMMHTC
+18 QUIT
PRIMARY ;
+1 IF $DATA(ORBU)
IF +$GET(ORBPRIM)>0
SET ORBU(ORBUI)=" Flagged OI Inpt primary provider:"
SET ORBUI=ORBUI+1
+2 IF $DATA(ORBU)
IF +$GET(ORBPRIM)<1
SET ORBU(ORBUI)=" Flagged OI Inpt primary provider: option cannot determine without A/D/T event data."
SET ORBUI=ORBUI+1
+3 IF +$GET(ORBPRIM)>0
SET ORBASPEC(ORBPRIM)=""
+4 QUIT
ATTEND ;
+1 IF $DATA(ORBU)
IF +$GET(ORBATTD)>0
SET ORBU(ORBUI)=" Flagged OI Attending physician:"
SET ORBUI=ORBUI+1
+2 IF $DATA(ORBU)
IF +$GET(ORBATTD)<1
SET ORBU(ORBUI)=" Flagged OI Attending physician: option cannot determine without A/D/T event data."
SET ORBUI=ORBUI+1
+3 IF +$GET(ORBATTD)>0
SET ORBASPEC(ORBATTD)=""
+4 QUIT
TEAMS ;
+1 NEW ORBLST,ORBI,ORBJ,ORBTM,ORBTNAME,ORBTTYPE,ORBTD
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Flagged OI Teams/Personal Lists related to patient:"
SET ORBUI=ORBUI+1
+3 DO TMSPT^ORQPTQ1(.ORBLST,ORDFN)
+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
SET ORBASPEC(ORBDUZ)=""
End DoDot:2
+14 ;tm's device
SET ORBTD=$PIECE($$TMDEV^ORB31(ORBTM),U,2)
+15 IF $LENGTH(ORBTD)
Begin DoDot:2
+16 SET ORBSDEV(ORBTD)=""
+17 IF $DATA(ORBU)
Begin DoDot:3
+18 SET ORBU(ORBUI)=" Team's Device "_ORBTD_" is a recipient"
SET ORBUI=ORBUI+1
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
ORDERER ;
+1 NEW ORBDUZ
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Flagged OI Ordering provider:"
SET ORBUI=ORBUI+1
+3 if +$GET(ORNUM)<1
QUIT
+4 SET ORBDUZ=$$ORDERER^ORQOR2(ORNUM)
+5 IF +$GET(ORBDUZ)>0
Begin DoDot:1
+6 SET ORBASPEC(ORBDUZ)=""
End DoDot:1
+7 QUIT
ENTERBY ;
+1 NEW ORBDUZ
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Flagged OI User entering order's most recent activity:"
SET ORBUI=ORBUI+1
+3 if +$GET(ORNUM)<1
QUIT
+4 IF $DATA(^OR(100,ORNUM,8,0))
Begin DoDot:1
+5 SET ORBDUZ=$PIECE(^OR(100,ORNUM,8,$PIECE(^OR(100,ORNUM,8,0),U,3),0),U,13)
End DoDot:1
+6 IF +$GET(ORBDUZ)>0
SET ORBASPEC(ORBDUZ)=""
+7 QUIT
PCMMPRIM ;
+1 NEW ORBDUZ
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Flagged OI PCMM Primary Care Practitioner:"
SET ORBUI=ORBUI+1
+3 ;DBIA #1252
SET ORBDUZ=+$$OUTPTPR^SDUTL3(ORDFN,$$NOW^XLFDT,1)
+4 IF +$GET(ORBDUZ)>0
SET ORBASPEC(ORBDUZ)=""
+5 QUIT
PCMMASSC ;
+1 NEW ORBDUZ
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Flagged OI PCMM Associate Provider:"
SET ORBUI=ORBUI+1
+3 ;DBIA #1252
SET ORBDUZ=+$$OUTPTAP^SDUTL3(ORDFN,$$NOW^XLFDT)
+4 IF +$GET(ORBDUZ)>0
SET ORBASPEC(ORBDUZ)=""
+5 QUIT
PCMMTEAM ;
+1 NEW ORPCMM,ORPCMMDZ,ORBDUZ
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Flagged OI PCMM Team Position Assignments:"
SET ORBUI=ORBUI+1
+3 ;DBIA #1916
SET ORPCMM=$$PRPT^SCAPMC(ORDFN,,,,,,"^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
SET ORBASPEC(ORBDUZ)=""
End DoDot:1
+7 KILL ^TMP("ORPCMM",$JOB)
+8 QUIT
PCMMMHTC ;
+1 NEW ORBDUZ
+2 IF $DATA(ORBU)
SET ORBU(ORBUI)=" Flagged OI PCMM Mental Health Treatment Coordinator:"
SET ORBUI=ORBUI+1
+3 ;DBIA #5697
SET ORBDUZ=+$$START^SCMCMHTC(ORBDFN)
+4 IF +$GET(ORBDUZ)>0
SET ORBASPEC(ORBDUZ)=""
+5 QUIT
