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

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

initial load of WorldVistAEHR
File size: 9.3 KB
Line 
1LRAPR ;DALOI/REG/WTY/KLL/CKA - ANAT RELEASE REPORTS ;10/30/01
2 ;;5.2;LAB SERVICE;**72,248,259,317,365**;Sep 27, 1994;Build 9
3 ;
4 N LRESSW
5 D SWITCH
6 I +LRESSW D Q
7 .D ^LRAPRES
8 .D END
9 W !!?27,"Release Pathology Reports",!!
10 D A
11 I '$D(LRSS) D END Q
12 I LRCAPA D G:'$D(X) END
13 .S X=$S(LRSS="CY":"CYTOLOGY REPORTING",LRSS="SP":"SURGICAL PATH REPORTING",1:"")
14 .D:X]"" X^LRUWK
15 I LRSS="AU" D B Q
16 S LRSOP="Z"
17 S DR="S A=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(A,U,3),LRZ(1)=$P(A,U,13),"
18 S DR=DR_"LRZ(2)=$P(A,U,11),LRZ(3)=$P(A,U,2);"
19 S DR=DR_"I 'LRZ W $C(7),!,""No date report completed. "
20 S DR=DR_"Cannot release."" S Y=0;"
21 S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
22 S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"
23 ;Perform supp edit regardless if date rept released since supp rpt
24 ; is added to released report
25 S DR=DR_"D SUPCHK^LRAPR;"
26 S DR=DR_"S DIR(0)=""YA"",DIR(""A"")=""Release report? """
27 S DR=DR_",DIR(""B"")=""NO"" D ^DIR K:Y Y S:$D(Y) Y=0;"
28 S DR=DR_".11////^D NOW^%DTC S X=%;.13////^S X=DUZ;"
29 S DR=DR_"S LRELSD=1 W !!,""Report released..."""
30 D ^LRAPDA
31 D END
32 Q
33 ;
34B ;Autopsy
35 S LRSOP="Z"
36 S DR="S A=$G(^LR(LRDFN,""AU"")) I A="""" S Y=0;"
37 S DR=DR_"S LRZ=$P(A,U,3),LRZ(1)=$P(A,U,16),LRZ(2)=$P(A,U,15),"
38 ;KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE
39 S DR=DR_"LRZ(3)=$P(A,U,10),LRZ(4)=$P(A,U,17);"
40 ;KLL-PROVISIONAL OR DATE REPORT COMPLETED IS REQUIRED
41 S DR=DR_"I 'LRZ(4),'LRZ W $C(7),!,""Provisional date or date report completed required. "
42 S DR=DR_"Cannot release."" S Y=0;"
43 S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
44 S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"
45 ;Perform supp edit regardless if date rept released since supp rpt
46 ; is added to released report
47 S DR=DR_"D SUPCHK^LRAPR;"
48 S DR=DR_"D RELEASE^LRAPR;"
49 S DR=DR_"D NOW^%DTC S LRDTE=%;"
50 S DR=DR_"14.7////^S X=$S(LRZ(2):""@"",1:LRDTE);"
51 S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"
52 S DR=DR_"S:'LRZ(2) LRELSD=1 "
53 S DR=DR_"W !!,""Report "" W:LRZ(2) ""un"" W ""released..."";K LRDTE"
54 D ^LRAPDA
55 D END
56 Q
57EN ;Supplementary Report Entry Point
58 N LRESSW
59 D SWITCH
60 W !!?20,"Release Supplementary Pathology Reports",!
61 ;D A
62 ;Section prompt replaces the line above
63 S LRQUIT=0
64 D SECTION^LRAPRES
65 I '$D(LRSS) D END Q
66 ;Verify User ID has access to release supp. reports
67 S LREND=0
68 I LRESSW D CLSSCHK^LRAPRES1(DUZ,.LREND)
69 Q:LREND
70 ;
71 W !!,"Data entry for ",LRH(0)," "
72 S %=1 D YN^LRU G:%<1 END
73 I %=2 D G:Y<1 END
74 .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT
75 .Q:Y<1 S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700
76 I '$D(^LRO(68,LRAA,1,LRAD,0)) D Q
77 .W $C(7),!!,"NO ",LRAA(1)," ACCESIONS IN FILE FOR ",LRH(0),!!
78W K X,Y,LR("CK") R !!,"Select Accession Number/Pt name: ",LRAN:DTIME
79 G:LRAN=""!(LRAN[U) END
80 I LRAN'?1N.N D G:LRAN<1 END G W
81 .D PNAME^LRAPDA
82 .Q:LRAN<1
83 .D DIE
84 D REST
85 G W
86REST W " for ",LRH(0)
87 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
88 .W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)
89 .W " not in ACCESSION file",!!
90 S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X
91 Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP
92 W !,LRP," ID: ",SSN
93 I LRSS'="AU" D
94 .S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
95 .W !,"Specimen(s):"
96 .S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D
97 ..I $D(^LR(LRDFN,LRSS,LRI,.1,X,0)),$L(^(0)) W !,^(0)
98DIE ;Define default supplementary report
99 N LRFILE,LRIENS,LRIENS1,LRX,LRRLS,LRFDA,LRLKFL,LRDA,LRQUIT,LRNOSP
100 N LRMSG,LRSRFL,LRFDA2,LRSRMD,LRRLM
101 S DIC("B")="",LRNOSP=0
102 I LRSS'="AU" D
103 .S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
104 .S LRIENS1=LRI_","_LRDFN_","
105 .I '+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) S LRNOSP=1 Q
106 .S LRX=0 F S LRX=$O(^LR(LRDFN,LRSS,LRI,1.2,LRX)) Q:'LRX D
107 ..S LRIENS=LRX_","_LRIENS1
108 ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
109 ..;LRSRMD-set to 1 if supp rpt modified and requires release
110 ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
111 ..Q:LRSRFL&('LRSRMD)
112 ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
113 I LRSS="AU" D
114 .S LRFILE=63.324,LRIENS1=LRDFN_","
115 .I '+$P($G(^LR(LRDFN,84,0)),"^",4) S LRNOSP=1 Q
116 .S LRX=0 F S LRX=$O(^LR(LRDFN,84,LRX)) Q:'LRX D
117 ..S LRIENS=LRX_","_LRIENS1
118 ..S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
119 ..;LRSRMD-set to 1 if supp rpt modified and requires release
120 ..S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
121 ..Q:LRSRFL&('LRSRMD)
122 ..S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
123 I LRNOSP D Q
124 .K LRMSG
125 .S LRMSG=$C(7)_"No supplementary reports exist for this accession."
126 .D EN^DDIOL(LRMSG,"","!!")
127 I 'DIC("B") D Q
128 .K LRMSG
129 .S LRMSG=$C(7)_"All supplementary reports have been released."
130 .D EN^DDIOL(LRMSG,"","!!")
131DIE1 ;
132 S (LRQUIT,LRRLM)=0
133 F D Q:LRQUIT
134 .W !
135 .S:LRSS="AU" (LRLKFL,DIC)="^LR(LRDFN,84,"
136 .S:LRSS'="AU" (LRLKFL,DIC)="^LR(LRDFN,LRSS,LRI,1.2,"
137 .S DIC("A")="Select SUPPLEMENTARY REPORT DATE: "
138 .S DIC(0)="AEQM"
139 .D ^DIC K DIC
140 .I Y<1 S LRQUIT=1 Q
141 .S LRDA=+Y
142 .S LRIENS=LRDA_","_LRIENS1
143 .S LRRLS=+$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
144 .;If E-Sign OFF, must check LRRLM. LRRLM=1 if supp rpt has been
145 .; modified and requires release
146 .S LRRLM=+$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
147 .I LRESSW,LRRLS D Q
148 ..W !!,"This supplementary report has already been released.",!
149 .I 'LRESSW,LRRLS D Q:'LRRLM
150 ..I 'LRRLM W !!,"This supplementary rept has already been released.",!
151 .W !
152 .I LRESSW D Q
153 ..D ESIG Q:LRQUIT
154 ..D UPDATE
155 .S DIR("A")="Release supplementary report",DIR(0)="Y",DIR("B")="NO"
156 .D ^DIR K DIR
157 .Q:'Y
158 .D UPDATE
159 .;If E-sign switch OFF and orig report released, must verify all
160 .; supp reports released before release main report.
161 .I LRCKREL,'LRESSW D CHKSUP^LRAPR1
162 Q
163 ;
164A D ^LRAP G:'$D(Y) END
165 Q
166C ;
167 S LRDICS="SPCYEM" D ^LRAP
168 G:'$D(Y) END
169 Q
170S ;from LRAPDA
171 S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^"
172 Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)) S ^(0)=LRT_"^50^^"_DUZ_"^"_LRK,X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
173 S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^"
174 S C=0 F S C=$O(LRT(C)) Q:'C D CAP
175 S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
176 Q
177 ;
178CAP S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^1^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
179 S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1)
180 Q
181 ;
182SWITCH ;Check to see if electronic signature is enabled
183 D GETDATA^LRAPESON(.LRESSW)
184 Q
185ESIG ;Prompt for electronic signature
186 S LRQUIT=0
187 D SIG^XUSESIG
188 I X1="" D
189 .W " SIGNATURE NOT VERIFIED"
190 .S LRQUIT=1
191 Q
192UPDATE ;
193 S LRLKFL=LRLKFL_LRDA_",0)"
194 L +@(LRLKFL):5 I '$T D Q
195 .S LRMSG="This record is locked by another user. "
196 .S LRMSG=LRMSG_"Please wait and try again."
197 .D EN^DDIOL(LRMSG,"","!!")
198 S LRFDA(LRFILE,LRIENS,.02)=1
199 S LRFDA2(LRFILE,LRIENS,.02)="@" ;Set but don't file unless unrel needed
200 ;File signer ID and Date/time of released supp report
201 D CKSIGNR^LRAPR1
202 D FILE^DIE("","LRFDA")
203 W "...Released"
204 L -@(LRLKFL)
205 I LRSS="AU" D
206 .S LRA=^LR(LRDFN,"AU")
207 .S LRAC=$$GET1^DIQ(63,LRDFN_",",14,"I")
208 .S LRI=$P(LRA,U)
209 I LRSS'="AU" D
210 .S LRA=^LR(LRDFN,LRSS,LRI,0)
211 .S LRAC=$$GET1^DIQ(LRSF,LRIENS,.06,"I")
212 D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
213 ;If all supp reports released, and E-Sign switch is ON, proceed to
214 ; release main report
215 S LRCKREL=0
216 S:LRSS'="AU" LRCKREL=$P(^LR(LRDFN,LRSS,LRI,0),"^",11)
217 S:LRSS="AU" LRCKREL=$P(^LR(LRDFN,LRSS),"^",15)
218 I LRCKREL,LRESSW D RELMN
219 Q
220SUPCHK ;Check for unreleased supplementary reports
221 N LRSR,LRSR1,LRSR2
222 S LRSR=0,LRSR1=1
223 I LRSS'="AU" D
224 .Q:'+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
225 .F S LRSR=$O(^LR(LRDFN,LRSS,LRI,1.2,LRSR)) Q:LRSR'>0!('LRSR1) D
226 ..S LRSR1=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2)
227 ..I 'LRSR1 D
228 ...S Y=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U)
229 ...D DD^%DT S LRSR2=Y
230 I LRSS="AU" D
231 .Q:'+$P($G(^LR(LRDFN,84,0)),U,4)
232 .F S LRSR=$O(^LR(LRDFN,84,LRSR)) Q:LRSR'>0!('LRSR1) D
233 ..S LRSR1=+$P(^LR(LRDFN,84,LRSR,0),U,2)
234 ..I 'LRSR1 D
235 ...S Y=+$P(^LR(LRDFN,84,LRSR,0),U)
236 ...D DD^%DT S LRSR2=Y
237 I 'LRSR1 D
238 .W $C(7),!,"Supplementary report "_LRSR2_" has not been released. "
239 .W "Cannot release."
240 .S Y=0
241 Q
242RINFO ;Display release information
243 W $C(7),!,"Report "
244 W:LRZ(2)=1 "has already been "
245 W "released "
246 S Y=LRZ(2)
247 D DD^%DT
248 W:LRZ(2)>1 Y
249 W:LRZ(1)'="" " by "_$P($G(^VA(200,LRZ(1),0)),U)
250 K Y
251 Q
252NMPATH ;Check for missing pathologist name
253 I 'LRZ(3) D
254 .W $C(7),!,"Pathologist name missing. Cannot release."
255 .S Y=0
256 Q
257RELEASE ;Prompt for release/unrelease
258 W ! S DIR(0)="YA",DIR("B")="NO"
259 S:LRZ(2) DIR("A")="Unrelease report? "
260 S:'LRZ(2) DIR("A")="Release report? "
261 D ^DIR
262 K:Y Y
263 I $D(Y) S Y=0
264 Q
265RELMN ;Allow release of main report as long as all supp reports are
266 ; released, and signer is same person for main and supp report(s)
267 ;Make sure all supp reports signed out
268 S LRQT=0
269 D RELCHK^LRAPR1
270 Q:LRQT
271 ;
272 ;Continue with electronic signature and storage in TIU
273 S LRAU=$S(LRSS="AU":1,1:0)
274 I 'LRAU D
275 .S LRPAT=+$$GET1^DIQ(LRSF,LRIENS1,.02,"I")
276 .S LRZ=$$GET1^DIQ(LRSF,LRIENS1,.03,"I")
277 .S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS1,.13,"I")
278 .S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS1,.13)
279 .S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS1,.11,"I")
280 I LRAU D
281 .S LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I")
282 .S LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I")
283 .S LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I")
284 .S LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8)
285 .S LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I")
286 W !!,?25,"*** Main Report Release ***",!
287 D NOW^%DTC S LRNTIME=%
288 D TIUPREP^LRAPRES
289 D STORE^LRAPRES
290 I LRQUIT D FILE^DIE("","LRFDA2") Q
291 D UNRLSE^LRAPR1
292 D RELEASE^LRAPRES
293 I LRQUIT D FILE^DIE("","LRFDA2") Q
294 D OERR^LR7OB63D
295 S LRQUIT=1
296 Q
297END ;
298 D V^LRU
299 Q
Note: See TracBrowser for help on using the repository browser.