source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRVER5.m@ 1384

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1LRVER5 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ;2/7/91 12:04
2 ;;5.2;LAB SERVICE;**42,153,283,286**;Sep 27, 1994
3 ;
4 I $G(LRNDISP) D
5 . S LRNX=0
6 . N LRX F S LRNX=$O(LRORD(LRNX)) Q:LRNX<1 S LRX(LRORD(LRNX))=""
7 . S LRX=0 F S LRX=$O(LRSB(LRX)) Q:LRX<1 K:'$D(LRX(LRX)) LRSB(LRX),LRSA(LRX)
8 ;
9 ; Check for amended results that have arrived via an HL7 interface.
10 ; Only allow amended results to be verified during this session.
11 I $D(^LAH("LA7 AMENDED RESULTS",LRUID)) D
12 . S LRNX=0
13 . F S LRNX=$O(LRORD(LRNX)) Q:'LRNX I '$D(^LAH("LA7 AMENDED RESULTS",LRUID,LRORD(LRNX))) K LRORD(LRNX)
14 . S LRNX=0
15 . F S LRNX=$O(LRSB(LRNX)) Q:'LRNX I '$D(^LAH("LA7 AMENDED RESULTS",LRUID,LRNX)) K LRSB(LRNX),LRSA(LRNX)
16 ;
17 S LRNX=0,LRVRM=12
18 ;
19V40 S LRNX=$O(LRORD(LRNX)) G V44:LRNX<1 D LRSUBS
20 ;
21 ; Check if changing performing lab.
22 I $P($G(LRSB(LRSB)),"^",9),'$$PLOK^LRVERA($P(LRSB(LRSB),"^",9),$G(LRDUZ(2)),DUZ(2),LRTS) G V40
23 ;
24 D V25
25 ;
26V42 ;
27 ;
28 S (LRDL,SX,X)=$P($G(LRSB(LRSB)),U),LRDVF=0,LREDIT=0
29 S:X=""&(LRDV'="") X=LRDV,LRDVF=1 ; default value
30 S LRTEST=$P(^LAB(60,LRTS,0),U)
31 K LRNOVER(LRSB)
32 ;
33Q42 ;
34 ;
35 ; Check for amended results that have arrived via an HL7 interface.
36 I $D(^LAH("LA7 AMENDED RESULTS",LRUID,LRSB)) D G:SX'=X!($G(LRAMEND(LRSB))) V45
37 . W !,LRTEST," " W:X'="" @LRFP
38 . D AMEND Q:$G(LRAMEND(LRSB))
39 . I SX=X W !,LRTEST," " W:X'="" @LRFP
40 ;
41 ; If entering results from a reference lab and not using normal/units
42 ; from file #60 then ask user for these values otherwise display
43 ; current file #60 values.
44 I $G(LRDUZ(2)),LRDUZ(2)'=DUZ(2) D
45 . I $G(^LAB(60,+LRTS,1,+$G(LRSPEC),.1)) D Q
46 . . D V25
47 . . W !!,"Current Ref Range: ",LRNG2,"-",LRNG3," Units: ",$P(LRNG,"^",7)
48 . . I LRNG4="",LRNG5="" Q
49 . . W !," Critical Low: ",LRNG4," Critical High: ",LRNG5
50 . N LRX,LRY
51 . D ASKPLNR,NORM
52 . S LRX=$P(LRNGS,"^",2,5),LRX=$TR(LRX,"^","!")
53 . S LRY=$P($G(LRSB(LRSB)),"^",5),$P(LRY,"!",2,5)=LRX
54 . S $P(LRSB(LRSB),"^",5)=LRY
55 ;
56 W !,LRTEST," " W:X'="" @LRFP
57 R "//",X:DTIME
58 I X'?.ANP W $C(7)," No Control Characters allowed." G V42
59 S:$L($G(SX))&(X="") X=SX,LRDVF=1
60 S LRDL=X I X=""&LRDVF S (LRD,X)=LRDV G V45
61Q43 G V40:X="",V45:X'["^",V44:X="^",LROUT:X="^^"
62 ;
63V43 S X=$P(X,U,2),DIC="^LAB(60,",DIC(0)="EOQZ" D ^DIC G:Y<1 Q42
64 S LRPLOC=$P(Y(0),U,5),LRSSQ=$P(LRPLOC,";",1),LRSB=$P(LRPLOC,";",2),LRTS=+Y
65 I LRSSQ="" W !,"Not in this group" G LROUT
66 I LRSS'=LRSSQ!'$D(^TMP("LR",$J,"TMP",LRSB)) W !,"Not in this group" G LROUT
67 S LRNX=0
68 F S LRNX=$O(LRORD(LRNX)) Q:LRNX<1 Q:LRSB=LRORD(LRNX)
69 I LRNX,LRSB=LRORD(LRNX) D LRSUBS,V25 G V42
70 ;
71V44 K SX
72 D COM^LRVER4
73 S LRNUF=1 S:LRVF LRSA=1
74 Q
75 ;
76V45 ;
77 K LRSKIP
78 I X="@" D G V46
79 . K:'$G(LRVF) ^LR(LRDFN,LRSS,LRIDT,LRSB)
80 . S X=$S($G(LRVF)&($D(LRSB(LRSB)))&('$D(LRM(LRSB))):"comment",$D(LRM(LRSB)):"pending",$D(LRSA(LRSB)):"canc",1:"")
81 . S $P(LRSB(LRSB),"^")=X,$P(LRSB(LRSB),"^",2)=""
82 ;
83 S LRXD=U_$P(^LAB(60,LRTS,0),U,12),LRXDP=LRXD_"0)",LRXDP=@LRXDP
84 X:'(X="*"!($E(X)="?")!(X="C")!(X="#")!(X="canc")!(X="pending")) $P(LRXDP,U,5,99)
85 I '$D(X)#2 D HELP G V42
86 I $D(X)#2,X["?" D HELP G:'($P(LRXDP,U,2)["S") V42
87 I $D(X)#2,$P(LRXDP,U,2)["S",X'="*",X'="#",X'="canc",X'="pending" D LRSET G:'$D(X)#2 V42
88 I $D(X)#2,X="C",$P(LRXDP,U,2)'["S" D COMP G V42
89 ;
90V46 ;
91 G V42:'$D(X)#2
92 I LRVF,$D(LRSB(LRSB)),$D(LRSA(LRSB)) S LRSA(LRSB,1)=LRTEST
93 S X1=$S($D(^LR(LRDFN,LRSS,+LRLDT,LRSB)):$P(^(LRSB),U),1:"")
94 S:X="*" X="canc" S:X="#" X="comment"
95 ;
96 I '$G(LRAMEND(LRSB)) S LRFLG=""
97 S Y=0 X:LRDEL'="" LRDEL
98 I '$G(LRAMEND(LRSB)) D RANGE^LRVER4
99 ;
100 S:$P(X,U)="" $P(LRSB(LRSB),U)=""
101 I $P(X,U)'="" D
102 . S $P(LRSB(LRSB),U)=X,$P(LRSB(LRSB),U,2)=LRFLG
103 . S LRX=$$TMPSB^LRVER1(LRSB),LRY=$P(LRSB(LRSB),U,3)
104 . F I=1:1:$L(LRX,"!") I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,"!",I)
105 . S $P(LRSB(LRSB),U,3)=LRY
106 . I $P($P(LRSB(LRSB),U,3),"!")="" D RONLT^LRVER3
107 . D
108 . . I '$D(LRSA(LRSB))#2 D Q
109 . . . S $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
110 . . . S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
111 . . S:'$P(LRSB(LRSB),U,4) $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
112 . S $P(LRSB(LRSB),U,5)=$TR(LRNGS,U,"!")
113 . S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
114 G:$D(LRNUF) V44 K LRNUF G V40:'$D(LRSKIP) S X=LRSKIP G Q43:X["^",V40
115 ;
116 ;
117RANGE ;
118 S $P(LRSB(LRSB),"^")=X
119 ; If previous results from another laboratory then use normals and units
120 ; associated with those results.
121 D
122 . I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) D PLNR^LRVR4 Q
123 . I $P(LRSB(LRSB),"^",9),DUZ(2)'=$P(LRSB(LRSB),"^",9) D PLNR^LRVR4
124 D RANGE^LRVER4
125 Q
126 ;
127 ;
128LRSUBS ; From LRVR5
129 S LRSB=LRORD(LRNX),LRTS=$S($D(^TMP("LR",$J,"TMP",LRSB))#2:^(LRSB),1:0)
130 Q
131 ;
132 ;
133LRSET ; from above and LRVR5
134 ;
135 N I,LRERR,RESULT
136 D CHK^DIE(63.04,LRSB,"EH",X,.RESULT,"LRERR")
137 ;
138 I RESULT'="^" S X=RESULT W " ",RESULT(0)
139 ;
140 I RESULT="^" D
141 . F I=1:1:LRERR("DIHELP") W !,LRERR("DIHELP",I)
142 . K X
143 ;
144 Q
145 ;
146 ;
147COMP ; from LRVR5
148 S X="^%ET",@^%ZOSF("TRAP")
149 R !,"Enter your computation: ",C:DTIME
150 Q:"^"[C G CH:C="?"!(C["""") S C=$P(C," ",1)
151 S X="TRAP^LRVER5",@^%ZOSF("TRAP") D ^DIM S X="W "_C
152 I '$D(X)#2 W !,"Something's wrong with the syntax." G CH
153 F I=1:1:$L(C) I $E(C,I)?1A S I=.9 Q
154 G CH:I=.9,CH:C["/0",CH:C["\0" W !," equals ",@C G COMP
155TRAP ;
156 W !!,"Error in your mathematical formular ",!
157CH W !,"Enter for example: 5*2/4+1 and 3.5 will be returned [i.e. ((5*2)/4)+1=3.5]"
158 G COMP
159 ;
160 ;
161V25 ; From LRVER4
162 N LRTX,LRX
163 S (LRDV,LRNG,LRDEL,LRNGS)=""
164 I '$D(^LAB(60,+LRTS,0))#2 Q
165 S LRX=+$P($P(^LAB(60,+LRTS,0),U,5),";",2)
166 S LRTX=$S($L($P(^LAB(60,+LRTS,0),U,5)):$O(^LAB(60,"C",$P(^LAB(60,+LRTS,0),U,5),0)),1:+LRTS)
167 S LRFP=$P(^LAB(60,LRTX,.1),U,3)
168 I LRFP="" S LRFP="$J(X,8)"
169 ;
170 ; Normal ranges, units, delta checks and default value
171 I $D(^LAB(60,LRTX,1,+$G(LRSPEC),0)) D
172 . S LRNG=^LAB(60,LRTX,1,+$G(LRSPEC),0)
173 . S LRDEL=$G(^LAB(62.1,+$P(LRNG,U,8),1))
174 . S LRDEL(1)=$G(^LAB(62.1,+$P(LRNG,U,8),2),"Q")
175 . S X2=$P(LRNG,U,9)
176 . S LRDV=$S('$D(LRSB(LRX)):$P(LRNG,U,10),1:"")
177 ;
178 ; When entering results from a reference lab check if flag to use normals/units from file 60.
179 I $G(LRDUZ(2)),LRDUZ(2)'=DUZ(2),'$G(^LAB(60,LRTX,1,+$G(LRSPEC),.1)) D PLNR^LRVR4
180 ;
181NORM ;
182 I $G(SEX)="" S SEX="M"
183 I $G(AGE)="" S AGE=99
184 S LRNGS=LRNG
185 F LRX=2:1:5 D
186 . N LRY
187 . S LRY=$P(LRNG,"^",LRX)
188 . ; enclose in quotes if text or structured numeric
189 . I LRY'="",$E(LRY)?.(1A,1"<",1">") S LRY=$C(34)_LRY_$C(34)
190 . I LRY'="",$E(LRY)'=$C(34),LRY'?.N.1".".N S @("LRY"_"="_LRY)
191 . S $P(LRNG,"^",LRX)=LRY,$P(LRNGS,"^",LRX)=LRY,@("LRNG"_LRX)=LRY
192 Q
193 ;
194 ;
195LROUT ;
196 K SX
197 S LROUT=1
198 Q
199 ;
200 ;
201HELP W !," ??",$C(7) S LRXDH=LRXD_"3)"
202 W:$D(@LRXDH) " ",@LRXDH
203 W !,"Enter * to report ""canc"" for canceled."
204 W !,"Enter # to report ""comment""."
205 W:'($P(LRXDP,U,2)["S") !,"Enter C to enter calculate mode."
206 Q
207 ;
208 ;
209AMEND ; Process amended results and prompt user
210 N LRANS,LRLL,LRSQ,LRROOT,LRX
211 ; flag to indicate if amended results have been extracted from LAH
212 S LRAMEND=0
213 ; save current value of X
214 S LRX=X
215 S LRROOT=$Q(^LAH("LA7 AMENDED RESULTS",LRUID,LRSB))
216 I LRROOT="" Q
217 I $QS(LRROOT,1)'="LA7 AMENDED RESULTS"!($QS(LRROOT,2)'=LRUID)!($QS(LRROOT,3)'=LRSB) Q
218 S LRLL=$QS(LRROOT,4),LRSQ=$QS(LRROOT,5)
219 I $D(^LAH(LRLL,1,LRSQ,LRSB)) D
220 . N DIR,DIRUT,DTOUT,DUOUT,LRJ,LRY,X,Y
221 . S LRY=^LAH(LRLL,1,LRSQ,LRSB)
222 . S DIR(0)="SOA^0:No;1:Yes;2:Keep but do not process",DIR("B")="Yes"
223 . S DIR("A",1)=" ",DIR("A",2)="Amended result: "_$P(LRY,"^")
224 . S DIR("A",2)=DIR("A",2)_" flag: "_$S($P(LRY,"^",2)'="":$P(LRY,"^",2),1:"None")
225 . S DIR("A",2)=DIR("A",2)_" units: "_$P($P(LRY,"^",5),"!",7)
226 . S DIR("A")="Accept amended results: "
227 . S DIR("?",1)="Answer with 0-No to not accept amended result and delete.",DIR("?",2)="1-Yes to process amended result.",DIR("?")="or 2-Keep which skips processing but leaves result for future processing."
228 . D ^DIR
229 . I $D(DIRUT) Q
230 . S LRANS=Y
231 . I LRANS=2 Q
232 . I LRANS=1 D
233 . . S LRX=$P(LRY,"^"),LRFLG=$P(LRY,"^",2),LRSB(LRSB)=LRY,LRJ=$P(LRY,"^",5)
234 . . F LRI=1,2,3,4,5,7,11,12 S $P(LRNG,"^",LRI)=$P(LRJ,"!",LRI)
235 . . S LRNGS=LRNG,(LRAMEND,LRAMEND(LRSB))=1
236 . . D LRSBCOM^LRVR4 ; also process any comments
237 . K ^LAH(LRLL,1,LRSQ,LRSB)
238 . K ^LAH("LA7 AMENDED RESULTS",LRUID,LRSB,LRLL,LRSQ)
239 . I +$O(^LAH(LRLL,1,LRSQ,1))<1 D ZAPALL^LRVR3(LRLL,LRSQ)
240 S X=LRX
241 Q
242 ;
243 ;
244ASKPLNR ; Ask user for performing lab normal ranges and units when entering
245 ; manually and not using values from file #60.
246 N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRI,LRJ,LRX,LRY,Y,X,Y
247 ;
248 S LRX=$P($G(LRSB(LRSB)),"^",5)
249 ;
250 W !!,"For test ",LRTEST
251 S DIR(0)="60.01,6"
252 I $P(LRX,"!",7)'="" S DIR("B")=$P(LRX,"!",7)
253 D ^DIR
254 I $D(DTOUT)!($D(DUOUT)) Q
255 ; Set units into component 7 of piece 5
256 S $P(LRX,"!",7)=Y,$P(LRSB(LRSB),"^",5)=LRX
257 ;
258 ; Ask normals - high/low and critical
259 K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
260 F LRJ=1,2,3,4 D Q:$D(DTOUT)!($D(DUOUT))
261 . K DIR
262 . S DIR(0)="60.01,"_LRJ,LRI=LRJ+1
263 . I $P(LRX,"!",LRI)'="" D
264 . . S DIR("B")=$P(LRX,"!",LRI)
265 . . I $E(DIR("B"))=$C(34) Q
266 . . I DIR("B")'?.N.1".".N S DIR("B")=$C(34)_DIR("B")_$C(34) ; enclose in quotes if text
267 . D ^DIR
268 . I $D(DTOUT)!($D(DUOUT)) Q
269 . S $P(LRX,"!",LRI)=Y
270 ;
271 ; Ask user for normality in case user does not know high/low/critical.
272 S LRRFLAG(LRSB)=$$RFLAG^LRVERA($P($G(LRSB(LRSB)),"^",2))
273 ;
274 ; Update normal variable LRNG
275 I $P(LRX,"!")="" S $P(LRX,"!")=LRSPEC
276 F LRI=1,2,3,4,5,7 S $P(LRNG,"^",LRI)=$P(LRX,"!",LRI)
277 ;
278 Q
Note: See TracBrowser for help on using the repository browser.