source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPR.m@ 1650

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

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