source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPUTL.m@ 1801

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

initial load of WorldVistAEHR
File size: 8.0 KB
RevLine 
[613]1LRAPUTL ;DALOI/WTY - AP UTILITIES;2/26/01
2 ;;5.2;LAB SERVICE;**259,308**;Sep 27, 1994
3 ;
4 ;Reference to EXTRACT^TIULQ supported by IA #2693
5 ;
6 Q
7ACCYR(LRYROUT,LRYRIN,LRAREA,LRAANM) ;
8 ; Return variable (passed by reference):
9 ; LRYROUT = Accession Year LRAD^LRH(0)
10 ; where LRAD is format 3010000
11 ; LRH(0) is format 2001
12 ; = -1 - Error Condition
13 ; = 0 - No change from default value (LRYRIN)
14 ;
15 ; Input parameters:
16 ; LRYRIN = Default accession year in yyyy format
17 ; LRAREA = Accession Area Mnemonic (ex. AU,CY,EM,SP)
18 ; LRAANM = Accession Area Name (ex. SURGICAL PATHOLOGY)
19 ;
20 S LRYROUT=-1
21 Q:LRAREA=""!(LRYRIN="")!(LRAANM="")
22 N LRYR1,LRYR2
23 W !!,"Data entry for ",LRYRIN," "
24 S %=1 D YN^LRU
25 I %<1 D END Q
26 I %=1 S LRYROUT=0 K LRYRIN,LRAREA,LRAANM Q
27 I %=2 D I Y<1 D END Q
28 .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT
29 .Q:Y<1
30 .S LRYR1=$E(Y,1,3)_"0000",LRYR2=$E(Y,1,3)+1700
31 I '$O(^LRO(68,LRAREA,1,LRYR1,1,0)) D Q
32 .W $C(7),!!,"NO ",LRAANM," ACCESSIONS IN FILE FOR ",LRYR2,!!
33 .S LRYROUT=-1
34 .D END
35 S LRYROUT=LRYR1_U_LRYR2
36 Q
37 ;
38LOOKUP(LRDATA,LRYR1,LRAANM,LRAREA,LRYR2,LRAAN) ;
39 ;Lookup by accession number or patient name
40 K X,Y,LR("CK"),DIR
41 S LRDATA=-1 W !
42 S DIR(0)="FO",DIR("A")="Select Accession Number/Pt name"
43 S DIR("?",1)="Enter the year "_LRYR1_" "_LRAANM_" accession number to"
44 S DIR("?",1)=DIR("?",1)_" be updated"
45 S DIR("?")="or locate the accession by entering the patient name."
46 D ^DIR S LRAN=Y K DIR
47 I LRAN=""!(LRAN[U) D END S LRDATA=-1 Q
48 I LRAN'?1N.N D Q
49 .D PNAME^LRAPDA
50 .I LRAN<1 S LRDATA=-1 Q
51 .S LRDATA=LRDFN,LRDATA(1)=$S('LRAU:LRI,1:"")
52 .D OE1^LR7OB63D
53 D OE1^LR7OB63D
54 W " for "_LRYR1
55 I '$D(^LRO(68,LRAAN,1,LRYR2,1,LRAN,0)) D Q
56 .S MSG="Accession # "_LRAN_" for "_LRYR1_" not in "_LRAANM
57 .D EN^DDIOL(MSG,"","!!") K MSG
58 .S LRDATA=0
59 S X=^LRO(68,LRAAN,1,LRYR2,1,LRAN,0),LRDFN=+X
60 Q:'$D(^LR(LRDFN,0)) S X=^LR(LRDFN,0) D ^LRUP
61 W @IOF
62 W !?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
63 S LRI=+$P($G(^LRO(68,LRAAN,1,LRYR2,1,LRAN,3)),"^",5)
64 I LRAREA'="AU",'$D(^LR(LRDFN,LRAREA,LRI,0)) D Q
65 .W $C(7)
66 .S MSG(1)="Inverse date missing or incorrect in Accession Area file "
67 .S MSG(1)=MSG(1)_"for"
68 .S MSG(1,"F")="!"
69 .S MSG(2)=LRAANM_" Year: "_$E(LRYR2,2,3)_" Accession: "_LRAN
70 .S MSG(2,"F")="!"
71 .D EN^DDIOL(.MSG) K MSG
72 .S LRDATA=-1
73 D DEMGRPH(LRAN,LRAD,LRAA)
74 S LRDATA=LRDFN,LRDATA(1)=LRI
75 Q
76DEMGRPH(LRAN,LRAD,LRAA) ;Demographics
77 N LRIENS,DA,LRIDT,LRQUIT,LRSPECID,LREDT,LRIDT,LRCDT
78 S LRQUIT=0
79 S LRIENS=LRAN_","_LRAD_","_LRAA_","
80 S LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRIENS,15,"E")
81 S LRSPECID=LRSPECID_$$GET1^DIQ(68.02,LRIENS,16)
82 S LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
83 S LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
84 I LREDT S LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
85 W !?5,LRCDT
86 W !?10,LRSPECID,!
87 I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) W !?15,"PCE ENC # "_^("PCE")
88 I $L($G(LRSS)),$O(^LR(LRDFN,LRSS,LRIDT,.1,0)) D
89 .N LRX
90 .W !?5,"Tissue Specimen(s): ",!
91 .S LRX=0 F S LRX=$O(^LR(LRDFN,LRSS,LRIDT,.1,LRX)) Q:LRX<1!(LRQUIT) D
92 ..I $Y>(IOSL-10) D PG Q:$G(LRQUIT) D
93 ...W @IOF,!?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1),!
94 ..W ?15,$P($G(^LR(LRDFN,LRSS,LRIDT,.1,LRX,0)),U),!
95 I $O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) D
96 .W ?5,"Test(s): "
97 .S LRX=0
98 .F S LRX=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX)) Q:LRX<1!($G(LRQUIT)) D
99 ..I $Y>(IOSL-10) D PG Q:$G(LRQUIT) W @IOF
100 ..W ?15,$P($G(^LAB(60,+LRX,0)),U),!
101 S:$G(LRQUIT) LRQUIT=0
102 Q
103GETDOCS(LRDOCS,LRDFN,LRSS,LRI,LRSF) ;Return PCP and provider
104 N LRPF,DFN,LRIENS,LRFLD
105 S:LRSS="AU" LRSF=63
106 I '+$G(LRDFN)!($G(LRSS)="")!('+$G(LRSF)) S LRDOCS=0 Q
107 I "AUSPCYEM"'[LRSS S LRDOCS=0 Q
108 S LRPF=+$$GET1^DIQ(63,LRDFN_",",.02,"I")
109 S DFN=$$GET1^DIQ(63,LRDFN_",",.03,"I")
110 S LRDOCS(1)=0
111 I LRPF=2 D
112 .D INP^VADPT
113 .S LRDOCS(1)=+VAIN(2)
114 S LRIENS=LRDFN_","
115 I LRSS'="AU" S LRIENS=LRI_","_LRIENS,LRFLD=.07
116 S:LRSS="AU" LRFLD=13.5
117 S LRDOCS(2)=$$GET1^DIQ(LRSF,LRIENS,LRFLD,"I")
118 Q
119RELEASE(LRRELEAS,LRDFN,LRSS,LRI) ;
120 ;Determine if report has been released
121 N LRFILE,LRFLDS,LRIENS,LRRELAR,LRCT
122 I '+$G(LRDFN) S LRRELEAS=0 Q
123 I $G(LRSS)=""!("AUSPEMCY"'[LRSS) S LRRELEAS=0 Q
124 I LRSS'="AU",'+$G(LRI) S LRRELEAS=0 Q
125 I LRSS="AU" D
126 .S LRFILE=63,LRFLDS="14.7;14.8",LRIENS=LRDFN_","
127 I LRSS'="AU" D
128 .S LRFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
129 .S LRFLDS=".11;.13;.15"
130 .S LRIENS=LRI_","_LRDFN_","
131 Q:LRFILE=""
132 D GETS^DIQ(LRFILE,LRIENS,LRFLDS,"I","LRRELAR")
133 F LRCT=1:1:$S(LRSS="AU":2,1:3) D
134 .S LRRELEAS(LRCT)=+$G(LRRELAR(LRFILE,LRIENS,$P(LRFLDS,";",LRCT),"I"))
135 Q
136TIUCHK(LRPTR,LRDFN,LRSS,LRI) ;
137 ;Check to see if report is in TIU
138 N LRTREC,LRROOT,LRFILE,LRIENS,LRFLD,LRREL
139 I LRSS=""!("AUSPEMCY"'[LRSS) S LRPTR=0 Q
140 I LRSS="AU" D
141 .S LRROOT="^LR(LRDFN,101,""A"")",LRIENS=LRDFN_","
142 .S LRFILE=63.101
143 I LRSS'="AU" D
144 .S LRROOT="^LR(LRDFN,LRSS,LRI,.05,""A"")"
145 .S LRIENS=LRI_","_LRDFN_","
146 .S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
147 S LRTREC=$O(@(LRROOT),-1)
148 I LRFILE=""!(LRTREC="") S LRPTR=0 Q
149 S LRIENS=LRTREC_","_LRIENS
150 S LRPTR=+$$GET1^DIQ(LRFILE,LRIENS,1,"I")
151 S:LRPTR LRPTR("D")=+$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
152 I LRSS="AU" D
153 .S LRFILE=63,LRIENS=LRDFN_",",LRFLD=14.7
154 I LRSS'="AU" D
155 .S LRFLD=$S(LRSS="CY":9,LRSS="SP":8,LRSS="EM":2,1:"")
156 .Q:LRFLD=""
157 .S LRFILE=+$$GET1^DID(63,LRFLD,"","SPECIFIER"),LRFLD=.11
158 .Q:LRFILE=""
159 .S LRIENS=LRI_","_LRDFN_","
160 S LRREL=+$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"I")
161 I 'LRREL K LRPTR S LRPTR=0 Q
162 I LRREL'=LRPTR("D") K LRPTR S LRPTR=0
163 Q
164ESIGINF(LRESINF,LRDFN,LRSS,LRI) ;Return Esig Info
165 N LRTIUDA,LRESINF1
166 Q:'$D(LRDFN)!('$D(LRSS))
167 Q:LRSS=""!("AUSPEMCY"'[LRSS)
168 D TIUCHK(.LRTIUDA,LRDFN,LRSS,$G(LRI))
169 Q:'+$G(LRTIUDA)
170 D EXTRACT^TIULQ(LRTIUDA,"LRESINF1(""ESIG"")",,,,,,1)
171 Q:'$D(LRESINF1("ESIG",LRTIUDA))
172 S LRESINF(1)=$G(LRESINF1("ESIG",LRTIUDA,1501,"E"))
173 S LRESINF(2)=$G(LRESINF1("ESIG",LRTIUDA,1503,"E"))
174 Q
175NEWLN(LRTEXT,TAB) ;
176 S LCT=$G(LCT)+1,BTAB=0
177 S TAB=+TAB
178 D GLBWRT(LRTEXT,TAB)
179 Q
180GLBWRT(LRTEXT,TAB) ;Write to global
181 D GLB(LCT,TAB,BTAB,LRTEXT,GROOT,.ATAB)
182 S BTAB=ATAB
183 Q
184GLB(LINE,TAB,BTAB,TEXT,ROOT,ATAB) ;
185 ; This subroutine is used to store report text to a global.
186 ; Input variables:
187 ; LINE = Current line number
188 ; TAB = Desired tab position (not required)
189 ; BTAB = Current tab position BEFORE text is stored
190 ; TEXT = Text string to be stored
191 ; ROOT = Global root
192 ;
193 ; Output variables:
194 ; ATAB = Current tab position after text storage
195 ;
196 N LRSPC,LRINC,FTEXT,LRLINE
197 S LRSPC="" F LRINC=1:1:80 S LRSPC=LRSPC_" "
198 S:BTAB="" BTAB=0
199 S:+TAB=0 TAB=BTAB
200 S FTEXT=TEXT
201 I TAB,TAB>BTAB D
202 .S FTEXT=$E(LRSPC,1,TAB-BTAB)_TEXT
203 S:'$D(@(ROOT_"0)")) @(ROOT_"0)")="^^^^"_DT_"^"
204 S LRLINE=LINE,LINE=LINE_",0"
205 S:'$D(@(ROOT_LINE_")")) @(ROOT_LINE_")")=""
206 S @(ROOT_LINE_")")=@(ROOT_LINE_")")_FTEXT
207 S $P(@(ROOT_"0)"),"^",3,4)=LRLINE_"^"_LRLINE
208 S ATAB=TAB+$L(TEXT)
209 Q
210PROVIDR ;Entry of provider taken from PRO^LRCAPES
211 S LREND=0
212 D
213 . N LRPRONM,DIR,DIRUT,DUOUT,X,Y
214 . S LRPRONM=$$GET1^DIQ(200,+$G(LRPRO),.01,"I")
215 . I $L(LRPRONM),$D(^VA(200,"AK.PROVIDER",LRPRONM,+$G(LRPRO)))#2,$$GET^XUA4A72(+$G(LRPRO),DT)>0 S DIR("B")=LRPRONM
216 . S DIR("A")="Provider"
217 . S LRPRO=0,DIR(0)="PO^200:ENMZ"
218 . S DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U),+Y)),$$GET^XUA4A72(+Y,DT)>0"
219 . D ^DIR
220 . I Y>1 S LRPRO=+Y
221 I '$G(LRPRO) D D END^LRCAPES Q
222 . W !?5,"No Active Provider Selected",!
223 . S LRNOP=1
224 . S LRQUIT=1
225 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 D D END^LRCAPES
226 . W !?5,"The accession is corrupt - missing zero node",!
227 . S LRNOP="7^Corrupt Accession"
228 . S LRQUIT=1
229 Q
230REFRRL ;Display informational message on referrals
231 S LRMSG2=$P(^DIC(LRDPF,0),"^")
232 S LRMSG="*** NOTE: This "_LRMSG2_" report will not be stored in TIU,"
233 S LRMSG(1)=$$CJ^XLFSTR(LRMSG,IOM)
234 S LRMSG(1,"F")="!!"
235 S LRMSG=" and therefore, does not have an electronic signature."
236 S LRMSG(2)=$$CJ^XLFSTR(LRMSG,IOM)
237 S LRMSG="A hardcopy signature will be required for this report."
238 S LRMSG(3)=$$CJ^XLFSTR(LRMSG,IOM)
239 D EN^DDIOL(.LRMSG)
240 K LRMSG
241 Q
242PG ;Page break
243 N DIR,DIRUT,DUOUT,DTOUT
244 S DIR(0)="E" D ^DIR
245 I $G(DIRUT) S LRQUIT=1
246 Q
247END ;
248 K LRYRIN,LRAREA,LRAANM
249 Q
Note: See TracBrowser for help on using the repository browser.