Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRAPRES1

LRAPRES1.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; Reference to FILE^TIUSRVP supported by ICR #3540
  1.  ; Reference to ^TIULQ supported by ICR #2693
  1.  ; Reference to LAB^ORB3LAB supported by ICR #4287
  1.  ; Reference to ^XUSEC supported by ICR #10076
  1.  ; Reference to GET^XUA4A72 supported by ICR #1625
  1.  ;
  1. MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine
  1.  Q:'$D(LRDFN)!('$D(LRSS))!('$D(LRP))!('$D(LRAC))
  1.  ;
  1.  N DIR,DIRUT,DTOUT,DUOUT,LRDOCS,LRMSG,LRC,LRNUM,LRADL,LRMORE,LRQUIT,LRXQA,X,Y,DIC,XQA,XQAMSG
  1.  ;
  1.  S LRQUIT=0
  1.  ;
  1.  ; CPRS alerts only sent for "patients" related to PATIENT file (#2)
  1.  I $P($G(^LR(LRDFN,0)),"^",2)'=2 Q
  1.  ;
  1.  D DOCS,MORE
  1.  I LRMORE D LOOKUP
  1.  D ALERT
  1.  ;;*
  1. LR7OB1 ;Update CPRS package reference and status of complete
  1.  D
  1.  . Q:LRSS="AU"  ;Do not update CPRS for Autopsy - AU does not update CPRS
  1.  . NEW LRX,LR
  1.  . S LRX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1.  . Q:'$G(LRX)
  1.  . S LR(4)=$P(LRX,U,4),LR(5)=$P(LRX,U,5)
  1.  . Q:$S('LR(4):1,'LR(5):1,1:0)
  1.  . D NEW^LR7OB1(LR(4),LR(5),"RE",,+LRT)
  1.  ;;;*
  1.  Q
  1.  ;
  1.  ;
  1. DOCS ; Get ordering provider and PCP/attending to send alert
  1.  N LRNUM,LRMSG
  1.  S:$G(LRSF)="" LRSF=63
  1.  D GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$G(LRI),LRSF)
  1.  S (LRNUM,LRQUIT)=1,LRC=0
  1.  F  S LRC=$O(LRDOCS(LRC)) Q:LRC<1  D
  1.  . I $D(LRXQA(+LRDOCS(LRC))) S LRXQA(+LRDOCS(LRC))=LRXQA(+LRDOCS(LRC))_"/"_$P(LRDOCS(LRC),"^",3) Q
  1.  . S LRXQA(+LRDOCS(LRC))=$P(LRDOCS(LRC),"^",3),LRQUIT=0
  1.  ;
  1.  I 'LRQUIT D
  1.  . S LRC=0,LRMSG(LRNUM)="Mandatory Alert will be sent to: ",LRMSG(LRNUM,"F")="!!"
  1.  . F  S LRC=$O(LRDOCS(LRC)) Q:LRC<1  D
  1.  . . S LRNUM=LRNUM+1,LRMSG(LRNUM)=$P(LRDOCS(LRC),"^",2)_"  ["_$P(LRDOCS(LRC),"^",3)_"]"
  1.  . . S LRMSG(LRNUM,"F")=$S(LRNUM>2:"!",1:"")_"?33"
  1.  I LRQUIT S LRMSG(LRNUM)="No Ordering Provider or PCP selected for alert",LRMSG(LRNUM,"F")="!!",LRQUIT=0
  1.  D EN^DDIOL(.LRMSG)
  1.  Q
  1.  ;
  1.  ;
  1. MORE ; Add names or mail groups to the lookup list?
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  W !
  1.  S LRMORE=1
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Send the alert to additional recipients and/or mail groups"
  1.  S X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q")
  1.  S DIR("B")=$S(X=1:"YES",1:"NO")
  1.  S DIR("?")="^D AHELP^LRAPRES1"
  1.  D ^DIR
  1.  I Y=0 S LRMORE=0 Q
  1.  I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1
  1.  Q
  1.  ;
  1.  ;
  1. LOOKUP ; Add additional names or mail groups to alert list.
  1.  N DIC,DIR,DIRUT,DTOUT,DUOUT,LRADL,LRDELETE,X,Y
  1.  S LRQUIT=0
  1.  F  D  Q:LRQUIT
  1.  . W !
  1.  . K DIR
  1.  . S LRDELETE=0
  1.  . S DIR(0)="FO^3:30^I X["".""&(X'?1""G."".E) K X"
  1.  . S DIR("A")="Enter name or mail group"
  1.  . S DIR("?",1)="Prefix selection with '-' to delete a recipient"
  1.  . S DIR("?",2)="Enter lastname,firstname OR G.mailgroup OR ^ to exit"
  1.  . S DIR("?")="Enter '??' for additional help and listing of currently selected recipients."
  1.  . S DIR("??")="^D AHELP2^LRAPRES1"
  1.  . S DIR("PRE")="I '$D(DTOUT),$E(X)=""-"" S X=$E(X,2,9999),LRDELETE=1"
  1.  . D ^DIR
  1.  . I $D(DIRUT) S LRQUIT=1 Q
  1.  . S LRADL="",Y=$$UP^XLFSTR(Y)
  1.  . I Y["." S LRADL=$P(Y,"."),X=$P(Y,".",2)
  1.  . K DIC
  1.  . S DIC(0)="QEZ"
  1.  . S DIC=$S(LRADL="G":3.8,1:200)
  1.  . D ^DIC
  1.  . Q:Y=-1
  1.  . I LRDELETE D
  1.  . . I LRADL="" K XQA($P(Y,"^")) Q
  1.  . . I LRADL="G" K XQA("G."_$P(Y,"^",2))
  1.  . E  D
  1.  . . I LRADL="",'$D(XQA($P(Y,"^"))) S XQA($P(Y,"^"))="Additional User" Q
  1.  . . I LRADL="G" S XQA("G."_$P(Y,"^",2))="Additional Mail Group"
  1.  . K LRMSG
  1.  . S LRMSG=$S(LRADL="G":"Mail group ",1:"User ")_$P(Y,"^",2)_$S(LRDELETE:" deleted from",1:" added to")_" alert list."
  1.  . D EN^DDIOL(LRMSG,"","!!")
  1.  Q
  1.  ;
  1.  ;
  1. ALERT ; Send the alert
  1.  ;
  1.  M XQA=LRXQA
  1.  I '$D(XQA) D EN^DDIOL("Alerts NOT sent - no alert recipients identified!","","!!") Q
  1.  ;
  1.  D LAB^ORB3LAB(DFN,LRDFN,LRI,$G(LRA),LRSS,.XQA)
  1.  ;
  1.  D EN^DDIOL("Alerts have been sent.","","!!")
  1.  Q
  1.  ;
  1.  ;
  1. AHELP ; Help Frame
  1.  N LRI,LRJ,LRMSG
  1.  S LRMSG(1)="Enter either 'Y' or 'N'."
  1.  S LRMSG(2)="If answered 'Yes', you will also have the opportunity to send alerts",LRMSG(2,"F")="!!"
  1.  S LRMSG(3)="to additional recipients and/or mail groups."
  1.  S LRMSG(4)="A mandatory alert is sent to the ordering provider/surgeon and the primary care",LRMSG(4,"F")="!!"
  1.  S LRMSG(5)="provider/attending that this report has been electronically signed and is now"
  1.  S LRMSG(6)="available for viewing."
  1.  S LRJ=6
  1.  D CHELP
  1.  Q
  1.  ;
  1. AHELP2 ; Help frame entry point for additional recipients selection
  1.  ;
  1.  N LRI,LRJ,LRMSG
  1.  S LRMSG(1)="A mandatory alert is sent to the ordering provider/surgeon and the primary care",LRMSG(4,"F")="!!"
  1.  S LRMSG(2)="provider/attending that this report has been electronically signed and is now"
  1.  S LRMSG(3)="available for viewing."
  1.  S LRJ=3
  1.  D CHELP
  1.  Q
  1.  ;
  1.  ;
  1. CHELP ; Display common help
  1.  ;
  1.  I '$D(LRXQA) S LRJ=LRJ+1,LRMSG(LRJ)="No mandatory recipients listed",LRMSG(LRJ,"F")="!!"
  1.  E  D
  1.  . S LRI=0,LRJ=LRJ+1,LRMSG(LRJ)="The current mandatory recipients will be:",LRMSG(LRJ,"F")="!!"
  1.  . F  S LRI=$O(LRXQA(LRI)) Q:LRI<1  S LRJ=LRJ+1,LRMSG(LRJ)=$$NAME^XUSER(LRI,"F")_"  ["_LRXQA(LRI)_"]"
  1.  ;
  1.  I '$D(XQA) S LRJ=LRJ+1,LRMSG(LRJ)="No additional recipients listed",LRMSG(LRJ,"F")="!!"
  1.  E  D
  1.  . S LRI="",LRJ=LRJ+1,LRMSG(LRJ)="The current additional recipients will be:",LRMSG(LRJ,"F")="!!"
  1.  . F  S LRI=$O(XQA(LRI)) Q:LRI=""  S LRJ=LRJ+1,LRMSG(LRJ)=$S(LRI:$$NAME^XUSER(LRI,"F"),1:LRI)_"  ["_XQA(LRI)_"]"
  1.  ;
  1.  D EN^DDIOL(.LRMSG)
  1.  Q
  1.  ;
  1.  ;
  1. RETRACT(LRDFN,LRSS,LRI,LRTIUPTR) ;
  1.  ; Change prior TIU versions of report to RETRACTED status
  1.  N LRROOT,LRIENS,LRFILE,LRTIUP,LRTIUAR,LRERR,LRSTAT,LRTIUX,LREXRR
  1.  I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q
  1.  I LRSS="AU" D
  1.  . S LRROOT="^LR(LRDFN,101,""C""",LRIENS=LRDFN_","
  1.  . S LRFILE=63.101
  1.  I LRSS'="AU" D
  1.  . S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""C"""
  1.  . S LRIENS=LRI_","_LRDFN_","
  1.  . S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
  1.  Q:'$D(@(LRROOT_")"))
  1.  S LRTIUP=0,LRTIUX(.05)=15
  1.  F  S LRTIUP=$O(@(LRROOT_",LRTIUP)"))  Q:LRTIUP'>0!(LRTIUP=LRTIUPTR)  D
  1.  . K LRTIUAR S (LRSTAT,LRERR)=0
  1.  . D EXTRACT^TIULQ(LRTIUP,"LRTIUAR",.LRERR,".05",,,"I")
  1.  . Q:+LRERR
  1.  . M LRSTAT=LRTIUAR(LRTIUP,.05,"I")
  1.  . Q:LRSTAT'=7  ;Quit if current status is not COMPLETED
  1.  . D FILE^TIUSRVP(.LREXRR,LRTIUP,.LRTIUX)
  1.  . ; Update new TIU version of report with previous TIU pointer value
  1.  . N LREXRR,LRTIUX
  1.  . S LRTIUX(1406)=LRTIUP
  1.  . D FILE^TIUSRVP(.LREXRR,LRTIUPTR,.LRTIUX)
  1.  Q
  1.  ;
  1.  ;
  1. CLSSCHK(DUZ,LREND) ; Determine if user has the proper class settings and PROVIDER key
  1.  ;
  1.  N LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH
  1.  ; First, check for PROVIDER key
  1.  I '$D(^XUSEC("PROVIDER",DUZ)) D  Q
  1.  . D EN^DDIOL($C(7)_"Electronic signature not authorized.  Missing PROVIDER key.","","!!")
  1.  . S LREND=1
  1.  ; Next, check the provider class
  1.  ; PROVIDER CL must contain PHYSICIAN, or CYTOTECH only for CY section
  1.  ; or DENTIST for ORAL AND MAXILLOFACIAL PATHOLOGY
  1.  S LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5)
  1.  S LRMTCH=0
  1.  I LRPRCLSS'["PHYSICIAN",LRPRCLSS'["DENTIST" D
  1.  . I LRPRCLSS'["CYTOTECH" S LRMTCH=1
  1.  . I LRSS'="CY" S LRMTCH=1
  1.  I LRMTCH=1 D  Q
  1.  . N LRMSG
  1.  . S LRMSG(1)=$C(7)_"You are not authorized to electronically sign reports.",LRMSG(1,"F")="!!"
  1.  . S LRMSG(2)="PROVIDER CLASS must include PHYSICIAN,"
  1.  . S LRMSG(3)=" or CYTOTECHNOLOGIST for CY SECTIONS ONLY,"
  1.  . S LRMSG(4)=" or DENTIST for ORAL AND MAXILLOFACIAL PATHOLOGY."
  1.  . D EN^DDIOL(.LRMSG)
  1.  . S LREND=1
  1.  ;
  1.  ; Finally, check the person class
  1.  S LRPCSTR=$$GET^XUA4A72(DUZ)
  1.  I LRPCSTR<0 D  Q
  1.  . D EN^DDIOL("PERSON CLASS is inactive or undefined.  Electronic signature is not authorized.","","!!")
  1.  . S LREND=1
  1.  S LRPCEXP=+$P(LRPCSTR,"^",6)
  1.  I LRPCEXP,LRPCEXP<DT D  Q
  1.  . D EN^DDIOL("PERSON CLASS has expired.  Electronic signature is not authorized.","","!!")
  1.  . S LREND=1
  1.  S LRVCDE=$P(LRPCSTR,"^",7),LRMTCH=0
  1.  ;
  1.  ; Correct PERSON Class should match PROVIDER Class
  1.  I LRPRCLSS["PHYSICIAN" D
  1.  . I $E(LRVCDE,1,6)="V11370","123568"[+$E(LRVCDE,7) S LRMTCH=1 Q
  1.  . I $E(LRVCDE,1,6)="V11371","03"[+$E(LRVCDE,7) S LRMTCH=1 Q
  1.  . I $E(LRVCDE,1,6)="V18240","124579"[+$E(LRVCDE,7) S LRMTCH=1 Q
  1.  . I LRVCDE="V182413" S LRMTCH=1
  1.  . ;LR*5.2*540: add MOHS person class
  1.  . I LRVCDE="V180504" S LRMTCH=1
  1.  ;
  1.  I LRPRCLSS["CYTOTECH",LRVCDE="V150113" S LRMTCH=1
  1.  I LRPRCLSS["DENTIST",LRVCDE="V030503" S LRMTCH=1
  1.  ;
  1.  I 'LRMTCH D
  1.  . D EN^DDIOL("Invalid PERSON CLASS.  Electronic Signature is not authorized.","","!!")
  1.  . S LREND=1
  1.  Q