source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRVR4.m@ 1311

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

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1LRVR4 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ; 24 Jan 2004
2 ;;5.2;LAB SERVICE;**14,42,121,153,221,263,279,283,287,286,330**;Sep 27, 1994
3 I $D(LRSBCOM) D
4 . N LRX
5 . S LRX=0
6 . F S LRX=$O(LRSBCOM(LRX)) Q:LRX="" S ^LAH(LRLL,1,LRSQ,1,LRX)=LRSBCOM(LRX)
7 K %,LRSBCOM
8 D LOOP
9 Q
10 ;
11 ;
12LOOP ;
13 S LRLCT=0
14 W !!,PNM," SSN: ",SSN," "
15 I LRDPF=2 W " LOC: ",$S(LRWRD'="":LRWRD,1:$S($L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7)):$P(^(0),U,7),1:"??"))
16 W !,"Pat Info: ",$P($G(^LR(LRDFN,.091)),U)
17 W ?34," Sex: ",$S(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
18 W ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
19 S LRPRAC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,8)
20 I LRPRAC>0,LRPRAC=+LRPRAC D GETS^DIQ(200,LRPRAC_",",".01;.132;.137;.138","E","LRPRAC(LRPRAC)","LRERR")
21 W !,"Provider: "
22 S LRLCT=LRLCT+3
23 I LRPRAC'="",'$D(LRPRAC(LRPRAC,200)) W LRPRAC
24 I LRPRAC,$D(LRPRAC(LRPRAC,200)) D
25 . W LRPRAC(LRPRAC,200,LRPRAC_",",.01,"E"),?40," Voice pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.137,"E")
26 . W !," Phone: ",LRPRAC(LRPRAC,200,LRPRAC_",",.132,"E"),?38," Digital pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.138,"E")
27 . S LRLCT=LRLCT+1
28 ;
29 N PRAC,PR
30 D PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
31 I $O(PRAC(0)) D
32 . S PR=0
33 . F S PR=$O(PRAC(PR)) Q:PR<1 I $D(^VA(200,PR,0)) W !?14,$P(^(0),"^") S LRLCT=LRLCT+1
34 ;
35 W ! S LRNX=0,LRVRM=1,Z=LRCDT,LRLCT=LRLCT+1
36 I $P(Z1,U,7)'="" W !,"VOLUME: ",$P(Z1,U,7) S LRLCT=LRLCT+1
37 S LRACC=$P(Z1,U,6)
38 W !,"ACCESSION:",?30,$P(Z2,U,6),?44," ",LRACC
39 W !,LRPANEL,?30,LRDAT(2),?44," ",LRDAT
40 S LRLCT=LRLCT+2
41 I $D(LRALERT),LRALERT<($P(LRPARAM,U,20)+1) D
42 . W !?15 W:$E(IOST,1,2)="C-" @LRVIDO
43 . W "Test ordered "_$P($G(^LAB(62.05,+LRALERT,0)),U)
44 . W:$E(IOST,1,2)="C-" @LRVIDOF,$C(7)
45 . S LRLCT=LRLCT+1
46 I $D(LRGVP) D V20 Q
47 I ($O(LRSB(0))<1!$D(LRPER))&'$D(LRNUF) D LRSBCOM G EDIT
48 K LRNUF
49 D V20:'$D(LRPER) Q:$O(LRSB(1))<1 G:LREDIT EDIT
50V36 ;
51 S LRTEC=$S($D(^LRO(68,LRAA,1,LRAD,2)):$P(^(2),U),1:$S($D(LRUSI):LRUSI,1:"")),LREDIT=0
52 ;
53V3 ;
54 D LRSBCOM,DCOM^LRVERA
55 ;
56 ; If entering reference lab results only allow editing comments/workload
57 K DIR
58 S LRLCT=0
59 I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) D
60 . S DIR(0)="SAO^C:Comments;W:Workload"
61 . S DIR("A")="SELECT ('C' for Comments, 'W' Workload): "
62 E D
63 . S DIR(0)="SAO^E:Edit;C:Comments;W:Workload"
64 . S DIR("A")="SELECT ('E' to Edit, 'C' for Comments, 'W' Workload): "
65 D ^DIR
66 I $D(DIRUT) S X="^" G V37
67 S X=Y
68 S:$E(X)="E" LREDIT=1,X=""
69 I X="C" D COM G LOOP
70 ;
71 I $E(X)="W" D G LOOP
72 . I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D STD^LRCAPV,EN^LRCAPV S LREND=0 Q
73 . W !?10,"Workload is not activated. "
74 ;
75 S X=$S(X="@":"",X="":LRTEC,1:X),LRTEC=X
76 S:'$D(^LRO(68,LRAA,1,LRAD,2)) ^(2)="" S ^(2)=X_U_$P(^(2),U,2,99)
77 G EDIT:LREDIT
78V37 Q ;LEAVE LRVR4, BACK TO LRVR3
79 ;
80 ;
81V25 ;
82 I LRVF K LRSB(LRSB),LRM(LRSB) Q
83 I '$D(LRSB(LRSB)) S LRSB(LRSB)=^LR(LRDFN,LRSS,LRIDT,LRSB) Q
84 Q
85 ;
86 ;
87V20 S LRNX=$O(LRORD(LRNX)) G V35:LRNX<1 D SUBS G V20:'LRTS
88 I $D(^LR(LRDFN,LRSS,LRIDT,LRSB)),^(LRSB)'["pending" D V25 G:LRVF V20
89 I "CH"'=LRSS G V20
90 D V25^LRVR5
91 W !,$P(^LAB(60,+LRTS,0),U)
92 S X1=""
93 I $D(^LR(LRDFN,LRSS,LRLDT,LRSB)) D
94 . S X1=$P(^(LRSB),U),(LRDL,X)=X1
95 . I $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET" D
96 . . S X=$$EXTERNAL^DILFD(63.04,LRSB,"",X1)
97 . . I X="" S X=X1
98 . W:X'="" ?30,@LRFP
99 S X="",LRFLG=""
100 I $D(LRSB(LRSB)),$P(LRSB(LRSB),U)'="" D
101 . N LRX
102 . K LRNOVER(LRSB)
103 . S (LRDL,LRX,X)=$P(LRSB(LRSB),U)
104 . I $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET" D
105 . . S X=$$EXTERNAL^DILFD(63.04,LRSB,"",LRX)
106 . . I X="" S X=LRX
107 . W ?44," ",@LRFP," "
108 . S X=LRX,Y=0
109 . K LRQ
110 . I X="" Q
111 . I (X="canc")!(X="comment")!(X="pending") D Q
112 . . W LRFLG,?56," ",$P(LRNG,U,7)
113 . . S LREDIT=0
114 . I LRDEL'="" S LRQ=1,LRVRM=11 X LRDEL S LRVRM=1 K LRQ
115 . D RANGE
116 . W LRFLG,?56," ",$P(LRNG,U,7) S:X'="" LREDIT=0
117 I '$D(LRNUF) S LRLCT=LRLCT+1 S:$X>80 LRLCT=LRLCT+1 D:LRLCT>22 WT G:$G(Y)'="^" V20
118 ;
119V35 ;
120 D LRCFL:LRCFL]""
121 K LRNUF
122 Q
123 ;
124 ;
125LRCFL ;
126 S LREXEC=LRCFL D ^LREXEC:LRCFL[""
127 D:LRLCT>22 WT
128 Q
129 ;
130 ;
131EDIT ;
132 S LROUT=1 D ^LRVR5
133 S LRVRM=1,LREDIT=0
134 G LRCFL:LROUT!$D(LRPER),LOOP
135 ;
136 ;
137RANGE ;
138 ; If results from another system, use flags returned with results
139 ; and set LRNG,LRNGS with normals from message.
140 ; Check for LRDUZ(2) set for performing lab or performing lab set (piece 9) in LRSB(LRSB) array.
141 I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) S Y=X D PLNR,CKPLNR,RQ Q
142 I $P(LRSB(LRSB),"^",9),DUZ(2)'=$P(LRSB(LRSB),"^",9) S Y=X D PLNR,CKPLNR,RQ Q
143 ;
144 D RANGE^LRVER4,RQ
145 Q
146 ;
147 ;
148RQ S X=Y
149NR I $D(LRSB(LRSB))#2 D
150 . N I,LRX,LRY
151 . I $P(X,U)="" S LRSB(LRSB)="" Q
152 . S $P(LRSB(LRSB),U)=X
153 . S $P(LRSB(LRSB),U,2)=LRFLG
154 . S $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
155 . I $P(LRSB(LRSB),U,9)="" S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),$G(DUZ(2)):DUZ(2),1:"")
156 . S LRX=$$TMPSB^LRVER1(LRSB),LRY=$P(LRSB(LRSB),U,3)
157 . F I=1:1:$L(LRX,"!") I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,"!",I)
158 . S $P(LRSB(LRSB),U,3)=LRY
159 . I $P($P(LRSB(LRSB),U,3),"!")="" D RONLT^LRVER3
160 . S LRX=LRNGS,LRY=$P(LRSB(LRSB),U,5)
161 . F I=1:1:$L(LRX,U) I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,U,I)
162 . S $P(LRSB(LRSB),U,5)=LRY
163 Q
164 ;
165 ;
166PLNR ; Performing lab normal ranges, use instead of current local ranges
167 ; Retrieve from results when "NPC" node = 2 or greater
168 ; and set LRNG and LRNGS with normals from HL7 message/interface.
169 N I,LRY
170 I +$G(^LR(LRDFN,LRSS,LRIDT,"NPC"))<2 Q
171 S LRY=$P($G(LRSB(LRSB)),"^",5)
172 S $P(LRNGS,"^")=$P(LRY,"!")
173 F I=2:1:5,11,12 D
174 . ; enclose in quotes if not numeric
175 . I I<6,$P(LRY,"!",I)'?.N.1".".N S $P(LRY,"!",I)=$C(34)_$P(LRY,"!",I)_$C(34)
176 . S $P(LRNGS,"^",I)=$P(LRY,"!",I),$P(LRNG,"^",I)=$P(LRY,"!",I),@("LRNG"_I)=$P(LRY,"!",I)
177 S $P(LRNG,"^",7)=$P(LRY,"!",7),$P(LRNGS,"^",7)=$P(LRY,"!",7)
178 Q
179 ;
180 ;
181CKPLNR ; Check performing lab normal ranges and set abnormal flag
182 ; based on HL7 messages/interface.
183 S LRFLG=$P(LRSB(LRSB),"^",2)
184 I '$D(LRQ),$E(LRFLG,2)="*" D DISPFLG^LRVER4
185 Q
186 ;
187 ;
188SUBS D SUBS^LRVER4
189 Q
190 ;
191 ;
192WT D WT^LRVER4
193 Q
194 ;
195 ;
196COM ;from LRVR5
197 Q:$D(LRGVP)!('$D(LRLABKY))
198 D DCOM^LRVERA
199 K DR,DA,DIE
200 S DIE="^LR("_LRDFN_",""CH"",",DA=LRIDT,DA(1)=LRDFN,DR=.99 D ^DIE
201 Q
202 ;
203 ;
204LRSBCOM ;Display/store comments from the instrument
205 N LRSBCOM,LRI
206 S LRI=0
207 F S LRI=$O(^LAH(LRLL,1,LRSQ,1,LRI)) Q:LRI="" D
208 . S LRSBCOM=^LAH(LRLL,1,LRSQ,1,LRI)
209 . I $P(LRSBCOM,"^",2) Q ; Already been processed
210 . D LRSBCOM1
211 . S $P(^LAH(LRLL,1,LRSQ,1,LRI),U,2)=1 ; Mark as processed
212 I $G(LRQUIET) Q
213 W !
214 S LRLCT=$G(LRLCT)+1 D:LRLCT>22 WT
215 Q
216 ;
217 ;
218LRSBCOM1 ; Store instrument comments in file #63
219 ; Check for duplicate comments in ^LAH and ^LR globals
220 N LRDUP,LRERR,LRI,LRNOECHO,LRNOEXPD,LRX,LRY
221 ;
222 ; Don't echo comments/don't expand comment using lab description file.
223 ; Used by LRNUM - called from input transform of #.01 field.
224 S LRNOECHO=0,LRNOEXPD=1
225 ;
226 ; Check for duplicates - comment stripped if spaces, force to upper case unless
227 ; flag set to store duplicates (Field #2.2 of PROFILE multiple in file #68.2)
228 S LRDUP=0
229 I '$P($G(^LRO(68.2,LRLL,10,+$G(LRPROF),0)),U,4) D
230 . S LRI=0,LRY=$TR(LRSBCOM," ",""),LRY=$$UP^XLFSTR(LRY)
231 . F S LRI=$O(^LR(LRDFN,"CH",LRIDT,1,LRI)) Q:'LRI D Q:LRDUP
232 . . S LRX=$P($G(^LR(LRDFN,"CH",LRIDT,1,LRI,0)),U)
233 . . S LRX=$TR(LRX," ",""),LRX=$$UP^XLFSTR(LRX)
234 . . I LRX=LRY S LRDUP=1
235 I LRDUP=1 Q ; Duplicate comment
236 D FILECOM(LRDFN,LRIDT,LRSBCOM)
237 I $G(LRQUIET) Q
238 W !,"Inst Comments: "_LRSBCOM
239 S LRLCT=$G(LRLCT)+1 D:LRLCT>10 WT
240 Q
241 ;
242 ;
243FILECOM(LRDFN,LRIDT,LRCMT) ; File comment in field #99
244 ; Call with LRDFN = ien of patient in file #63
245 ; LRIDT = ien of specimen date/time
246 ; LRCMT = comment to store
247 ;
248 N LRFDA,LRERR
249 S LRFDA(2,63.041,"+2,"_LRIDT_","_LRDFN_",",.01)=LRCMT
250 D UPDATE^DIE("","LRFDA(2)","","LRERR(2)")
251 Q
Note: See TracBrowser for help on using the repository browser.