LRAPRES1.m

LRAPRES1 ;DALOI/WTY/KLL/CKA - AP ESIG RELEASE REPORT/ALERT; 13-Aug-2013 09:16 ; MKK

 ;;5.2;LAB SERVICE;**259,336,369,365,1030,397,413,1033**;NOV 01, 1997

 ;

 ;Reference to FILE^TIUSRVP supported by IA #3540

 ;Reference to ^TIULQ supported by IA #2693 

 ;Reference to ^ORB3LAB supported by IA #4287

 ;Reference to DIC lookup on MAIL GROUP file (#3.8) supported by IA #10111

 ;

MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine

 Q:'$D(LRDFN)!('$D(LRSS))!('$D(LRP))!('$D(LRAC))

 N LRDOCS,LRMSG,LRC,LRDOCSN,LRNUM,LRADL,LRMORE,LRQUIT,LRXQA

 N DIR,DIRUT,DTOUT,DUOUT,X,Y,DIC,XQA,XQAMSG

 S LRQUIT=0

 I $G(LRAU) D

 .S LRA=^LR(LRDFN,"AU")

 .S LRI=$P(LRA,U)

 D DOCS

 Q:LRQUIT

 D MORE

 I LRMORE D LOOKUP

 D SEND

 Q

DOCS ;GET ORDERING PROVIDER AND PCP TO SEND ALERT

 W !

 S:$G(LRSF)="" LRSF=63

 D GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$G(LRI),LRSF)

 S:LRDOCS(1)=LRDOCS(2) LRDOCS(2)=0

 F LRC=1:1:2 D

 .I LRDOCS(LRC) D

 ..S LRDOCSN(LRC)=$$NAME^XUSER(LRDOCS(LRC),"F")

 ..I LRDOCSN(LRC)'="" S LRXQA(LRDOCS(LRC))=""

 S LRNUM=1

 K LRMSG

 D

 .S LRMSG(LRNUM)="Alert will be sent to:",LRMSG(LRNUM,"F")="!!"

 .I LRDOCS(1) D

 ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(1),LRMSG(LRNUM,"F")="?24"

 .I LRDOCS(2) D

 ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(2)

 ..S LRMSG(LRNUM,"F")=$S(LRDOCS(1):"!",1:"")_"?24"

 I LRQUIT D

 .S LRMSG(LRNUM)="No Ordering Provider or PCP for alert"

 .S LRMSG(LRNUM,"F")="!!"

 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 names or mail groups"

 S X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q")

 S X=$S(X=1:"YES",X=0:"NO",1:"NO")

 S DIR("B")=X

 D ^DIR

 I Y=0 S LRMORE=0 Q

 I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1,LRMORE=0

 Q

LOOKUP ;Add additional names or mail groups to alert list.

 F  D  Q:LRQUIT

 .W !

 .K DIR

 .;S DIR(0)="F^3:30^I X'?1""U."".E&(X'?1""G."".E) K X"

 .S DIR(0)="FO^3:30^I X["".""&((X'?1""G."".E)&(X'?1""g."".E)) K X"

 .S DIR("A")="Enter name or mail group"

 .S DIR("?")="Enter lastname,firstname OR G.mailgroup OR ^ to exit"

 .D ^DIR

 .I $D(DIRUT) S LRQUIT=1 Q

 .S X=Y,LRADL=""

 .I Y["." S LRADL=$P(Y,"."),X=$P(Y,".",2)

 .S Y=$$UP^XLFSTR(Y)

 .I LRADL="g" S LRADL="G"

 .K DIC

 .S DIC(0)="QEZ"

 .S DIC=$S(LRADL="G":3.8,1:200)

 .D ^DIC

 .Q:Y=-1

 .S:LRADL="" XQA($P(Y,"^"))=""

 .S:LRADL="G" XQA("G."_$P(Y,"^",2))=""

 Q

SEND ; Send the alert

 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031

 ;       Cannot send alert if OR*3.0*210 not installed on this UCI

 ;       since that patch installs the ORB3LAB routine.

 Q:'$$PATCH^XPDUTL("OR*3.0*210")

 ; ----- END IHS/MSC/MKK - LR*5.2*1031

 ;

 ;S XQAMSG=$E(LRP,1,9)_" ("_$E(LRP,1)_VA("BID")_"): Pathology report signed for "_LRAC_"."

 ;D SETUP^XQALERT

 M XQA=LRXQA

 D LAB^ORB3LAB(DFN,LRDFN,LRI,$G(LRA),LRSS,.XQA)

 I $D(LRADL) D

 . S LRMSG="Alerts have been sent to the specified additional users."

 . D EN^DDIOL(LRMSG,"","!!")

 . K LRMSG

 Q

 ;

AHELP ;Help Frame

 K LRMSG

 S LRMSG(1)="If answered 'Yes', the alert will notify the primary care"

 S LRMSG(1,"F")="!"

 S LRMSG(2)="provider and the surgeon/physician that this report has"

 S LRMSG(3)="been electronically signed and is now available for"

 S LRMSG(4)="viewing. You will also have the opportunity to send the"

 S LRMSG(5)="alert to additional names or mail groups."

 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

 .K LRMSG S LRMSG=$C(7)_"Electronic signature not authorized.  Missing "

 .S LRMSG=LRMSG_"PROVIDER key."

 .D EN^DDIOL(LRMSG,"","!!")

 .K LRMSG S LREND=1

 ;Next, check the provider class

 S LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5)

 ;PROVIDER CL MUST CONTAIN PHYSICIAN, OR CYTOTECH ONLY FOR CY SECTION

 ;OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY

 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

 .K LRMSG

 .S LRMSG(1)=$C(7)_"You are not authorized to electronically sign "

 .S LRMSG(1)=LRMSG(1)_"reports."

 .S LRMSG(1,"F")="!!"

 .S LRMSG(2)="PROVIDER CLASS must include PHYSICIAN,"

 .S LRMSG(2,"F")="!"

 .S LRMSG(3)="  OR CYTOTECHNOLOGIST FOR CY SECTIONS ONLY,"

 .S LRMSG(3,"F")="!"

 .S LRMSG(4)=" OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY."

 .S LRMSG(4,"F")="!"

 .D EN^DDIOL(.LRMSG) K LRMSG

 .S LREND=1

 ;Finally, check the person class

 S LRPCSTR=$$GET^XUA4A72(DUZ)   ;Supported reference #1625

 I LRPCSTR<0 D  Q

 .K LRMSG

 .S LRMSG="PERSON CLASS is inactive or undefined.  Electronic signature"

 .S LRMSG=LRMSG_" is not authorized."

 .D EN^DDIOL(LRMSG,"","!!")

 .K LRMSG

 .S LREND=1

 S LRPCEXP=+$P(LRPCSTR,"^",6)

 I LRPCEXP D  Q

 .K LRMSG

 .S LRMSG="PERSON CLASS has expired.  Electronic signature"

 .S LRMSG=LRMSG_" is not authorized."

 .D EN^DDIOL(LRMSG,"","!!") K LRMSG

 .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

 .I $E(LRVCDE,1,6)="V11371","03"[+$E(LRVCDE,7) S LRMTCH=1

 .I $E(LRVCDE,1,6)="V18240","124579"[+$E(LRVCDE,7) S LRMTCH=1

 .I LRVCDE="V182413" S LRMTCH=1

 I LRPRCLSS["CYTOTECH" D

 .I LRVCDE="V150113" S LRMTCH=1

 I LRPRCLSS["DENTIST" D

 .I LRVCDE="V030503" S LRMTCH=1

 I 'LRMTCH D

 .K LRMSG

 .S LRMSG="Invalid PERSON CLASS.  Electronic Signature is not "

 .S LRMSG=LRMSG_"authorized."

 .D EN^DDIOL(LRMSG,"","!!")

 .K LRMSG

 .S LREND=1

 Q

LRAPRES1  ;DALOI/WTY/KLL/CKA - AP ESIG RELEASE REPORT/ALERT; 13-Aug-2013 09:16 ; MKK

 +1       ;;5.2;LAB SERVICE;**259,336,369,365,1030,397,413,1033**;NOV 01, 1997

 +2       ;

 +3       ;Reference to FILE^TIUSRVP supported by IA #3540

 +4       ;Reference to ^TIULQ supported by IA #2693 

 +5       ;Reference to ^ORB3LAB supported by IA #4287

 +6       ;Reference to DIC lookup on MAIL GROUP file (#3.8) supported by IA #10111

 +7       ;

MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine

 +1        IF '$DATA(LRDFN)!('$DATA(LRSS))!('$DATA(LRP))!('$DATA(LRAC))

               QUIT 

 +2        NEW LRDOCS,LRMSG,LRC,LRDOCSN,LRNUM,LRADL,LRMORE,LRQUIT,LRXQA

 +3        NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,DIC,XQA,XQAMSG

 +4        SET LRQUIT=0

 +5        IF $GET(LRAU)

               Begin DoDot:1

 +6                SET LRA=^LR(LRDFN,"AU")

 +7                SET LRI=$PIECE(LRA,U)

               End DoDot:1

 +8        DO DOCS

 +9        IF LRQUIT

               QUIT 

 +10       DO MORE

 +11       IF LRMORE

               DO LOOKUP

 +12       DO SEND

 +13       QUIT 

DOCS      ;GET ORDERING PROVIDER AND PCP TO SEND ALERT

 +1        WRITE !

 +2        IF $GET(LRSF)=""

               SET LRSF=63

 +3        DO GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$GET(LRI),LRSF)

 +4        IF LRDOCS(1)=LRDOCS(2)

               SET LRDOCS(2)=0

 +5        FOR LRC=1:1:2

               Begin DoDot:1

 +6                IF LRDOCS(LRC)

                       Begin DoDot:2

 +7                        SET LRDOCSN(LRC)=$$NAME^XUSER(LRDOCS(LRC),"F")

 +8                        IF LRDOCSN(LRC)'=""

                               SET LRXQA(LRDOCS(LRC))=""

                       End DoDot:2

               End DoDot:1

 +9        SET LRNUM=1

 +10       KILL LRMSG

 +11       Begin DoDot:1

 +12           SET LRMSG(LRNUM)="Alert will be sent to:"

               SET LRMSG(LRNUM,"F")="!!"

 +13           IF LRDOCS(1)

                   Begin DoDot:2

 +14                   SET LRNUM=LRNUM+1

                       SET LRMSG(LRNUM)=LRDOCSN(1)

                       SET LRMSG(LRNUM,"F")="?24"

                   End DoDot:2

 +15           IF LRDOCS(2)

                   Begin DoDot:2

 +16                   SET LRNUM=LRNUM+1

                       SET LRMSG(LRNUM)=LRDOCSN(2)

 +17                   SET LRMSG(LRNUM,"F")=$SELECT(LRDOCS(1):"!",1:"")_"?24"

                   End DoDot:2

           End DoDot:1

 +18       IF LRQUIT

               Begin DoDot:1

 +19               SET LRMSG(LRNUM)="No Ordering Provider or PCP for alert"

 +20               SET LRMSG(LRNUM,"F")="!!"

               End DoDot:1

 +21       DO EN^DDIOL(.LRMSG)

 +22       QUIT 

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 names or mail groups"

 +6        SET X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q")

 +7        SET X=$SELECT(X=1:"YES",X=0:"NO",1:"NO")

 +8        SET DIR("B")=X

 +9        DO ^DIR

 +10       IF Y=0

               SET LRMORE=0

               QUIT 

 +11       IF $DATA(DUOUT)!($DATA(DTOUT))

               SET LRQUIT=1

               SET LRMORE=0

 +12       QUIT 

LOOKUP    ;Add additional names or mail groups to alert list.

 +1        FOR 

               Begin DoDot:1

 +2                WRITE !

 +3                KILL DIR

 +4       ;S DIR(0)="F^3:30^I X'?1""U."".E&(X'?1""G."".E) K X"

 +5                SET DIR(0)="FO^3:30^I X["".""&((X'?1""G."".E)&(X'?1""g."".E)) K X"

 +6                SET DIR("A")="Enter name or mail group"

 +7                SET DIR("?")="Enter lastname,firstname OR G.mailgroup OR ^ to exit"

 +8                DO ^DIR

 +9                IF $DATA(DIRUT)

                       SET LRQUIT=1

                       QUIT 

 +10               SET X=Y

                   SET LRADL=""

 +11               IF Y["."

                       SET LRADL=$PIECE(Y,".")

                       SET X=$PIECE(Y,".",2)

 +12               SET Y=$$UP^XLFSTR(Y)

 +13               IF LRADL="g"

                       SET LRADL="G"

 +14               KILL DIC

 +15               SET DIC(0)="QEZ"

 +16               SET DIC=$SELECT(LRADL="G":3.8,1:200)

 +17               DO ^DIC

 +18               IF Y=-1

                       QUIT 

 +19               IF LRADL=""

                       SET XQA($PIECE(Y,"^"))=""

 +20               IF LRADL="G"

                       SET XQA("G."_$PIECE(Y,"^",2))=""

               End DoDot:1

               IF LRQUIT

                   QUIT 

 +21       QUIT 

SEND      ; Send the alert

 +1       ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031

 +2       ;       Cannot send alert if OR*3.0*210 not installed on this UCI

 +3       ;       since that patch installs the ORB3LAB routine.

 +4        IF '$$PATCH^XPDUTL("OR*3.0*210")

               QUIT 

 +5       ; ----- END IHS/MSC/MKK - LR*5.2*1031

 +6       ;

 +7       ;S XQAMSG=$E(LRP,1,9)_" ("_$E(LRP,1)_VA("BID")_"): Pathology report signed for "_LRAC_"."

 +8       ;D SETUP^XQALERT

 +9        MERGE XQA=LRXQA

 +10       DO LAB^ORB3LAB(DFN,LRDFN,LRI,$GET(LRA),LRSS,.XQA)

 +11       IF $DATA(LRADL)

               Begin DoDot:1

 +12               SET LRMSG="Alerts have been sent to the specified additional users."

 +13               DO EN^DDIOL(LRMSG,"","!!")

 +14               KILL LRMSG

               End DoDot:1

 +15       QUIT 

 +16      ;

AHELP     ;Help Frame

 +1        KILL LRMSG

 +2        SET LRMSG(1)="If answered 'Yes', the alert will notify the primary care"

 +3        SET LRMSG(1,"F")="!"

 +4        SET LRMSG(2)="provider and the surgeon/physician that this report has"

 +5        SET LRMSG(3)="been electronically signed and is now available for"

 +6        SET LRMSG(4)="viewing. You will also have the opportunity to send the"

 +7        SET LRMSG(5)="alert to additional names or mail groups."

 +8        DO EN^DDIOL(.LRMSG)

 +9        QUIT 

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 

CLSSCHK(DUZ,LREND) ;Determine if user has the proper class settings and

 +1       ;PROVIDER key

 +2        NEW LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH

 +3       ;First, check for PROVIDER key

 +4        IF '$DATA(^XUSEC("PROVIDER",DUZ))

               Begin DoDot:1

 +5                KILL LRMSG

                   SET LRMSG=$CHAR(7)_"Electronic signature not authorized.  Missing "

 +6                SET LRMSG=LRMSG_"PROVIDER key."

 +7                DO EN^DDIOL(LRMSG,"","!!")

 +8                KILL LRMSG

                   SET LREND=1

               End DoDot:1

               QUIT 

 +9       ;Next, check the provider class

 +10       SET LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5)

 +11      ;PROVIDER CL MUST CONTAIN PHYSICIAN, OR CYTOTECH ONLY FOR CY SECTION

 +12      ;OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY

 +13       SET LRMTCH=0

 +14       IF LRPRCLSS'["PHYSICIAN"

               IF LRPRCLSS'["DENTIST"

                   Begin DoDot:1

 +15                   IF LRPRCLSS'["CYTOTECH"

                           SET LRMTCH=1

 +16                   IF LRSS'="CY"

                           SET LRMTCH=1

                   End DoDot:1

 +17       IF LRMTCH=1

               Begin DoDot:1

 +18               KILL LRMSG

 +19               SET LRMSG(1)=$CHAR(7)_"You are not authorized to electronically sign "

 +20               SET LRMSG(1)=LRMSG(1)_"reports."

 +21               SET LRMSG(1,"F")="!!"

 +22               SET LRMSG(2)="PROVIDER CLASS must include PHYSICIAN,"

 +23               SET LRMSG(2,"F")="!"

 +24               SET LRMSG(3)="  OR CYTOTECHNOLOGIST FOR CY SECTIONS ONLY,"

 +25               SET LRMSG(3,"F")="!"

 +26               SET LRMSG(4)=" OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY."

 +27               SET LRMSG(4,"F")="!"

 +28               DO EN^DDIOL(.LRMSG)

                   KILL LRMSG

 +29               SET LREND=1

               End DoDot:1

               QUIT 

 +30      ;Finally, check the person class

 +31      ;Supported reference #1625

           SET LRPCSTR=$$GET^XUA4A72(DUZ)

 +32       IF LRPCSTR<0

               Begin DoDot:1

 +33               KILL LRMSG

 +34               SET LRMSG="PERSON CLASS is inactive or undefined.  Electronic signature"

 +35               SET LRMSG=LRMSG_" is not authorized."

 +36               DO EN^DDIOL(LRMSG,"","!!")

 +37               KILL LRMSG

 +38               SET LREND=1

               End DoDot:1

               QUIT 

 +39       SET LRPCEXP=+$PIECE(LRPCSTR,"^",6)

 +40       IF LRPCEXP

               Begin DoDot:1

 +41               KILL LRMSG

 +42               SET LRMSG="PERSON CLASS has expired.  Electronic signature"

 +43               SET LRMSG=LRMSG_" is not authorized."

 +44               DO EN^DDIOL(LRMSG,"","!!")

                   KILL LRMSG

 +45               SET LREND=1

               End DoDot:1

               QUIT 

 +46       SET LRVCDE=$PIECE(LRPCSTR,"^",7)

           SET LRMTCH=0

 +47      ;CORRECT PERSON CLASS SHOULD MATCH PROVIDER CLASS

 +48       IF LRPRCLSS["PHYSICIAN"

               Begin DoDot:1

 +49               IF $EXTRACT(LRVCDE,1,6)="V11370"

                       IF "123568"[+$EXTRACT(LRVCDE,7)

                           SET LRMTCH=1

 +50               IF $EXTRACT(LRVCDE,1,6)="V11371"

                       IF "03"[+$EXTRACT(LRVCDE,7)

                           SET LRMTCH=1

 +51               IF $EXTRACT(LRVCDE,1,6)="V18240"

                       IF "124579"[+$EXTRACT(LRVCDE,7)

                           SET LRMTCH=1

 +52               IF LRVCDE="V182413"

                       SET LRMTCH=1

               End DoDot:1

 +53       IF LRPRCLSS["CYTOTECH"

               Begin DoDot:1

 +54               IF LRVCDE="V150113"

                       SET LRMTCH=1

               End DoDot:1

 +55       IF LRPRCLSS["DENTIST"

               Begin DoDot:1

 +56               IF LRVCDE="V030503"

                       SET LRMTCH=1

               End DoDot:1

 +57       IF 'LRMTCH

               Begin DoDot:1

 +58               KILL LRMSG

 +59               SET LRMSG="Invalid PERSON CLASS.  Electronic Signature is not "

 +60               SET LRMSG=LRMSG_"authorized."

 +61               DO EN^DDIOL(LRMSG,"","!!")

 +62               KILL LRMSG

 +63               SET LREND=1

               End DoDot:1

 +64       QUIT