LRAPRES1 ;DALOI/STAFF - AP ESIG RELEASE REPORT/ALERT ;Jul 06, 2020@18:52
;;5.2;LAB SERVICE;**259,336,369,365,397,413,350,462,482,540**;Sep 27, 1994;Build 4
;
; Reference to FILE^TIUSRVP supported by ICR #3540
; Reference to ^TIULQ supported by ICR #2693
; Reference to LAB^ORB3LAB supported by ICR #4287
; Reference to ^XUSEC supported by ICR #10076
; Reference to GET^XUA4A72 supported by ICR #1625
;
MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine
Q:'$D(LRDFN)!('$D(LRSS))!('$D(LRP))!('$D(LRAC))
;
N DIR,DIRUT,DTOUT,DUOUT,LRDOCS,LRMSG,LRC,LRNUM,LRADL,LRMORE,LRQUIT,LRXQA,X,Y,DIC,XQA,XQAMSG
;
S LRQUIT=0
;
; CPRS alerts only sent for "patients" related to PATIENT file (#2)
I $P($G(^LR(LRDFN,0)),"^",2)'=2 Q
;
D DOCS,MORE
I LRMORE D LOOKUP
D ALERT
;;*
LR7OB1 ;Update CPRS package reference and status of complete
D
. Q:LRSS="AU" ;Do not update CPRS for Autopsy - AU does not update CPRS
. NEW LRX,LR
. S LRX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
. Q:'$G(LRX)
. S LR(4)=$P(LRX,U,4),LR(5)=$P(LRX,U,5)
. Q:$S('LR(4):1,'LR(5):1,1:0)
. D NEW^LR7OB1(LR(4),LR(5),"RE",,+LRT)
;;;*
Q
;
;
DOCS ; Get ordering provider and PCP/attending to send alert
N LRNUM,LRMSG
S:$G(LRSF)="" LRSF=63
D GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$G(LRI),LRSF)
S (LRNUM,LRQUIT)=1,LRC=0
F S LRC=$O(LRDOCS(LRC)) Q:LRC<1 D
. I $D(LRXQA(+LRDOCS(LRC))) S LRXQA(+LRDOCS(LRC))=LRXQA(+LRDOCS(LRC))_"/"_$P(LRDOCS(LRC),"^",3) Q
. S LRXQA(+LRDOCS(LRC))=$P(LRDOCS(LRC),"^",3),LRQUIT=0
;
I 'LRQUIT D
. S LRC=0,LRMSG(LRNUM)="Mandatory Alert will be sent to: ",LRMSG(LRNUM,"F")="!!"
. F S LRC=$O(LRDOCS(LRC)) Q:LRC<1 D
. . S LRNUM=LRNUM+1,LRMSG(LRNUM)=$P(LRDOCS(LRC),"^",2)_" ["_$P(LRDOCS(LRC),"^",3)_"]"
. . S LRMSG(LRNUM,"F")=$S(LRNUM>2:"!",1:"")_"?33"
I LRQUIT S LRMSG(LRNUM)="No Ordering Provider or PCP selected for alert",LRMSG(LRNUM,"F")="!!",LRQUIT=0
D EN^DDIOL(.LRMSG)
Q
;
;
MORE ; Add names or mail groups to the lookup list?
N DIR,DIRUT,DTOUT,DUOUT,X,Y
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^LRAPRES1"
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,X,Y
S LRQUIT=0
F D Q:LRQUIT
. W !
. K DIR
. S LRDELETE=0
. S DIR(0)="FO^3:30^I X["".""&(X'?1""G."".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 AHELP2^LRAPRES1"
. 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="",Y=$$UP^XLFSTR(Y)
. I Y["." S LRADL=$P(Y,"."),X=$P(Y,".",2)
. K DIC
. S DIC(0)="QEZ"
. S DIC=$S(LRADL="G":3.8,1:200)
. D ^DIC
. Q:Y=-1
. I LRDELETE D
. . I LRADL="" K XQA($P(Y,"^")) Q
. . I LRADL="G" K XQA("G."_$P(Y,"^",2))
. E D
. . I LRADL="",'$D(XQA($P(Y,"^"))) S XQA($P(Y,"^"))="Additional User" Q
. . I LRADL="G" S XQA("G."_$P(Y,"^",2))="Additional Mail Group"
. 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
;
;
ALERT ; Send the alert
;
M XQA=LRXQA
I '$D(XQA) D EN^DDIOL("Alerts NOT sent - no alert recipients identified!","","!!") Q
;
D LAB^ORB3LAB(DFN,LRDFN,LRI,$G(LRA),LRSS,.XQA)
;
D EN^DDIOL("Alerts have been sent.","","!!")
Q
;
;
AHELP ; Help Frame
N LRI,LRJ,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."
S LRMSG(4)="A mandatory alert is sent to the ordering provider/surgeon and the primary care",LRMSG(4,"F")="!!"
S LRMSG(5)="provider/attending that this report has been electronically signed and is now"
S LRMSG(6)="available for viewing."
S LRJ=6
D CHELP
Q
;
AHELP2 ; Help frame entry point for additional recipients selection
;
N LRI,LRJ,LRMSG
S LRMSG(1)="A mandatory alert is sent to the ordering provider/surgeon and the primary care",LRMSG(4,"F")="!!"
S LRMSG(2)="provider/attending that this report has been electronically signed and is now"
S LRMSG(3)="available for viewing."
S LRJ=3
D CHELP
Q
;
;
CHELP ; Display common help
;
I '$D(LRXQA) S LRJ=LRJ+1,LRMSG(LRJ)="No mandatory recipients listed",LRMSG(LRJ,"F")="!!"
E D
. S LRI=0,LRJ=LRJ+1,LRMSG(LRJ)="The current mandatory recipients will be:",LRMSG(LRJ,"F")="!!"
. F S LRI=$O(LRXQA(LRI)) Q:LRI<1 S LRJ=LRJ+1,LRMSG(LRJ)=$$NAME^XUSER(LRI,"F")_" ["_LRXQA(LRI)_"]"
;
I '$D(XQA) S LRJ=LRJ+1,LRMSG(LRJ)="No additional recipients listed",LRMSG(LRJ,"F")="!!"
E D
. S LRI="",LRJ=LRJ+1,LRMSG(LRJ)="The current additional recipients will be:",LRMSG(LRJ,"F")="!!"
. F S LRI=$O(XQA(LRI)) Q:LRI="" S LRJ=LRJ+1,LRMSG(LRJ)=$S(LRI:$$NAME^XUSER(LRI,"F"),1:LRI)_" ["_XQA(LRI)_"]"
;
D EN^DDIOL(.LRMSG)
Q
;
;
RETRACT(LRDFN,LRSS,LRI,LRTIUPTR) ;
; Change prior TIU versions of report to RETRACTED status
N LRROOT,LRIENS,LRFILE,LRTIUP,LRTIUAR,LRERR,LRSTAT,LRTIUX,LREXRR
I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q
I LRSS="AU" D
. S LRROOT="^LR(LRDFN,101,""C""",LRIENS=LRDFN_","
. S LRFILE=63.101
I LRSS'="AU" D
. S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""C"""
. S LRIENS=LRI_","_LRDFN_","
. S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
Q:'$D(@(LRROOT_")"))
S LRTIUP=0,LRTIUX(.05)=15
F S LRTIUP=$O(@(LRROOT_",LRTIUP)")) Q:LRTIUP'>0!(LRTIUP=LRTIUPTR) D
. K LRTIUAR S (LRSTAT,LRERR)=0
. D EXTRACT^TIULQ(LRTIUP,"LRTIUAR",.LRERR,".05",,,"I")
. Q:+LRERR
. M LRSTAT=LRTIUAR(LRTIUP,.05,"I")
. Q:LRSTAT'=7 ;Quit if current status is not COMPLETED
. D FILE^TIUSRVP(.LREXRR,LRTIUP,.LRTIUX)
. ; Update new TIU version of report with previous TIU pointer value
. N LREXRR,LRTIUX
. S LRTIUX(1406)=LRTIUP
. D FILE^TIUSRVP(.LREXRR,LRTIUPTR,.LRTIUX)
Q
;
;
CLSSCHK(DUZ,LREND) ; Determine if user has the proper class settings and PROVIDER key
;
N LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH
; First, check for PROVIDER key
I '$D(^XUSEC("PROVIDER",DUZ)) D Q
. D EN^DDIOL($C(7)_"Electronic signature not authorized. Missing PROVIDER key.","","!!")
. S LREND=1
; Next, check the provider class
; PROVIDER CL must contain PHYSICIAN, or CYTOTECH only for CY section
; or DENTIST for ORAL AND MAXILLOFACIAL PATHOLOGY
S LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5)
S LRMTCH=0
I LRPRCLSS'["PHYSICIAN",LRPRCLSS'["DENTIST" D
. I LRPRCLSS'["CYTOTECH" S LRMTCH=1
. I LRSS'="CY" S LRMTCH=1
I LRMTCH=1 D Q
. N LRMSG
. S LRMSG(1)=$C(7)_"You are not authorized to electronically sign reports.",LRMSG(1,"F")="!!"
. S LRMSG(2)="PROVIDER CLASS must include PHYSICIAN,"
. S LRMSG(3)=" or CYTOTECHNOLOGIST for CY SECTIONS ONLY,"
. S LRMSG(4)=" or DENTIST for ORAL AND MAXILLOFACIAL PATHOLOGY."
. D EN^DDIOL(.LRMSG)
. S LREND=1
;
; Finally, check the person class
S LRPCSTR=$$GET^XUA4A72(DUZ)
I LRPCSTR<0 D Q
. D EN^DDIOL("PERSON CLASS is inactive or undefined. Electronic signature is not authorized.","","!!")
. S LREND=1
S LRPCEXP=+$P(LRPCSTR,"^",6)
I LRPCEXP,LRPCEXP<DT D Q
. D EN^DDIOL("PERSON CLASS has expired. Electronic signature is not authorized.","","!!")
. S LREND=1
S LRVCDE=$P(LRPCSTR,"^",7),LRMTCH=0
;
; Correct PERSON Class should match PROVIDER Class
I LRPRCLSS["PHYSICIAN" D
. I $E(LRVCDE,1,6)="V11370","123568"[+$E(LRVCDE,7) S LRMTCH=1 Q
. I $E(LRVCDE,1,6)="V11371","03"[+$E(LRVCDE,7) S LRMTCH=1 Q
. I $E(LRVCDE,1,6)="V18240","124579"[+$E(LRVCDE,7) S LRMTCH=1 Q
. I LRVCDE="V182413" S LRMTCH=1
. ;LR*5.2*540: add MOHS person class
. I LRVCDE="V180504" S LRMTCH=1
;
I LRPRCLSS["CYTOTECH",LRVCDE="V150113" S LRMTCH=1
I LRPRCLSS["DENTIST",LRVCDE="V030503" S LRMTCH=1
;
I 'LRMTCH D
. D EN^DDIOL("Invalid PERSON CLASS. Electronic Signature is not authorized.","","!!")
. S LREND=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPRES1 8396 printed Sep 23, 2025@19:43:50 Page 2
LRAPRES1 ;DALOI/STAFF - AP ESIG RELEASE REPORT/ALERT ;Jul 06, 2020@18:52
+1 ;;5.2;LAB SERVICE;**259,336,369,365,397,413,350,462,482,540**;Sep 27, 1994;Build 4
+2 ;
+3 ; Reference to FILE^TIUSRVP supported by ICR #3540
+4 ; Reference to ^TIULQ supported by ICR #2693
+5 ; Reference to LAB^ORB3LAB supported by ICR #4287
+6 ; Reference to ^XUSEC supported by ICR #10076
+7 ; Reference to GET^XUA4A72 supported by ICR #1625
+8 ;
MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine
+1 if '$DATA(LRDFN)!('$DATA(LRSS))!('$DATA(LRP))!('$DATA(LRAC))
QUIT
+2 ;
+3 NEW DIR,DIRUT,DTOUT,DUOUT,LRDOCS,LRMSG,LRC,LRNUM,LRADL,LRMORE,LRQUIT,LRXQA,X,Y,DIC,XQA,XQAMSG
+4 ;
+5 SET LRQUIT=0
+6 ;
+7 ; CPRS alerts only sent for "patients" related to PATIENT file (#2)
+8 IF $PIECE($GET(^LR(LRDFN,0)),"^",2)'=2
QUIT
+9 ;
+10 DO DOCS
DO MORE
+11 IF LRMORE
DO LOOKUP
+12 DO ALERT
+13 ;;*
LR7OB1 ;Update CPRS package reference and status of complete
+1 Begin DoDot:1
+2 ;Do not update CPRS for Autopsy - AU does not update CPRS
if LRSS="AU"
QUIT
+3 NEW LRX,LR
+4 SET LRX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
+5 if '$GET(LRX)
QUIT
+6 SET LR(4)=$PIECE(LRX,U,4)
SET LR(5)=$PIECE(LRX,U,5)
+7 if $SELECT('LR(4)
QUIT
+8 DO NEW^LR7OB1(LR(4),LR(5),"RE",,+LRT)
End DoDot:1
+9 ;;;*
+10 QUIT
+11 ;
+12 ;
DOCS ; Get ordering provider and PCP/attending to send alert
+1 NEW LRNUM,LRMSG
+2 if $GET(LRSF)=""
SET LRSF=63
+3 DO GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$GET(LRI),LRSF)
+4 SET (LRNUM,LRQUIT)=1
SET LRC=0
+5 FOR
SET LRC=$ORDER(LRDOCS(LRC))
if LRC<1
QUIT
Begin DoDot:1
+6 IF $DATA(LRXQA(+LRDOCS(LRC)))
SET LRXQA(+LRDOCS(LRC))=LRXQA(+LRDOCS(LRC))_"/"_$PIECE(LRDOCS(LRC),"^",3)
QUIT
+7 SET LRXQA(+LRDOCS(LRC))=$PIECE(LRDOCS(LRC),"^",3)
SET LRQUIT=0
End DoDot:1
+8 ;
+9 IF 'LRQUIT
Begin DoDot:1
+10 SET LRC=0
SET LRMSG(LRNUM)="Mandatory Alert will be sent to: "
SET LRMSG(LRNUM,"F")="!!"
+11 FOR
SET LRC=$ORDER(LRDOCS(LRC))
if LRC<1
QUIT
Begin DoDot:2
+12 SET LRNUM=LRNUM+1
SET LRMSG(LRNUM)=$PIECE(LRDOCS(LRC),"^",2)_" ["_$PIECE(LRDOCS(LRC),"^",3)_"]"
+13 SET LRMSG(LRNUM,"F")=$SELECT(LRNUM>2:"!",1:"")_"?33"
End DoDot:2
End DoDot:1
+14 IF LRQUIT
SET LRMSG(LRNUM)="No Ordering Provider or PCP selected for alert"
SET LRMSG(LRNUM,"F")="!!"
SET LRQUIT=0
+15 DO EN^DDIOL(.LRMSG)
+16 QUIT
+17 ;
+18 ;
MORE ; Add names or mail groups to the lookup list?
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 WRITE !
+3 SET LRMORE=1
+4 SET DIR(0)="Y"
+5 SET DIR("A")="Send the alert to additional recipients and/or mail groups"
+6 SET X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q")
+7 SET DIR("B")=$SELECT(X=1:"YES",1:"NO")
+8 SET DIR("?")="^D AHELP^LRAPRES1"
+9 DO ^DIR
+10 IF Y=0
SET LRMORE=0
QUIT
+11 IF $DATA(DUOUT)!($DATA(DTOUT))
SET LRQUIT=1
+12 QUIT
+13 ;
+14 ;
LOOKUP ; Add additional names or mail groups to alert list.
+1 NEW DIC,DIR,DIRUT,DTOUT,DUOUT,LRADL,LRDELETE,X,Y
+2 SET LRQUIT=0
+3 FOR
Begin DoDot:1
+4 WRITE !
+5 KILL DIR
+6 SET LRDELETE=0
+7 SET DIR(0)="FO^3:30^I X["".""&(X'?1""G."".E) K X"
+8 SET DIR("A")="Enter name or mail group"
+9 SET DIR("?",1)="Prefix selection with '-' to delete a recipient"
+10 SET DIR("?",2)="Enter lastname,firstname OR G.mailgroup OR ^ to exit"
+11 SET DIR("?")="Enter '??' for additional help and listing of currently selected recipients."
+12 SET DIR("??")="^D AHELP2^LRAPRES1"
+13 SET DIR("PRE")="I '$D(DTOUT),$E(X)=""-"" S X=$E(X,2,9999),LRDELETE=1"
+14 DO ^DIR
+15 IF $DATA(DIRUT)
SET LRQUIT=1
QUIT
+16 SET LRADL=""
SET Y=$$UP^XLFSTR(Y)
+17 IF Y["."
SET LRADL=$PIECE(Y,".")
SET X=$PIECE(Y,".",2)
+18 KILL DIC
+19 SET DIC(0)="QEZ"
+20 SET DIC=$SELECT(LRADL="G":3.8,1:200)
+21 DO ^DIC
+22 if Y=-1
QUIT
+23 IF LRDELETE
Begin DoDot:2
+24 IF LRADL=""
KILL XQA($PIECE(Y,"^"))
QUIT
+25 IF LRADL="G"
KILL XQA("G."_$PIECE(Y,"^",2))
End DoDot:2
+26 IF '$TEST
Begin DoDot:2
+27 IF LRADL=""
IF '$DATA(XQA($PIECE(Y,"^")))
SET XQA($PIECE(Y,"^"))="Additional User"
QUIT
+28 IF LRADL="G"
SET XQA("G."_$PIECE(Y,"^",2))="Additional Mail Group"
End DoDot:2
+29 KILL LRMSG
+30 SET LRMSG=$SELECT(LRADL="G":"Mail group ",1:"User ")_$PIECE(Y,"^",2)_$SELECT(LRDELETE:" deleted from",1:" added to")_" alert list."
+31 DO EN^DDIOL(LRMSG,"","!!")
End DoDot:1
if LRQUIT
QUIT
+32 QUIT
+33 ;
+34 ;
ALERT ; Send the alert
+1 ;
+2 MERGE XQA=LRXQA
+3 IF '$DATA(XQA)
DO EN^DDIOL("Alerts NOT sent - no alert recipients identified!","","!!")
QUIT
+4 ;
+5 DO LAB^ORB3LAB(DFN,LRDFN,LRI,$GET(LRA),LRSS,.XQA)
+6 ;
+7 DO EN^DDIOL("Alerts have been sent.","","!!")
+8 QUIT
+9 ;
+10 ;
AHELP ; Help Frame
+1 NEW LRI,LRJ,LRMSG
+2 SET LRMSG(1)="Enter either 'Y' or 'N'."
+3 SET LRMSG(2)="If answered 'Yes', you will also have the opportunity to send alerts"
SET LRMSG(2,"F")="!!"
+4 SET LRMSG(3)="to additional recipients and/or mail groups."
+5 SET LRMSG(4)="A mandatory alert is sent to the ordering provider/surgeon and the primary care"
SET LRMSG(4,"F")="!!"
+6 SET LRMSG(5)="provider/attending that this report has been electronically signed and is now"
+7 SET LRMSG(6)="available for viewing."
+8 SET LRJ=6
+9 DO CHELP
+10 QUIT
+11 ;
AHELP2 ; Help frame entry point for additional recipients selection
+1 ;
+2 NEW LRI,LRJ,LRMSG
+3 SET LRMSG(1)="A mandatory alert is sent to the ordering provider/surgeon and the primary care"
SET LRMSG(4,"F")="!!"
+4 SET LRMSG(2)="provider/attending that this report has been electronically signed and is now"
+5 SET LRMSG(3)="available for viewing."
+6 SET LRJ=3
+7 DO CHELP
+8 QUIT
+9 ;
+10 ;
CHELP ; Display common help
+1 ;
+2 IF '$DATA(LRXQA)
SET LRJ=LRJ+1
SET LRMSG(LRJ)="No mandatory recipients listed"
SET LRMSG(LRJ,"F")="!!"
+3 IF '$TEST
Begin DoDot:1
+4 SET LRI=0
SET LRJ=LRJ+1
SET LRMSG(LRJ)="The current mandatory recipients will be:"
SET LRMSG(LRJ,"F")="!!"
+5 FOR
SET LRI=$ORDER(LRXQA(LRI))
if LRI<1
QUIT
SET LRJ=LRJ+1
SET LRMSG(LRJ)=$$NAME^XUSER(LRI,"F")_" ["_LRXQA(LRI)_"]"
End DoDot:1
+6 ;
+7 IF '$DATA(XQA)
SET LRJ=LRJ+1
SET LRMSG(LRJ)="No additional recipients listed"
SET LRMSG(LRJ,"F")="!!"
+8 IF '$TEST
Begin DoDot:1
+9 SET LRI=""
SET LRJ=LRJ+1
SET LRMSG(LRJ)="The current additional recipients will be:"
SET LRMSG(LRJ,"F")="!!"
+10 FOR
SET LRI=$ORDER(XQA(LRI))
if LRI=""
QUIT
SET LRJ=LRJ+1
SET LRMSG(LRJ)=$SELECT(LRI:$$NAME^XUSER(LRI,"F"),1:LRI)_" ["_XQA(LRI)_"]"
End DoDot:1
+11 ;
+12 DO EN^DDIOL(.LRMSG)
+13 QUIT
+14 ;
+15 ;
RETRACT(LRDFN,LRSS,LRI,LRTIUPTR) ;
+1 ; Change prior TIU versions of report to RETRACTED status
+2 NEW LRROOT,LRIENS,LRFILE,LRTIUP,LRTIUAR,LRERR,LRSTAT,LRTIUX,LREXRR
+3 IF LRSS=""!("AUSPEMCY"'[LRSS)
SET LRPTR=0
QUIT
+4 IF LRSS="AU"
Begin DoDot:1
+5 SET LRROOT="^LR(LRDFN,101,""C"""
SET LRIENS=LRDFN_","
+6 SET LRFILE=63.101
End DoDot:1
+7 IF LRSS'="AU"
Begin DoDot:1
+8 SET LRROOT="^LR(LRDFN,LRSS,LRI,.05,""C"""
+9 SET LRIENS=LRI_","_LRDFN_","
+10 SET LRFILE=$SELECT(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
End DoDot:1
+11 if '$DATA(@(LRROOT_")"))
QUIT
+12 SET LRTIUP=0
SET LRTIUX(.05)=15
+13 FOR
SET LRTIUP=$ORDER(@(LRROOT_",LRTIUP)"))
if LRTIUP'>0!(LRTIUP=LRTIUPTR)
QUIT
Begin DoDot:1
+14 KILL LRTIUAR
SET (LRSTAT,LRERR)=0
+15 DO EXTRACT^TIULQ(LRTIUP,"LRTIUAR",.LRERR,".05",,,"I")
+16 if +LRERR
QUIT
+17 MERGE LRSTAT=LRTIUAR(LRTIUP,.05,"I")
+18 ;Quit if current status is not COMPLETED
if LRSTAT'=7
QUIT
+19 DO FILE^TIUSRVP(.LREXRR,LRTIUP,.LRTIUX)
+20 ; Update new TIU version of report with previous TIU pointer value
+21 NEW LREXRR,LRTIUX
+22 SET LRTIUX(1406)=LRTIUP
+23 DO FILE^TIUSRVP(.LREXRR,LRTIUPTR,.LRTIUX)
End DoDot:1
+24 QUIT
+25 ;
+26 ;
CLSSCHK(DUZ,LREND) ; Determine if user has the proper class settings and PROVIDER key
+1 ;
+2 NEW LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH
+3 ; First, check for PROVIDER key
+4 IF '$DATA(^XUSEC("PROVIDER",DUZ))
Begin DoDot:1
+5 DO EN^DDIOL($CHAR(7)_"Electronic signature not authorized. Missing PROVIDER key.","","!!")
+6 SET LREND=1
End DoDot:1
QUIT
+7 ; Next, check the provider class
+8 ; PROVIDER CL must contain PHYSICIAN, or CYTOTECH only for CY section
+9 ; or DENTIST for ORAL AND MAXILLOFACIAL PATHOLOGY
+10 SET LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5)
+11 SET LRMTCH=0
+12 IF LRPRCLSS'["PHYSICIAN"
IF LRPRCLSS'["DENTIST"
Begin DoDot:1
+13 IF LRPRCLSS'["CYTOTECH"
SET LRMTCH=1
+14 IF LRSS'="CY"
SET LRMTCH=1
End DoDot:1
+15 IF LRMTCH=1
Begin DoDot:1
+16 NEW LRMSG
+17 SET LRMSG(1)=$CHAR(7)_"You are not authorized to electronically sign reports."
SET LRMSG(1,"F")="!!"
+18 SET LRMSG(2)="PROVIDER CLASS must include PHYSICIAN,"
+19 SET LRMSG(3)=" or CYTOTECHNOLOGIST for CY SECTIONS ONLY,"
+20 SET LRMSG(4)=" or DENTIST for ORAL AND MAXILLOFACIAL PATHOLOGY."
+21 DO EN^DDIOL(.LRMSG)
+22 SET LREND=1
End DoDot:1
QUIT
+23 ;
+24 ; Finally, check the person class
+25 SET LRPCSTR=$$GET^XUA4A72(DUZ)
+26 IF LRPCSTR<0
Begin DoDot:1
+27 DO EN^DDIOL("PERSON CLASS is inactive or undefined. Electronic signature is not authorized.","","!!")
+28 SET LREND=1
End DoDot:1
QUIT
+29 SET LRPCEXP=+$PIECE(LRPCSTR,"^",6)
+30 IF LRPCEXP
IF LRPCEXP<DT
Begin DoDot:1
+31 DO EN^DDIOL("PERSON CLASS has expired. Electronic signature is not authorized.","","!!")
+32 SET LREND=1
End DoDot:1
QUIT
+33 SET LRVCDE=$PIECE(LRPCSTR,"^",7)
SET LRMTCH=0
+34 ;
+35 ; Correct PERSON Class should match PROVIDER Class
+36 IF LRPRCLSS["PHYSICIAN"
Begin DoDot:1
+37 IF $EXTRACT(LRVCDE,1,6)="V11370"
IF "123568"[+$EXTRACT(LRVCDE,7)
SET LRMTCH=1
QUIT
+38 IF $EXTRACT(LRVCDE,1,6)="V11371"
IF "03"[+$EXTRACT(LRVCDE,7)
SET LRMTCH=1
QUIT
+39 IF $EXTRACT(LRVCDE,1,6)="V18240"
IF "124579"[+$EXTRACT(LRVCDE,7)
SET LRMTCH=1
QUIT
+40 IF LRVCDE="V182413"
SET LRMTCH=1
+41 ;LR*5.2*540: add MOHS person class
+42 IF LRVCDE="V180504"
SET LRMTCH=1
End DoDot:1
+43 ;
+44 IF LRPRCLSS["CYTOTECH"
IF LRVCDE="V150113"
SET LRMTCH=1
+45 IF LRPRCLSS["DENTIST"
IF LRVCDE="V030503"
SET LRMTCH=1
+46 ;
+47 IF 'LRMTCH
Begin DoDot:1
+48 DO EN^DDIOL("Invalid PERSON CLASS. Electronic Signature is not authorized.","","!!")
+49 SET LREND=1
End DoDot:1
+50 QUIT
