source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPRES1.m@ 613

Last change on this file since 613 was 613, checked in by George Lilly, 14 years ago

initial load of WorldVistAEHR
File size: 6.1 KB
Line 
1LRAPRES1 ;DALOI/WTY/KLL/CKA - AP ESIG RELEASE REPORT/ALERT;11/13/01
2 ;;5.2;LAB SERVICE;**259,336,369,365**;Sep 27, 1994;Build 9
3 ;
4 ;Reference to FILE^TIUSRVP supported by IA #3540
5 ;Reference to ^TIULQ supported by IA #2693
6 ;Reference to ^ORB3LAB supported by IA #4287
7 ;Reference to DIC lookup on MAIL GROUP file (#3.8) supported by IA #10111
8 ;
9MAIN(LRDFN,LRSS,LRI,LRSF,LRP,LRAC) ;Main subroutine
10 Q:'$D(LRDFN)!('$D(LRSS))!('$D(LRP))!('$D(LRAC))
11 N LRDOCS,LRMSG,LRC,LRDOCSN,LRNUM,LRADL,LRMORE,LRQUIT,LRXQA
12 N DIR,DIRUT,DTOUT,DUOUT,X,Y,DIC,XQA,XQAMSG
13 S LRQUIT=0
14 I $G(LRAU) D
15 .S LRA=^LR(LRDFN,"AU")
16 .S LRI=$P(LRA,U)
17 D DOCS
18 Q:LRQUIT
19 D MORE
20 I LRMORE D LOOKUP
21 D SEND
22 Q
23DOCS ;GET ORDERING PROVIDER AND PCP TO SEND ALERT
24 W !
25 S:$G(LRSF)="" LRSF=63
26 D GETDOCS^LRAPUTL(.LRDOCS,LRDFN,LRSS,$G(LRI),LRSF)
27 S:LRDOCS(1)=LRDOCS(2) LRDOCS(2)=0
28 F LRC=1:1:2 D
29 .I LRDOCS(LRC) D
30 ..S LRDOCSN(LRC)=$$NAME^XUSER(LRDOCS(LRC),"F")
31 ..I LRDOCSN(LRC)'="" S LRXQA(LRDOCS(LRC))=""
32 S LRNUM=1
33 K LRMSG
34 D
35 .S LRMSG(LRNUM)="Alert will be sent to:",LRMSG(LRNUM,"F")="!!"
36 .I LRDOCS(1) D
37 ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(1),LRMSG(LRNUM,"F")="?24"
38 .I LRDOCS(2) D
39 ..S LRNUM=LRNUM+1,LRMSG(LRNUM)=LRDOCSN(2)
40 ..S LRMSG(LRNUM,"F")=$S(LRDOCS(1):"!",1:"")_"?24"
41 I LRQUIT D
42 .S LRMSG(LRNUM)="No Ordering Provider or PCP for alert"
43 .S LRMSG(LRNUM,"F")="!!"
44 D EN^DDIOL(.LRMSG)
45 Q
46MORE ;Add names or mail groups to the lookup list?
47 N DIR,DIRUT,DTOUT,DUOUT,X,Y
48 W !
49 S LRMORE=1
50 S DIR(0)="Y"
51 S DIR("A")="Send the alert to additional names or mail groups"
52 S X=$$GET^XPAR("USR^DIV^PKG","LRAPRES1 AP ALERT",1,"Q")
53 S X=$S(X=1:"YES",X=0:"NO",1:"NO")
54 S DIR("B")=X
55 D ^DIR
56 I Y=0 S LRMORE=0 Q
57 I $D(DUOUT)!($D(DTOUT)) S LRQUIT=1,LRMORE=0
58 Q
59LOOKUP ;Add additional names or mail groups to alert list.
60 F D Q:LRQUIT
61 .W !
62 .K DIR
63 .;S DIR(0)="F^3:30^I X'?1""U."".E&(X'?1""G."".E) K X"
64 .S DIR(0)="FO^3:30^I X["".""&((X'?1""G."".E)&(X'?1""g."".E)) K X"
65 .S DIR("A")="Enter name or mail group"
66 .S DIR("?")="Enter lastname,firstname OR G.mailgroup OR ^ to exit"
67 .D ^DIR
68 .I $D(DIRUT) S LRQUIT=1 Q
69 .S X=Y,LRADL=""
70 .I Y["." S LRADL=$P(Y,"."),X=$P(Y,".",2)
71 .S Y=$$UP^XLFSTR(Y)
72 .I LRADL="g" S LRADL="G"
73 .K DIC
74 .S DIC(0)="QEZ"
75 .S DIC=$S(LRADL="G":3.8,1:200)
76 .D ^DIC
77 .Q:Y=-1
78 .S:LRADL="" XQA($P(Y,"^"))=""
79 .S:LRADL="G" XQA("G."_$P(Y,"^",2))=""
80 Q
81SEND ;Send the alert
82 ;S XQAMSG=$E(LRP,1,9)_" ("_$E(LRP,1)_VA("BID")_"): Pathology report signed for "_LRAC_"."
83 ;D SETUP^XQALERT
84 M XQA=LRXQA
85 D LAB^ORB3LAB(DFN,LRDFN,LRI,$G(LRA),LRSS,.XQA)
86 I $D(LRADL) D
87 .S LRMSG="Alerts have been sent to the specified additional users."
88 .D EN^DDIOL(LRMSG,"","!!")
89 .K LRMSG
90 Q
91AHELP ;Help Frame
92 K LRMSG
93 S LRMSG(1)="If answered 'Yes', the alert will notify the primary care"
94 S LRMSG(1,"F")="!"
95 S LRMSG(2)="provider and the surgeon/physician that this report has"
96 S LRMSG(3)="been electronically signed and is now available for"
97 S LRMSG(4)="viewing. You will also have the opportunity to send the"
98 S LRMSG(5)="alert to additional names or mail groups."
99 D EN^DDIOL(.LRMSG)
100 Q
101RETRACT(LRDFN,LRSS,LRI,LRTIUPTR) ;
102 ;Change prior TIU versions of report to RETRACTED status
103 N LRROOT,LRIENS,LRFILE,LRTIUP,LRTIUAR,LRERR,LRSTAT,LRTIUX,LREXRR
104 I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q
105 I LRSS="AU" D
106 .S LRROOT="^LR(LRDFN,101,""C""",LRIENS=LRDFN_","
107 .S LRFILE=63.101
108 I LRSS'="AU" D
109 .S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""C"""
110 .S LRIENS=LRI_","_LRDFN_","
111 .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
112 Q:'$D(@(LRROOT_")"))
113 S LRTIUP=0,LRTIUX(.05)=15
114 F S LRTIUP=$O(@(LRROOT_",LRTIUP)")) Q:LRTIUP'>0!(LRTIUP=LRTIUPTR) D
115 .K LRTIUAR S (LRSTAT,LRERR)=0
116 .D EXTRACT^TIULQ(LRTIUP,"LRTIUAR",.LRERR,".05",,,"I")
117 .Q:+LRERR
118 .M LRSTAT=LRTIUAR(LRTIUP,.05,"I")
119 .Q:LRSTAT'=7 ;Quit if current status is not COMPLETED
120 .D FILE^TIUSRVP(.LREXRR,LRTIUP,.LRTIUX)
121 .;Update new TIU version of report with previous TIU pointer value
122 .N LREXRR,LRTIUX
123 .S LRTIUX(1406)=LRTIUP
124 .D FILE^TIUSRVP(.LREXRR,LRTIUPTR,.LRTIUX)
125 Q
126CLSSCHK(DUZ,LREND) ;Determine if user has the proper class settings and
127 ;PROVIDER key
128 N LRMSG,LRPRCLSS,LRPCEXP,LRVCDE,LRPCSTR,LRMTCH
129 ;First, check for PROVIDER key
130 I '$D(^XUSEC("PROVIDER",DUZ)) D Q
131 .K LRMSG S LRMSG=$C(7)_"Electronic signature not authorized. Missing "
132 .S LRMSG=LRMSG_"PROVIDER key."
133 .D EN^DDIOL(LRMSG,"","!!")
134 .K LRMSG S LREND=1
135 ;Next, check the provider class
136 S LRPRCLSS=$$GET1^DIQ(200,DUZ_",",53.5)
137 ;PROVIDER CL MUST CONTAIN PHYSICIAN, OR CYTOTECH ONLY FOR CY SECTION
138 ;OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY
139 S LRMTCH=0
140 I LRPRCLSS'["PHYSICIAN",LRPRCLSS'["DENTIST" D
141 .I LRPRCLSS'["CYTOTECH" S LRMTCH=1
142 .I LRSS'="CY" S LRMTCH=1
143 I LRMTCH=1 D Q
144 .K LRMSG
145 .S LRMSG(1)=$C(7)_"You are not authorized to electronically sign "
146 .S LRMSG(1)=LRMSG(1)_"reports."
147 .S LRMSG(1,"F")="!!"
148 .S LRMSG(2)="PROVIDER CLASS must include PHYSICIAN,"
149 .S LRMSG(2,"F")="!"
150 .S LRMSG(3)=" OR CYTOTECHNOLOGIST FOR CY SECTIONS ONLY,"
151 .S LRMSG(3,"F")="!"
152 .S LRMSG(4)=" OR DENTIST FOR ORAL AND MAXILLOFACIAL PATHOLOGY."
153 .S LRMSG(4,"F")="!"
154 .D EN^DDIOL(.LRMSG) K LRMSG
155 .S LREND=1
156 ;Finally, check the person class
157 S LRPCSTR=$$GET^XUA4A72(DUZ) ;Supported reference #1625
158 I LRPCSTR<0 D Q
159 .K LRMSG
160 .S LRMSG="PERSON CLASS is inactive or undefined. Electronic signature"
161 .S LRMSG=LRMSG_" is not authorized."
162 .D EN^DDIOL(LRMSG,"","!!")
163 .K LRMSG
164 .S LREND=1
165 S LRPCEXP=+$P(LRPCSTR,"^",6)
166 I LRPCEXP D Q
167 .K LRMSG
168 .S LRMSG="PERSON CLASS has expired. Electronic signature"
169 .S LRMSG=LRMSG_" is not authorized."
170 .D EN^DDIOL(LRMSG,"","!!") K LRMSG
171 .S LREND=1
172 S LRVCDE=$P(LRPCSTR,"^",7),LRMTCH=0
173 ;CORRECT PERSON CLASS SHOULD MATCH PROVIDER CLASS
174 I LRPRCLSS["PHYSICIAN" D
175 .I $E(LRVCDE,1,6)="V11370","123568"[+$E(LRVCDE,7) S LRMTCH=1
176 .I $E(LRVCDE,1,6)="V11371","03"[+$E(LRVCDE,7) S LRMTCH=1
177 .I $E(LRVCDE,1,6)="V18240","124579"[+$E(LRVCDE,7) S LRMTCH=1
178 .I LRVCDE="V182413" S LRMTCH=1
179 I LRPRCLSS["CYTOTECH" D
180 .I LRVCDE="V150113" S LRMTCH=1
181 I LRPRCLSS["DENTIST" D
182 .I LRVCDE="V030503" S LRMTCH=1
183 I 'LRMTCH D
184 .K LRMSG
185 .S LRMSG="Invalid PERSON CLASS. Electronic Signature is not "
186 .S LRMSG=LRMSG_"authorized."
187 .D EN^DDIOL(LRMSG,"","!!")
188 .K LRMSG
189 .S LREND=1
190 Q
Note: See TracBrowser for help on using the repository browser.