LR7ORB3 ;DALOI/JMC - Lab CPRS Notification Utility ;03/07/13 15:23
;;5.2;LAB SERVICE;**350,427**;Sep 27, 1994;Build 33
;
; Reference to EN^ORB3 supported by ICR #1362
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
SETUP(LRDFN,LRSS,LRIDT,LRUID) ; Setup a CPRS notification
; Call with LRDFN = file #63 IEN
; LRSS = file #63 subscript
; LRIDT = inverse d/t of entry in file #63
; LRUID = accession's UID
;
; Only supports CH and MI. AP subscript handled by separate API.
;
N DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,LRC,LRDOCS,LRMORE,LRQUIT,LRTST,LRTYPE,LRX,LRXQA,LRY,X,Y
;
S (LRTYPE,LRXQA,LRY)=""
;
; Select test to alert
S LRY=$$SELTEST(LRUID)
I 'LRY Q LRY
S LRTST=$P(LRY,"^",2,4)
;
; Ask user type of CPRS notification to send
S DIR(0)="SO^1:Lab results available;2:Abnormal lab results;3:Critical lab results"
D ^DIR
I $D(DIRUT) Q "0^User aborted"
E S LRTYPE=$S(Y=1:3,Y=2:14,1:57)
;
; Ask user for recipients.
D GETDOCS(.LRDOCS,LRDFN,LRSS,LRIDT)
S (LRC,LRXQA)=0
F S LRC=$O(LRDOCS(LRC)) Q:LRC<1 S LRXQA(+LRDOCS(LRC))=$P(LRDOCS(LRC),"^",3)
I $O(LRXQA("")) D
. N LRJ,LRMSG
. D CURREC,EN^DDIOL(.LRMSG)
;
S LRMORE=0 D MORE
I LRMORE D LOOKUP
I $O(LRXQA(""))'="" S LRXQA=1
E S LRY="0^No recipients selected"
;
; If everything OK then send alert
I LRTYPE,LRXQA D
. N LRJ,LRMSG
. D CURREC,EN^DDIOL(.LRMSG)
. K DIR
. S DIR(0)="Y",DIR("A")="Send Alert",DIR("B")="YES"
. D ^DIR
. I Y'=1 S LRY="0^Alert Sending Aborted" Q
. S LRY=$$OR(LRTYPE,LRDFN,LRSS,LRIDT,LRUID,.LRXQA,LRTST)
;
Q LRY
;
;
;
GETDOCS(LRDOCS,LRDFN,LRSS,LRIDT) ; Return PCP(inpatient PC/attending/outpt PC/outpt assoc PC/outpt attending) and ordering provider
;
N DFN,LRDPF,LRX,X
;
S LRDOCS=0
I LRSS'?1(1"CH",1"MI") Q
;
S LRX=$P($G(^LR(LRDFN,LRSS,LRIDT,0)),"^",$S(LRSS="CH":10,1:7))
I LRX>0 S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=LRX_"^"_$$NAME^XUSER(LRX,"F")_"^"_"Ordering Provider"
;
S LRDPF=$P($G(^LR(LRDFN,0)),"^",2),DFN=$P($G(^LR(LRDFN,0)),"^",3)
I LRDPF=2 D
. N LRDT,LRPCP,VADMVT,VAINDT
. S LRPCP=0
. S LRDT=$P($G(^LR(LRDFN,LRSS,LRIDT,0)),"^")
. I LRDT<1 S LRDT=DT
. S VAINDT=LRDT D ADM^VADPT2
. I VADMVT D Q
. . N VAHOW,VAIN,VAROOT
. . D INP^VADPT
. . I VAIN(2) S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=VAIN(2)_"^"_"Inpatient Primary Care Provider",LRPCP=1 Q
. . I VAIN(11) S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=VAIN(11)_"^"_"Inpatient Attending Provider",LRPCP=1
. S LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,1)
. I LRX>0 S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=LRX_"^"_"Outpatient Primary Care Provider",LRPCP=1 Q
. S LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,2)
. I LRX>0 S LRDOCS=LRDOCS+1,LRDOCS(LRDOCS)=LRX_"^"_"Outpatient Attending Provider",LRPCP=1
Q
;
;
MORE ; Add names or mail groups to the lookup list?
N DIR,DIRUT,DTOUT,DUOUT,X,Y
;
;ZEXCEPT: LRMORE,LRQUIT
;
W !
S LRMORE=1
S DIR(0)="Y"
S DIR("A")="Send the alert to additional recipients and/or mail groups"
S X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q")
S DIR("B")=$S(X=1:"YES",1:"NO")
S DIR("?")="^D AHELP^LR7ORB3"
D ^DIR
I Y=0 S LRMORE=0 Q
I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1
Q
;
;
LOOKUP ; Add additional names or mail groups to alert list.
N DIC,DIR,DIRUT,DTOUT,DUOUT,LRADL,LRDELETE,LRMSG,X,Y
;
;ZEXCEPT: LRQUIT,LRXQA
;
S LRQUIT=0
F D Q:LRQUIT
. W !
. K DIR
. S LRDELETE=0
. S DIR(0)="FO^3:30^I X["".""&(X'?1(1""G."",1""g."")1.E) K X"
. S DIR("A")="Enter name or mail group"
. S DIR("?",1)="Prefix selection with '-' to delete a recipient"
. S DIR("?",2)="Enter lastname,firstname OR G.mailgroup OR ^ to exit"
. S DIR("?")="Enter '??' for additional help and listing of currently selected recipients."
. S DIR("??")="^D AHELP^LR7ORB3"
. S DIR("PRE")="I '$D(DTOUT),$E(X)=""-"" S X=$E(X,2,9999),LRDELETE=1"
. D ^DIR
. I $D(DIRUT) S LRQUIT=1 Q
. S LRADL=""
. I Y?1(1"G.",1"g.")1.E S LRADL="G",X=$P(Y,".",2)
. K DIC
. S DIC(0)="EMQZ",DIC=$S(LRADL="G":3.8,1:200)
. I LRADL="G" S DIC("S")="N LRX S LRX=^(0) I $S($P(LRX,U,2)=""PU"":1,$P($G(^XMB(3.8,+Y,3)),U)=DUZ:1,+$P(LRX,U,6):0,$D(^XMB(3.8,+Y,1,""B"",DUZ)):1,1:0)"
. D ^DIC
. Q:Y=-1
. I LRDELETE D
. . I LRADL="" K LRXQA($P(Y,"^")) Q
. . I LRADL="G" K LRXQA("G."_$P(Y,"^",2))
. E D
. . I LRADL="" S LRXQA($P(Y,"^"))="" Q
. . I LRADL="G" S LRXQA("G."_$P(Y,"^",2))=""
. K LRMSG
. S LRMSG=$S(LRADL="G":"Mail group ",1:"User ")_$P(Y,"^",2)_$S(LRDELETE:" deleted from",1:" added to")_" alert list."
. D EN^DDIOL(LRMSG,"","!!")
Q
;
;
AHELP ; Help Frame
N LRI,LRMSG
;
S LRMSG(1)="Enter either 'Y' or 'N'."
S LRMSG(2)="If answered 'Yes', you will also have the opportunity to send alerts",LRMSG(2,"F")="!!"
S LRMSG(3)="to additional recipients and/or mail groups."
;
; Get list of current recipients
D CURREC
;
D EN^DDIOL(.LRMSG)
Q
;
;
CURREC ; Build list of current recipients.
;
N LRI,LRJ
;
;ZEXCEPT: LRMSG,LRXQA
;
S LRJ=$O(LRMSG(""),-1)
;
I '$D(LRXQA) S LRJ=LRJ+1,LRMSG(LRJ)="No recipients listed",LRMSG(LRJ,"F")="!!" Q
;
S LRI="",LRJ=LRJ+1,LRMSG(LRJ)="The current recipients will be:",LRMSG(LRJ,"F")="!!"
F S LRI=$O(LRXQA(LRI)) Q:LRI="" D
. S LRJ=LRJ+1,LRMSG(LRJ)=$S(LRI:$$NAME^XUSER(LRI,"F"),1:LRI)
. I LRXQA(LRI)'="" S LRMSG(LRJ)=LRMSG(LRJ)_" ["_LRXQA(LRI)_"]"
;
Q
;
;
OR(LRTYPE,LRDFN,LRSS,LRIDT,LRUID,LRXQA,LRTST) ; Send OR notification
;
N DFN,LRIENS,LRMSG,LRODT,LROE,LROIFN,LRPREFIX,LRSN,LRX,LRY
;
; Call with LRTYPE = type OERR notification (currently supports 3, 14, 57)
; LRDFN = file #63 IEN
; LRSS = file #63 subscript
; LRIDT = inverse d/t of entry in file #63
; LRUID = accession's UID
; LRXQA = recipient array
; LRTST = test ien ^ test name being alerted ^ parent test ien
;
; Only supports CH and MI. AP subscript handled by separate API.
;
I LRSS'?1(1"CH",1"MI") Q "0^Lab Subscript not supported"
;
S DFN=$P(^LR(LRDFN,0),"^",3)
;
S LRPREFIX=$S(LRTYPE=3:"",LRTYPE=14:"Abnormal ",LRTYPE=57:"Critical ",1:"")
;
S LRX=$$CHECKUID^LRWU4(LRUID,LRSS)
I LRX<1 Q "0^Accession's UID not valid"
S LRY=$G(^LRO(68,$P(LRX,"^",2),1,$P(LRX,"^",3),1,$P(LRX,"^",4),0))
S LRODT=+$P(LRY,"^",4),LRSN=+$P(LRY,"^",5),(LROE,LROIFN)=""
I LRODT,LRSN D
. N LR6903
. S LR6903=$O(^LRO(69,LRODT,1,LRSN,2,"B",+LRTST,0))
. I 'LR6903,$P(LRTST,"^",3) S LR6903=$O(^LRO(69,LRODT,1,LRSN,2,"B",+$P(LRTST,"^",3),0))
. I LR6903 S LROIFN=$P($G(^LRO(69,LRODT,1,LRSN,2,LR6903,0)),"^",7)
. I 'LROIFN S LROIFN=$P($G(^LRO(69,LRODT,1,LRSN,0)),"^",11)
. S LROE=$P($G(^LRO(69,LRODT,1,LRSN,.1)),"^")
;
S LRIENS=LROIFN_"@OR|"_LROE_";"_LRODT_";"_LRSN_";"_LRSS_";"_LRIDT_"@LRCH"
;
I LRSS="CH" D
. I LRTYPE=14!(LRTYPE=57) S LRMSG=LRPREFIX_"lab results:"
. E S LRMSG="Lab results:"
;
I LRSS="MI" D
. I LRTYPE=14!(LRTYPE=57) S LRMSG=LRPREFIX_"microbiology results:"
. E S LRMSG="Microbiology results:"
;
S LRMSG=LRMSG_" - ["_$P(LRTST,"^",2)_"]"
;
; OERR parameters:
; ORN: notification id (#100.9 ien)
; | ORBDFN: patient id (#2 ien)
; | | ORNUM: order number (#100 ien)
; | | | ORBADUZ: recipient array
; | | | | ORBPMSG: message text
; | | | | | ORBPDATA lab result reference
; | | | | | |
D EN^ORB3(LRTYPE,DFN,LROIFN,.LRXQA,LRMSG,LRIENS)
;
Q "1^Alert Sent"
;
;
SELTEST(LRUID) ; Select test on accession for alert messsage - screen out workload tests
;
; Call with LRUID = accession's UID
; Returns LRY = 1^Test IEN^Test name for alert message^Parent Test IEN
; 0^error message
;
N DIC,DIR,DIROUT,DIRUT,DUOUT,LRAA,LRAD,LRADO,LRAN,LRI,LRJ,LRTEST,LRX,LRY,X,Y
;
S LRY=1
; Resolve UID to global subscripts.
S LRX=$$CHECKUID^LRWU4(LRUID)
I LRX S LRAA=$P(LRX,"^",2),LRAD=$P(LRX,"^",3),LRAN=$P(LRX,"^",4)
E S LRY="0^Invalid Accession UID"
I 'LRY Q LRY
;
; Build list of tests on accession
; - if accession has rolled over then also check original accession
S LRADO=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3)
F LRJ=1,2 D
. I LRJ=2,LRAD=LRADO Q
. I LRJ=2 S LRAD=LRADO
. S LRI=0
. F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:'LRI D
. . I $P(^LAB(60,LRI,0),"^",4)'="WK" S LRTEST(LRI)=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),"^",9)
;
I '$D(LRTEST) S LRY="O^No tests on accession"
;
I 'LRY Q LRY
;
S DIC="^LAB(60,",DIC(0)="AEMQZ"
S DIC("A")="Select TEST: ",DIC("S")="I $D(LRTEST(Y))"
D ^DIC
I Y<1 S LRY="0^User aborted"
E S LRY="1^"_Y(0,0)
E S LRY="1^"_+Y_"^"_Y(0,0)_"^"_$G(LRTEST(+Y))
;
Q LRY
;
;
ASKXQA(LRDFN,LRSS,LRIDT,LRUID,LRDEFAULT) ; Ask if user wants to send a CPRS notification/alert for this accession.
; Call with LRDFN = file #63 IEN
; LRSS = file #63 subscript
; LRIDT = inverse d/t of entry in file #63
; LRUID = accession's UID
; LRDEFAULT = default answer for DIR call (1-NO,2-YES)
;
N DIR,DIRUT,DTOUT,DUOUT,LRY,X,Y
;
S LRDEFAULT=$G(LRDEFAULT)
S DIR(0)="Y",DIR("A")="Send a CPRS Alert/Notification"
S DIR("B")=$S(LRDEFAULT=2:"YES",1:"NO")
D ^DIR
I Y<1 Q
;
S LRY=$$SETUP(LRDFN,LRSS,LRIDT,LRUID)
W " ...",$P(LRY,"^",2)
;
Q
;
;
SENDOR ; Send a CPRS alert for an accession.
; - User is prompted to select the accession and tests.
;
N %ZIS,DIC,DIR,DIROUT,DIRUT,DUOUT,LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LREND,LRIDT,LRLAB,LRSS,LRSTOP,LRUID,LRVBY,LRY,X,Y
;
F D Q:LREND!LRSTOP
. S (LREND,LRSTOP,LRVBY)=0
. S LRACC="" D ^LRWU4
. I LRAN<1 S LREND=1 Q
. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." Q
. K DIC,LRDFN,LRDPF,LRIDT,LRSS
. S LRSS=$P(^LRO(68,LRAA,0),"^",2),LRDFN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^"),LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
. S LRDPF=$P(^LR(LRDFN,0),"^",2)
. I LRDPF'=2 W !,"CPRS Alerts only support patients from the PATIENT file (#2)" Q
. S LRUID=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
. I LRUID="" W !,"Accession missing associated UID" Q
. I LRSS=""!(LRIDT<1)!(LRDFN<1) W !,"Incomplete accession - unable to identify results." Q
. I LRSS'?1(1"CH",1"MI") D Q
. . W !,"This option only supports CH and MI subscripted accessions."
. . W !,"Use option 'Send an AP Alert' [LRAP ALERT] to send AP alerts"
. I '$$OK2SEND^LA7SRR W !,"This accession has not been released." Q
. S LRY=$$SETUP(LRDFN,LRSS,LRIDT,LRUID)
. W " ...",$P(LRY,"^",2)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7ORB3 10711 printed Oct 16, 2024@18:06:08 Page 2
LR7ORB3 ;DALOI/JMC - Lab CPRS Notification Utility ;03/07/13 15:23
+1 ;;5.2;LAB SERVICE;**350,427**;Sep 27, 1994;Build 33
+2 ;
+3 ; Reference to EN^ORB3 supported by ICR #1362
+4 ;
+5 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+6 ; used in conjunction with Eclipse M-editor.
+7 ;
SETUP(LRDFN,LRSS,LRIDT,LRUID) ; Setup a CPRS notification
+1 ; Call with LRDFN = file #63 IEN
+2 ; LRSS = file #63 subscript
+3 ; LRIDT = inverse d/t of entry in file #63
+4 ; LRUID = accession's UID
+5 ;
+6 ; Only supports CH and MI. AP subscript handled by separate API.
+7 ;
+8 NEW DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,LRC,LRDOCS,LRMORE,LRQUIT,LRTST,LRTYPE,LRX,LRXQA,LRY,X,Y
+9 ;
+10 SET (LRTYPE,LRXQA,LRY)=""
+11 ;
+12 ; Select test to alert
+13 SET LRY=$$SELTEST(LRUID)
+14 IF 'LRY
QUIT LRY
+15 SET LRTST=$PIECE(LRY,"^",2,4)
+16 ;
+17 ; Ask user type of CPRS notification to send
+18 SET DIR(0)="SO^1:Lab results available;2:Abnormal lab results;3:Critical lab results"
+19 DO ^DIR
+20 IF $DATA(DIRUT)
QUIT "0^User aborted"
+21 IF '$TEST
SET LRTYPE=$SELECT(Y=1:3,Y=2:14,1:57)
+22 ;
+23 ; Ask user for recipients.
+24 DO GETDOCS(.LRDOCS,LRDFN,LRSS,LRIDT)
+25 SET (LRC,LRXQA)=0
+26 FOR
SET LRC=$ORDER(LRDOCS(LRC))
if LRC<1
QUIT
SET LRXQA(+LRDOCS(LRC))=$PIECE(LRDOCS(LRC),"^",3)
+27 IF $ORDER(LRXQA(""))
Begin DoDot:1
+28 NEW LRJ,LRMSG
+29 DO CURREC
DO EN^DDIOL(.LRMSG)
End DoDot:1
+30 ;
+31 SET LRMORE=0
DO MORE
+32 IF LRMORE
DO LOOKUP
+33 IF $ORDER(LRXQA(""))'=""
SET LRXQA=1
+34 IF '$TEST
SET LRY="0^No recipients selected"
+35 ;
+36 ; If everything OK then send alert
+37 IF LRTYPE
IF LRXQA
Begin DoDot:1
+38 NEW LRJ,LRMSG
+39 DO CURREC
DO EN^DDIOL(.LRMSG)
+40 KILL DIR
+41 SET DIR(0)="Y"
SET DIR("A")="Send Alert"
SET DIR("B")="YES"
+42 DO ^DIR
+43 IF Y'=1
SET LRY="0^Alert Sending Aborted"
QUIT
+44 SET LRY=$$OR(LRTYPE,LRDFN,LRSS,LRIDT,LRUID,.LRXQA,LRTST)
End DoDot:1
+45 ;
+46 QUIT LRY
+47 ;
+48 ;
+49 ;
GETDOCS(LRDOCS,LRDFN,LRSS,LRIDT) ; Return PCP(inpatient PC/attending/outpt PC/outpt assoc PC/outpt attending) and ordering provider
+1 ;
+2 NEW DFN,LRDPF,LRX,X
+3 ;
+4 SET LRDOCS=0
+5 IF LRSS'?1(1"CH",1"MI")
QUIT
+6 ;
+7 SET LRX=$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,0)),"^",$SELECT(LRSS="CH":10,1:7))
+8 IF LRX>0
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=LRX_"^"_$$NAME^XUSER(LRX,"F")_"^"_"Ordering Provider"
+9 ;
+10 SET LRDPF=$PIECE($GET(^LR(LRDFN,0)),"^",2)
SET DFN=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+11 IF LRDPF=2
Begin DoDot:1
+12 NEW LRDT,LRPCP,VADMVT,VAINDT
+13 SET LRPCP=0
+14 SET LRDT=$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,0)),"^")
+15 IF LRDT<1
SET LRDT=DT
+16 SET VAINDT=LRDT
DO ADM^VADPT2
+17 IF VADMVT
Begin DoDot:2
+18 NEW VAHOW,VAIN,VAROOT
+19 DO INP^VADPT
+20 IF VAIN(2)
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=VAIN(2)_"^"_"Inpatient Primary Care Provider"
SET LRPCP=1
QUIT
+21 IF VAIN(11)
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=VAIN(11)_"^"_"Inpatient Attending Provider"
SET LRPCP=1
End DoDot:2
QUIT
+22 SET LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,1)
+23 IF LRX>0
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=LRX_"^"_"Outpatient Primary Care Provider"
SET LRPCP=1
QUIT
+24 SET LRX=$$OUTPTPR^SDUTL3(DFN,LRDT,2)
+25 IF LRX>0
SET LRDOCS=LRDOCS+1
SET LRDOCS(LRDOCS)=LRX_"^"_"Outpatient Attending Provider"
SET LRPCP=1
End DoDot:1
+26 QUIT
+27 ;
+28 ;
MORE ; Add names or mail groups to the lookup list?
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 ;
+3 ;ZEXCEPT: LRMORE,LRQUIT
+4 ;
+5 WRITE !
+6 SET LRMORE=1
+7 SET DIR(0)="Y"
+8 SET DIR("A")="Send the alert to additional recipients and/or mail groups"
+9 SET X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q")
+10 SET DIR("B")=$SELECT(X=1:"YES",1:"NO")
+11 SET DIR("?")="^D AHELP^LR7ORB3"
+12 DO ^DIR
+13 IF Y=0
SET LRMORE=0
QUIT
+14 IF $DATA(DUOUT)!($DATA(DTOUT))
SET LRQUIT=1
+15 QUIT
+16 ;
+17 ;
LOOKUP ; Add additional names or mail groups to alert list.
+1 NEW DIC,DIR,DIRUT,DTOUT,DUOUT,LRADL,LRDELETE,LRMSG,X,Y
+2 ;
+3 ;ZEXCEPT: LRQUIT,LRXQA
+4 ;
+5 SET LRQUIT=0
+6 FOR
Begin DoDot:1
+7 WRITE !
+8 KILL DIR
+9 SET LRDELETE=0
+10 SET DIR(0)="FO^3:30^I X["".""&(X'?1(1""G."",1""g."")1.E) K X"
+11 SET DIR("A")="Enter name or mail group"
+12 SET DIR("?",1)="Prefix selection with '-' to delete a recipient"
+13 SET DIR("?",2)="Enter lastname,firstname OR G.mailgroup OR ^ to exit"
+14 SET DIR("?")="Enter '??' for additional help and listing of currently selected recipients."
+15 SET DIR("??")="^D AHELP^LR7ORB3"
+16 SET DIR("PRE")="I '$D(DTOUT),$E(X)=""-"" S X=$E(X,2,9999),LRDELETE=1"
+17 DO ^DIR
+18 IF $DATA(DIRUT)
SET LRQUIT=1
QUIT
+19 SET LRADL=""
+20 IF Y?1(1"G.",1"g.")1.E
SET LRADL="G"
SET X=$PIECE(Y,".",2)
+21 KILL DIC
+22 SET DIC(0)="EMQZ"
SET DIC=$SELECT(LRADL="G":3.8,1:200)
+23 IF LRADL="G"
SET DIC("S")="N LRX S LRX=^(0) I $S($P(LRX,U,2)=""PU"":1,$P($G(^XMB(3.8,+Y,3)),U)=DUZ:1,+$P(LRX,U,6):0,$D(^XMB(3.8,+Y,1,""B"",DUZ)):1,1:0)"
+24 DO ^DIC
+25 if Y=-1
QUIT
+26 IF LRDELETE
Begin DoDot:2
+27 IF LRADL=""
KILL LRXQA($PIECE(Y,"^"))
QUIT
+28 IF LRADL="G"
KILL LRXQA("G."_$PIECE(Y,"^",2))
End DoDot:2
+29 IF '$TEST
Begin DoDot:2
+30 IF LRADL=""
SET LRXQA($PIECE(Y,"^"))=""
QUIT
+31 IF LRADL="G"
SET LRXQA("G."_$PIECE(Y,"^",2))=""
End DoDot:2
+32 KILL LRMSG
+33 SET LRMSG=$SELECT(LRADL="G":"Mail group ",1:"User ")_$PIECE(Y,"^",2)_$SELECT(LRDELETE:" deleted from",1:" added to")_" alert list."
+34 DO EN^DDIOL(LRMSG,"","!!")
End DoDot:1
if LRQUIT
QUIT
+35 QUIT
+36 ;
+37 ;
AHELP ; Help Frame
+1 NEW LRI,LRMSG
+2 ;
+3 SET LRMSG(1)="Enter either 'Y' or 'N'."
+4 SET LRMSG(2)="If answered 'Yes', you will also have the opportunity to send alerts"
SET LRMSG(2,"F")="!!"
+5 SET LRMSG(3)="to additional recipients and/or mail groups."
+6 ;
+7 ; Get list of current recipients
+8 DO CURREC
+9 ;
+10 DO EN^DDIOL(.LRMSG)
+11 QUIT
+12 ;
+13 ;
CURREC ; Build list of current recipients.
+1 ;
+2 NEW LRI,LRJ
+3 ;
+4 ;ZEXCEPT: LRMSG,LRXQA
+5 ;
+6 SET LRJ=$ORDER(LRMSG(""),-1)
+7 ;
+8 IF '$DATA(LRXQA)
SET LRJ=LRJ+1
SET LRMSG(LRJ)="No recipients listed"
SET LRMSG(LRJ,"F")="!!"
QUIT
+9 ;
+10 SET LRI=""
SET LRJ=LRJ+1
SET LRMSG(LRJ)="The current recipients will be:"
SET LRMSG(LRJ,"F")="!!"
+11 FOR
SET LRI=$ORDER(LRXQA(LRI))
if LRI=""
QUIT
Begin DoDot:1
+12 SET LRJ=LRJ+1
SET LRMSG(LRJ)=$SELECT(LRI:$$NAME^XUSER(LRI,"F"),1:LRI)
+13 IF LRXQA(LRI)'=""
SET LRMSG(LRJ)=LRMSG(LRJ)_" ["_LRXQA(LRI)_"]"
End DoDot:1
+14 ;
+15 QUIT
+16 ;
+17 ;
OR(LRTYPE,LRDFN,LRSS,LRIDT,LRUID,LRXQA,LRTST) ; Send OR notification
+1 ;
+2 NEW DFN,LRIENS,LRMSG,LRODT,LROE,LROIFN,LRPREFIX,LRSN,LRX,LRY
+3 ;
+4 ; Call with LRTYPE = type OERR notification (currently supports 3, 14, 57)
+5 ; LRDFN = file #63 IEN
+6 ; LRSS = file #63 subscript
+7 ; LRIDT = inverse d/t of entry in file #63
+8 ; LRUID = accession's UID
+9 ; LRXQA = recipient array
+10 ; LRTST = test ien ^ test name being alerted ^ parent test ien
+11 ;
+12 ; Only supports CH and MI. AP subscript handled by separate API.
+13 ;
+14 IF LRSS'?1(1"CH",1"MI")
QUIT "0^Lab Subscript not supported"
+15 ;
+16 SET DFN=$PIECE(^LR(LRDFN,0),"^",3)
+17 ;
+18 SET LRPREFIX=$SELECT(LRTYPE=3:"",LRTYPE=14:"Abnormal ",LRTYPE=57:"Critical ",1:"")
+19 ;
+20 SET LRX=$$CHECKUID^LRWU4(LRUID,LRSS)
+21 IF LRX<1
QUIT "0^Accession's UID not valid"
+22 SET LRY=$GET(^LRO(68,$PIECE(LRX,"^",2),1,$PIECE(LRX,"^",3),1,$PIECE(LRX,"^",4),0))
+23 SET LRODT=+$PIECE(LRY,"^",4)
SET LRSN=+$PIECE(LRY,"^",5)
SET (LROE,LROIFN)=""
+24 IF LRODT
IF LRSN
Begin DoDot:1
+25 NEW LR6903
+26 SET LR6903=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",+LRTST,0))
+27 IF 'LR6903
IF $PIECE(LRTST,"^",3)
SET LR6903=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",+$PIECE(LRTST,"^",3),0))
+28 IF LR6903
SET LROIFN=$PIECE($GET(^LRO(69,LRODT,1,LRSN,2,LR6903,0)),"^",7)
+29 IF 'LROIFN
SET LROIFN=$PIECE($GET(^LRO(69,LRODT,1,LRSN,0)),"^",11)
+30 SET LROE=$PIECE($GET(^LRO(69,LRODT,1,LRSN,.1)),"^")
End DoDot:1
+31 ;
+32 SET LRIENS=LROIFN_"@OR|"_LROE_";"_LRODT_";"_LRSN_";"_LRSS_";"_LRIDT_"@LRCH"
+33 ;
+34 IF LRSS="CH"
Begin DoDot:1
+35 IF LRTYPE=14!(LRTYPE=57)
SET LRMSG=LRPREFIX_"lab results:"
+36 IF '$TEST
SET LRMSG="Lab results:"
End DoDot:1
+37 ;
+38 IF LRSS="MI"
Begin DoDot:1
+39 IF LRTYPE=14!(LRTYPE=57)
SET LRMSG=LRPREFIX_"microbiology results:"
+40 IF '$TEST
SET LRMSG="Microbiology results:"
End DoDot:1
+41 ;
+42 SET LRMSG=LRMSG_" - ["_$PIECE(LRTST,"^",2)_"]"
+43 ;
+44 ; OERR parameters:
+45 ; ORN: notification id (#100.9 ien)
+46 ; | ORBDFN: patient id (#2 ien)
+47 ; | | ORNUM: order number (#100 ien)
+48 ; | | | ORBADUZ: recipient array
+49 ; | | | | ORBPMSG: message text
+50 ; | | | | | ORBPDATA lab result reference
+51 ; | | | | | |
+52 DO EN^ORB3(LRTYPE,DFN,LROIFN,.LRXQA,LRMSG,LRIENS)
+53 ;
+54 QUIT "1^Alert Sent"
+55 ;
+56 ;
SELTEST(LRUID) ; Select test on accession for alert messsage - screen out workload tests
+1 ;
+2 ; Call with LRUID = accession's UID
+3 ; Returns LRY = 1^Test IEN^Test name for alert message^Parent Test IEN
+4 ; 0^error message
+5 ;
+6 NEW DIC,DIR,DIROUT,DIRUT,DUOUT,LRAA,LRAD,LRADO,LRAN,LRI,LRJ,LRTEST,LRX,LRY,X,Y
+7 ;
+8 SET LRY=1
+9 ; Resolve UID to global subscripts.
+10 SET LRX=$$CHECKUID^LRWU4(LRUID)
+11 IF LRX
SET LRAA=$PIECE(LRX,"^",2)
SET LRAD=$PIECE(LRX,"^",3)
SET LRAN=$PIECE(LRX,"^",4)
+12 IF '$TEST
SET LRY="0^Invalid Accession UID"
+13 IF 'LRY
QUIT LRY
+14 ;
+15 ; Build list of tests on accession
+16 ; - if accession has rolled over then also check original accession
+17 SET LRADO=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^",3)
+18 FOR LRJ=1,2
Begin DoDot:1
+19 IF LRJ=2
IF LRAD=LRADO
QUIT
+20 IF LRJ=2
SET LRAD=LRADO
+21 SET LRI=0
+22 FOR
SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))
if 'LRI
QUIT
Begin DoDot:2
+23 IF $PIECE(^LAB(60,LRI,0),"^",4)'="WK"
SET LRTEST(LRI)=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),"^",9)
End DoDot:2
End DoDot:1
+24 ;
+25 IF '$DATA(LRTEST)
SET LRY="O^No tests on accession"
+26 ;
+27 IF 'LRY
QUIT LRY
+28 ;
+29 SET DIC="^LAB(60,"
SET DIC(0)="AEMQZ"
+30 SET DIC("A")="Select TEST: "
SET DIC("S")="I $D(LRTEST(Y))"
+31 DO ^DIC
+32 IF Y<1
SET LRY="0^User aborted"
+33 IF '$TEST
SET LRY="1^"_Y(0,0)
+34 IF '$TEST
SET LRY="1^"_+Y_"^"_Y(0,0)_"^"_$GET(LRTEST(+Y))
+35 ;
+36 QUIT LRY
+37 ;
+38 ;
ASKXQA(LRDFN,LRSS,LRIDT,LRUID,LRDEFAULT) ; Ask if user wants to send a CPRS notification/alert for this accession.
+1 ; Call with LRDFN = file #63 IEN
+2 ; LRSS = file #63 subscript
+3 ; LRIDT = inverse d/t of entry in file #63
+4 ; LRUID = accession's UID
+5 ; LRDEFAULT = default answer for DIR call (1-NO,2-YES)
+6 ;
+7 NEW DIR,DIRUT,DTOUT,DUOUT,LRY,X,Y
+8 ;
+9 SET LRDEFAULT=$GET(LRDEFAULT)
+10 SET DIR(0)="Y"
SET DIR("A")="Send a CPRS Alert/Notification"
+11 SET DIR("B")=$SELECT(LRDEFAULT=2:"YES",1:"NO")
+12 DO ^DIR
+13 IF Y<1
QUIT
+14 ;
+15 SET LRY=$$SETUP(LRDFN,LRSS,LRIDT,LRUID)
+16 WRITE " ...",$PIECE(LRY,"^",2)
+17 ;
+18 QUIT
+19 ;
+20 ;
SENDOR ; Send a CPRS alert for an accession.
+1 ; - User is prompted to select the accession and tests.
+2 ;
+3 NEW %ZIS,DIC,DIR,DIROUT,DIRUT,DUOUT,LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LREND,LRIDT,LRLAB,LRSS,LRSTOP,LRUID,LRVBY,LRY,X,Y
+4 ;
+5 FOR
Begin DoDot:1
+6 SET (LREND,LRSTOP,LRVBY)=0
+7 SET LRACC=""
DO ^LRWU4
+8 IF LRAN<1
SET LREND=1
QUIT
+9 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
QUIT
+10 KILL DIC,LRDFN,LRDPF,LRIDT,LRSS
+11 SET LRSS=$PIECE(^LRO(68,LRAA,0),"^",2)
SET LRDFN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),"^")
SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+12 SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
+13 IF LRDPF'=2
WRITE !,"CPRS Alerts only support patients from the PATIENT file (#2)"
QUIT
+14 SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^")
+15 IF LRUID=""
WRITE !,"Accession missing associated UID"
QUIT
+16 IF LRSS=""!(LRIDT<1)!(LRDFN<1)
WRITE !,"Incomplete accession - unable to identify results."
QUIT
+17 IF LRSS'?1(1"CH",1"MI")
Begin DoDot:2
+18 WRITE !,"This option only supports CH and MI subscripted accessions."
+19 WRITE !,"Use option 'Send an AP Alert' [LRAP ALERT] to send AP alerts"
End DoDot:2
QUIT
+20 IF '$$OK2SEND^LA7SRR
WRITE !,"This accession has not been released."
QUIT
+21 SET LRY=$$SETUP(LRDFN,LRSS,LRIDT,LRUID)
+22 WRITE " ...",$PIECE(LRY,"^",2)
End DoDot:1
if LREND!LRSTOP
QUIT
+23 ;
+24 QUIT
