source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPRES.m@ 1006

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

initial load of WorldVistAEHR

File size: 8.9 KB
Line 
1LRAPRES ;DALOI/WTY/KLL- AP ESIG RELEASE REPORT;10/30/01
2 ;;5.2;LAB SERVICE;**259,295,317**;Sep 27, 1994
3 ;
4 ;Reference to NEW^TIUPNAPI supported by IA #1911
5MAIN ;
6 N LRMSG,LRDEM,LREND,LRQUIT,LRNTIME,LRPRCLSS,LRVCDE,LRMTCH
7 N LRPCEXP,LRESCPT,LRPCSTR
8 S LRESCPT=0
9 D TITLE
10 I LRQUIT D END Q
11 D CPTCHK
12 F D Q:LRQUIT
13 .S LRQUIT=0
14 .D MENU
15 .Q:LRQUIT
16 .D SECTION
17 .Q:LRQUIT
18 .S LREND=0
19 .I LRSEL="E" S LREND=0 D CLSSCHK^LRAPRES1(DUZ,.LREND)
20 .Q:LREND
21 .D ACCYR
22 .Q:LRQUIT
23 .D ACCPN
24 D END
25 Q
26ACCPN ;Prompt for accesion number or patient name
27 F D Q:LREND
28 .S (LRQUIT,LREND)=0
29 .D CPTCHK
30 .D LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)
31 .Q:'LRDATA
32 .I LRDATA=-1 S LREND=1 Q
33 .S LRDFN=LRDATA,LRI=LRDATA(1)
34 .S LRIENS=LRI_","_LRDFN_","
35 .I LRSEL="E" D Q:LRQUIT
36 ..D RELCHK
37 ..Q:LRQUIT
38 ..D:'LRZ(2) BROWSE
39 ..D ESIG
40 ..Q:LRQUIT
41 ..D NOW^%DTC S LRNTIME=%
42 ..I 'LRZ(2) D TIUPREP,STORE
43 ..Q:LRQUIT
44 ..D RELEASE
45 ..Q:LRQUIT
46 ..D:'LRZ(2) MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
47 ..D OERR^LR7OB63D
48 .I LRSEL="C" D
49 ..Q:$T(CPT^LRCAPES)=""
50 ..S LRPRO=DUZ
51 ..D PROVIDR^LRAPUTL
52 ..Q:LRQUIT
53 ..D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
54 .I LRSEL="V" D
55 ..D DEMARR
56 ..D INIT^LRAPSNMD(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,.LRDEM,1)
57 Q
58TITLE ;Title
59 S LRQUIT=0
60 D CK^LRAP
61 I Y=-1 S LRQUIT=1 Q
62 W @IOF
63 S LRTEXT="Release/Electronically Sign Pathology Reports"
64 S LRMSG(1)=$$CJ^XLFSTR(LRTEXT,IOM)
65 S LRMSG(1,"F")="!!"
66 S LRMSG(2)="",LRMSG(2,"F")="!"
67 D EN^DDIOL(.LRMSG) K LRMSG
68 Q
69CPTCHK ;Determine if CPT is activated
70 Q:$T(ES^LRCAPES)=""
71 S LRESCPT=$$ES^LRCAPES()
72 Q
73DEMARR ;
74 I LRAU D
75 .S LRPRO=$$GET1^DIQ(63,LRDFN_",",13.5,"I")
76 .S LRPRO(1)=$$GET1^DIQ(63,LRDFN_",",13.5)
77 I 'LRAU D
78 .S LRPRO=$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.07,"I")
79 .S LRPRO(1)=$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.07)
80 S LRDEM("SEX")=SEX,LRDEM("DOB")=DOB
81 S LRDEM("AGE")=AGE
82 S LRDEM("SEC")=LRAA(1),LRDEM("PNM")=PNM
83 S LRDEM("SSN")=SSN,LRDEM("PRO")=LRPRO(1)
84 I LRAU D
85 .S LRDEM("DTH")=$P(VADM(6),"^",2)
86 .S LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)
87 .S LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)
88 Q
89MENU ;
90 N DIR,X,Y
91 S DIR(0)="S^"
92 S:LRESCPT DIR(0)=DIR(0)_"C:CPT Coding;"
93 S DIR(0)=DIR(0)_"E:Electronically Sign Reports;V:View SNOMED Codes"
94 S DIR("A")="Selection"
95 D ^DIR
96 I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S LRQUIT=1 Q
97 S LRSEL=Y
98 Q
99SECTION ;Choose Anatomic Pathology section (AU,SP,CY,EM)
100 W !
101 D ^LRAP
102 I '$D(Y)!('$D(LRSS)) S LRQUIT=1 Q
103 S:LRO(68)="EM" LRO(68)="ELECTRON MICROSCOPY"
104 S LRAU=0 ; LRAU = 0 - Not Autopsy
105 S:LRSS="AU" LRAU=1 ; = 1 - Autosy
106 I LRCAPA D Q:LRQUIT
107 .S X=""
108 .S:LRSS="CY" X="CYTOLOGY REPORTING"
109 .S:LRSS="SP" X="SURGICAL PATH REPORTING"
110 .D:X'="" X^LRUWK
111 .S:'$D(X) LRQUIT=1
112 ;
113 S LRSOP="Z"
114 S LRMSG(1)=LRO(68)_" ("_LRABV_")",LRMSG(1,"F")="!?20"
115 S LRMSG(2)="",LRMSG(2,"F")="!"
116 D EN^DDIOL(.LRMSG) K LRMSG
117 Q
118ACCYR ;Determine Accession Year
119 D ACCYR^LRAPUTL(.LRAD1,LRH(0),LRAA,LRO(68))
120 I LRAD1=-1 S LRQUIT=1 Q
121 I LRAD1 S LRAD=$P(LRAD1,U),LRH(0)=$P(LRAD1,U,2)
122 Q
123RELCHK ;Perform series of checks
124 N LRPAT,LRSRLST,LRSRREL
125 S LRQUIT=0
126 I 'LRAU D Q:LRQUIT
127 .S LRPAT=+$$GET1^DIQ(LRSF,LRIENS,.02,"I")
128 .S LRZ=$$GET1^DIQ(LRSF,LRIENS,.03,"I")
129 .S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS,.13,"I")
130 .S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS,.13)
131 .S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS,.11,"I")
132 .I 'LRZ,'LRZ(2) D
133 ..W $C(7)
134 ..S LRMSG="No date report completed. Cannot release."
135 ..D EN^DDIOL(LRMSG,"","!!") K LRMSG
136 ..S LRQUIT=1
137 I LRAU D Q:LRQUIT
138 .I $G(^LR(LRDFN,"AU"))="" D Q
139 ..S LRMSG="No information found for this accession in the "
140 ..S LRMSG=LRMSG_"LAB DATA file (#63)."
141 ..D EN^DDIOL(LRMSG,"","!!") K LRMSG
142 ..S LRQUIT=1
143 .S LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I")
144 .S LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I")
145 .S LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I")
146 .S LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8)
147 .S LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I")
148 .;KLL-CHECK FOR PROVISIONAL DATE OR DATE REPORT COMPLETED
149 .S LRZ(3)=$$GET1^DIQ(63,LRDFN_",",14.9,"I")
150 .I 'LRZ,'LRZ(3) D
151 ..W $C(7)
152 ..S LRMSG="Provisional or date report completed required. Cannot release."
153 ..D EN^DDIOL(LRMSG,"","!!") K LRMSG
154 ..S LRQUIT=1
155 I 'LRPAT,'LRZ(2) D
156 .W $C(7)
157 .S LRMSG="Pathologist or Cytotechnologist entry missing. Cannot release."
158 .D EN^DDIOL(LRMSG,"","!!") K LRMSG
159 .S LRQUIT=1
160 D:'LRZ(2) SUPCHK^LRAPR1
161 Q:LRQUIT
162 I LRZ(2) D Q:LRQUIT
163 .W $C(7)
164 .S LRMSG="Report " S:LRZ(2)=1 LRMSG=LRMSG_"has already been "
165 .S LRMSG=LRMSG_"released "
166 .S Y=LRZ(2) D DD^%DT S:LRZ(2)>1 LRMSG=LRMSG_Y
167 .S:LRZ(1)'="" LRMSG=LRMSG_" by "_LRZ(1.1)
168 .D EN^DDIOL(LRMSG,"","!!") K LRMSG
169 .S:'LRAU LRQUIT=1
170 ;KLL-DON'T ALLOW UNRELEASE IF REPT COMPLETED DATE EXISTS FOR AU
171 I LRZ(2),LRZ S LRQUIT=1
172 S LRMSG="" D EN^DDIOL(LRMSG,"","!") K LRMSG
173 ;Don't allow unrelease if supp report not released for AU
174 I LRZ(2),'LRZ D
175 .S LRSRLST=$P($G(^LR(LRDFN,84,0)),"^",4)
176 .Q:'LRSRLST
177 .S LRSRREL=$P($G(^LR(LRDFN,84,LRSRLST,0)),"^",2)
178 .I 'LRSRREL D
179 ..S LRMSG=$C(7)_"Supplementary report has not been released. "
180 ..S LRMSG=LRMSG_"Cannot use this option."
181 ..D EN^DDIOL(LRMSG,"","!!") K LRMSG
182 ..S LRQUIT=1
183 Q:LRQUIT
184 I LRZ(2),'LRZ D
185 .S DIR(0)="YA",DIR("B")="NO"
186 .S DIR("A")="Unrelease report? "
187 .D ^DIR
188 .I 'Y S LRQUIT=1
189 Q
190BROWSE ;Display the report in the browser
191 S DIR(0)="YA",DIR("B")="YES"
192 S DIR("A")="View the report before signing? "
193 D ^DIR Q:'Y
194 K ^TMP("LRAPBR",$J)
195 S LRMSG="*** Report is being processed. One moment please. ***"
196 S LRMSG=$$CJ^XLFSTR(LRMSG,IOM)
197 D EN^DDIOL(LRMSG,"","!!")
198 D INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,0)
199 Q
200ESIG ;Prompt for electronic signature
201 S LRQUIT=0
202 D SIG^XUSESIG
203 I X1="" D Q
204 .W " SIGNATURE NOT VERIFIED"
205 .S LRQUIT=1
206 Q
207TIUPREP ;
208 K ^TMP("TIUP",$J)
209 S LRMSG="*** Report is being processed"
210 ;Exclude patient files 67, 67.1, 67.2, 67.3, 62.3 from TIU storage
211 I LRDPF'=62.3,LRDPF'[67 S LRMSG=LRMSG_" for storage in TIU"
212 S LRMSG=LRMSG_". One moment please. ***"
213 S LRMSG=$$CJ^XLFSTR(LRMSG,IOM)
214 D EN^DDIOL(LRMSG,"","!!")
215 D INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,1,LRNTIME)
216 Q
217RELEASE ;
218 I 'LRAU D
219 .S LRRC=$$GET1^DIQ(LRSF,LRIENS,.1,"I")
220 .I LRCAPA,'LRAU D C^LRAPSWK
221 .S DR=".11////^S X=LRNTIME;.13////^S X=DUZ"
222 .S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN
223 .;KLL-Set LRA for xref call to LRWOMEN
224 .S LRA=^LR(LRDFN,LRSS,LRI,0)
225 I LRAU D
226 .S DR="14.7////^S X=$S(LRZ(2):""@"",1:LRNTIME);"
227 .S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"
228 .S DIE="^LR(",DA=LRDFN
229 D CK^LRU
230 Q:$D(LR("CK"))
231 D ^DIE
232 D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(LRI))
233 D FRE^LRU
234 S LRMSG="*** Report "
235 I LRZ(2),LRAU S LRMSG=LRMSG_"un"
236 S LRMSG=LRMSG_"released. ***"
237 D EN^DDIOL($$CJ^XLFSTR(LRMSG,IOM),"","!!") K MSG
238 I "CYSP"[LRSS,LRCAPA D WKLD Q
239 ;I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK
240 Q
241STORE ;Store report in TIU
242 N LRTITLE,LRIENS,LRFILE,LRFDA,LRTIUPTR
243 ;Display informational message if referral patient
244 I LRDPF=62.3!(LRDPF[67) D REFRRL^LRAPUTL Q
245 ;KLL-EDIT ADDED FOR MULTIDIVISIONAL LABS,TRANSLATE LRSS TO CORRECT
246 ; NAME TO ENSURE SUCCESSFUL MATCH IN TIU(8925.1)
247 S:LRSS="SP" LRO68="SURGICAL PATHOLOGY"
248 S:LRSS="CY" LRO68="CYTOPATHOLOGY"
249 S:LRSS="EM" LRO68="ELECTRON MICROSCOPY"
250 S:LRSS="AU" LRO68="AUTOPSY"
251 S LRTITLE=$$FIND1^DIC(8925.1,,"O","LR "_LRO68_" REPORT")
252 D NEW^TIUPNAPI(.LRTIUPTR,DFN,DUZ,LRNTIME,LRTITLE,,,,DUZ)
253 I +LRTIUPTR=-1 D Q
254 .S LRMSG="*** Report storage in TIU failed. ***"
255 .S LRMSG=$$CJ^XLFSTR(LRMSG,IOM)
256 .D EN^DDIOL(LRMSG,"","!!")
257 .S LRQUIT=1
258 S LRMSG="*** Report storage in TIU is complete. ***"
259 S LRMSG=$$CJ^XLFSTR(LRMSG,IOM)
260 D EN^DDIOL(LRMSG,"","!!")
261 ;KLL-Calculate checksum of TIU report text
262 S LRVAL="^TIU(8925,"_+LRTIUPTR_",""TEXT"")"
263 S LRCHKSUM=$$CHKSUM^XUSESIG1(LRVAL)
264 ;Store pointer & checksum information in the LAB DATA (#63) file
265 S LRIENS="+1,"_$S('LRAU:LRI_",",1:"")_LRDFN_","
266 S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
267 S:LRFILE="" LRFILE=$S(LRSS="AU":63.101,1:"")
268 S LRFDA(1,LRFILE,LRIENS,.01)=LRNTIME
269 S LRFDA(1,LRFILE,LRIENS,1)=+LRTIUPTR
270 S LRFDA(1,LRFILE,LRIENS,2)=LRCHKSUM
271 D UPDATE^DIE("","LRFDA(1)")
272 D RETRACT^LRAPRES1(LRDFN,LRSS,LRI,+LRTIUPTR)
273 Q
274WKLD ;Capture workload
275 K LRFDA,ERR,IENS,OROUT,ORIEN
276 S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK
277 Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))
278 S RNUM=1
279 S IENS="+"_RNUM_","_LRAN_","_LRAD_","_LRAA_","
280 S FILE=68.04,ORIEN(1)=LRT
281 S LRFDA(1,FILE,IENS,.01)=LRT
282 S LRFDA(1,FILE,IENS,1)=50
283 S LRFDA(1,FILE,IENS,3)=DUZ
284 S LRFDA(1,FILE,IENS,4)=LRK
285 S FILE1=68.14
286 S C=0 F S C=$O(LRT(C)) Q:'C D
287 .S RNUM=RNUM+1
288 .S ORIEN(RNUM)=C
289 .S IENS1="+"_RNUM_","_IENS
290 .S LRFDA(1,FILE1,IENS1,.01)=C
291 .S LRFDA(1,FILE1,IENS1,.02)=1
292 .S LRFDA(1,FILE1,IENS1,.03)=0
293 .S LRFDA(1,FILE1,IENS1,.04)=0
294 .S LRFDA(1,FILE1,IENS1,1)=LRK
295 .S LRFDA(1,FILE1,IENS1,2)=DUZ
296 .S LRFDA(1,FILE1,IENS1,3)=DUZ(2)
297 .S LRFDA(1,FILE1,IENS1,4)=LRAA
298 .S LRFDA(1,FILE1,IENS1,5)=LRAA
299 .S LRFDA(1,FILE1,IENS1,6)=LRAA
300 D UPDATE^DIE("","LRFDA(1)","ORIEN","OROUT")
301 Q
302END ;Clean-up variables and quit
303 K LRAD1,LRDATA,LRAU,LRRDTE,LRTEXT,LRSEL,LRFILE,LRIENS,LRIENS1
304 K LRFDA,ERR,IENS,OROUT,ORIEN,LRTMP
305 K ^TMP("LRAPBR",$J),^TMP("TIUP",$J)
306 D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES
307 D V^LRU
308 Q
Note: See TracBrowser for help on using the repository browser.