source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRLNC0.m@ 1006

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

initial load of WorldVistAEHR

File size: 9.3 KB
Line 
1LRLNC0 ;DALOI/CA/FHS-MAP LAB TESTS TO LOINC CODES ;1-OCT-1998
2 ;;5.2;LAB SERVICE;**215,232,278,280**;Sep 27,1994
3 ;Reference to ^DD supported by IA # 10154
4 ;=================================================================
5 ; Ask VistA test to map-Lookup in Lab Test file #60
6START ;entry point from option LR LOINC MAPPING
7 S LREND=0,LRLNC1=1 D TEST
8 I $G(LREND) G EXIT
9 I '$G(LRNLT) G START
10 ;MAP DEFAULT
11DEFAULT ;
12 N LRNLTX
13 Q:'$D(^LAM(+$G(LRNLT),0))#2
14 S LRNLTX=LRNLT
15 L +^LAM(LRNLTX,9):2 I '$T W !!?5,"Locked by another user",! H 5 Q
16 W !
17 K DIR S DIR("B")="No"
18 S DIR(0)="Y",DIR("A")="Do you want to edit/delete the Default LOINC code"
19 S DIR("?")="Enter yes to map/change the default LOINC code."
20 D ^DIR K DIR
21 L -^LAM(LRNLTX,9)
22 I $D(DIRUT) Q
23 I $G(LRDFONLY),$D(DIRUT) Q
24 I '$G(LRDFONLY),$D(DIRUT) D EXIT G START
25 I Y D D DEFAULT^LRLNCMD
26 . Q:'$G(^LAM(LRNLT,9))
27 . W !!?5,"Deleting LOINC Default Code",!
28 . N DA,DR,X,DIE
29 . S DIE="^LAM(",DA=+LRNLT,DR="25///^S X=""@""" D ^DIE
30 L -^LAM(LRNLTX,9)
31 I $G(LRDFONLY) Q
32 I '$P($P($G(^LAB(60,LRIEN,0)),U,5),";",2) Q
33ASKSPEC D SPEC
34 I $G(LREND) D EXIT G START
35 W !!
36 S DIR(0)="Y",DIR("A")="Do you want to see possible LOINC code matches"
37 S DIR("?")="Enter no if you already know the LOINC code."
38 S DIR("B")="No"
39 D ^DIR K DIR
40 I $D(DIRUT) D EXIT G START
41 I 'Y D ENTERLNC^LRLNCC
42 I $G(LREND) D EXIT G START
43 I '$G(LRCODE) D LOINC
44 I $G(LRNO) D EXIT G START
45 I $G(LREND) D EXIT G START
46 I $G(LRNO) D ENTERLNC^LRLNCC
47 I $G(LREND) D EXIT G START
48CORRECT W !!
49 S DIR(0)="Y",DIR("A")="Is this the correct one"
50 S DIR("B")="Yes"
51 S DIR("?")="Enter no to select a different code."
52 D ^DIR K DIR
53 I $D(DIRUT)!($G(LREND)) D EXIT G START
54 I 'Y,$G(LRNO) D ENTERLNC^LRLNCC
55 I 'Y,'$G(LRNO) D LOINC
56 I $G(LRNO) D EXIT G START
57 I $G(LREND) D EXIT G START
58 D CHKSPEC
59 I $G(LRNO) D EXIT G START
60 I $G(LRNEXT) G NEXTSP
61 I $G(LREND) D EXIT G START
62 D LINK
63 I $G(LRNEXT) G NEXTSP
64 I $G(LREND) D EXIT G START
65 D CHECK
66 I $G(LRNEXT) G NEXTSP
67 I $G(LREND) D EXIT G START
68 D MAP
69NEXTSP D KILL1
70 G ASKSPEC
71KILL1 I $G(LRNLT) L -^LAM(LRNLT,9)
72 K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRLNC,LRLNC0,LRLOINC,LRELEC,LRCODE,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRUNTIS,S,Y
73 K DD,D0,DLAYGO,LRLNCNAM,LRNO,LRNOP,LRLNC1,LRNEXT,LRODLCD,X
74 Q
75EXIT I $G(LRNLT) L -^LAM(LRNLT,9)
76 K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRCODE,LRDATA,LREND,LRLNC,LRLNC0,LRLOINC,LRELEC,LRIEN,LRNLT
77 K LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
78 K DD,DO,DLAYGO,LRLNCNAM,LRNO,LRNOP,LRDEF,LRLNC1,LRNEXT,LROLDCD,X
79 QUIT
80TEST W @IOF
81 K DIR,LRNLT
82 S DIR(0)="PO^60:QENMZ,",DIR("A")="VistA Lab Test to "_$S($D(LRDEL):"Delete/Unmap",1:"Link/Map")_" to LOINC "
83 S DIR("?")="Select Lab test you wish to "_$S($D(LRDEL):"delete/unmap",1:"link/map")_" to a LOINC Code"
84 D ^DIR K DIR
85 I $D(DIRUT)!'Y K DIRUT S LREND=1 Q
86 S LRIEN=+Y,LRTEST=$P(Y,U,2)
87 L +^LAB(60,LRIEN):2 I '$T W !?4,"Another user is editing this entry",! H 5 Q
88 ;Check for RESULT NLT CODE and if not one let enter
89 S LRNLT=+$P($G(^LAB(60,LRIEN,64)),U,2)
90DIS64 D Q:$G(LR64DIS)
91 . Q:'$G(LRNLT)
92 . N LRLNC,LRANS
93 . S LRLNC=$P($G(^LAM(LRNLT,9)),U) Q:'LRLNC
94 . D GETS^DIQ(64,LRNLT_",",".01;1","E","LRANS")
95 . D GETS^DIQ(95.3,LRLNC_",",".01;80","E","LRANS")
96 . W !,!?5,$G(LRANS(64,LRNLT_",",.01,"E"))_" "_$G(LRANS(64,LRNLT_",",1,"E"))
97 . W !?4,"Default LOINC Already Mapped to:"
98 . W !,$G(LRANS(95.3,LRLNC_",",.01,"E"))_" "_$G(LRANS(95.3,LRLNC_",",80,"E"))
99 I '$P($G(^LAB(60,LRIEN,64)),U,2) D
100 .W !!,"There is not a RESULT NLT CODE for "_LRTEST,".",!
101 .W !,"You must select one now to continue with the mapping of this test!",!
102 K DIE,DA,DR S DIE="^LAB(60,",DA=+LRIEN,DR=64.1 D ^DIE K DIE,DA,DR
103 L -^LAB(60,LRIEN)
104 I $G(X)<1 S LRNLT="" Q
105 I $P($G(^LAB(60,+LRIEN,64)),U,2) D
106 . N DIC,DA,DR
107 . S DIC="^LAB(60,",DA=+LRIEN,DR=64 W !! W ?5,"IEN: [",DA,"] ",$P(^LAB(60,LRIEN,0),U) S S=$Y D EN^DIQ
108 W !
109 S LRNLT=$P($G(^LAB(60,LRIEN,64)),U,2)
110 I 'LRNLT G TEST
111 Q
112SPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
113 W !!
114LOOK61 K DIC,DA
115 N LRANS
116 Q:'$G(LRIEN)
117 S DIC=61,DIC(0)="AENMZQ"
118 S DIC("A")="Specimen source: "
119 D ^DIC
120 I $D(DUOUT)!($D(DTOUT))!(Y<1) D Q
121 .K DIC,DA,DTOUT,DUOUT S LREND=1 Q
122 Q:$G(LREND)
123 S LRSPEC=+Y,LRSPECN=Y(0,0)
124 K DA,DIC,DIE,DR
125 I '$L($P($G(^LAB(60,LRIEN,0)),U,5)) G OVER
126 I '$D(^LAB(60,LRIEN,1)) D
127 .S DIC("P")=$P(^DD(60,100,0),"^",2)
128 I '$D(^LAB(60,LRIEN,1,LRSPEC)) D G:$G(LRNOP) LOOK61
129 . N DIR
130 . W !," Are you sure you want to add this specimen"
131 . S DIR(0)="Y" D ^DIR I Y<1 S LRNOP=1 Q
132 . K DD,DO
133 . S DA(1)=LRIEN,X=LRSPEC,DINUM=X
134 . S DIC="^LAB(60,"_DA(1)_",1,"
135 . S DIC(0)="LMZ",DLAYGO=60.01
136 . D FILE^DICN S LRANS=Y
137 ;A DIE call is made to edit fields in subfile
138 I $P($G(LRANS),U,3) D
139 .S DIE=DIC K DIC
140 .S DA=+Y
141 .S DR="1:9.3"
142 .D ^DIE
143 K DIE,DR,DA
144OVER ;Check to see if linked to file 64.061. If not, then let enter link.
145 I '$P($G(^LAB(61,LRSPEC,0)),U,9) D
146 .W !!,"There is not a LEDI HL7 code for "_LRSPECN,"."
147 .W !,"You must select one now to continue with the mapping of this test and specimen!",!
148 I '$P($G(^LAB(61,LRSPEC,0)),U,10) D G:$G(LRNOP) LOOK61
149 .W !!,"There is not a TIME ASPECT for "_LRSPECN,".",!
150 .K DIE,DR,DA S DA=LRSPEC,DIE="^LAB(61,",DR=".09:.0961"
151 .D ^DIE
152 .S:$D(DIRUT) LRNOP=1
153 S LRELEC=$P($G(^LAB(61,LRSPEC,0)),U,9)
154 I 'LRELEC G SPEC
155 S LRSPECL=$P(^LAB(64.061,LRELEC,0),U,2)
156 Q
157LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
158 D FIND^DIC(95.3,"","80","M",LRTEST,"","","I $P(^(0),U,8)=$G(LRELEC)!(LRELEC=74!(LRELEC=83)!(LRELEC=114)!(LRELEC=1376)&(""SER PLAS BLD""[$P(^(80),"":"",4)))","","LRLOINC","")
159CODE ;ask which code to map
160 D CODE^LRLNCC
161 Q
162LINK ;Link the code with file 64
163 S LRDATA=$P(^LAB(60,LRIEN,0),U,12) ;DATA NAME
164 I '$L(LRDATA) S LRDATA=$P($G(^LAB(60,+$G(LRIEN),0)),U,4) ;Set to subscript of test.
165 S LRTIME=$P(^LAB(95.3,LRCODE,0),U,7) ;TIME ASPECT
166 S LRUNITS=$P(^LAB(95.3,LRCODE,0),U,14) ;UNITS
167 S LRNLT=+$P(^LAM(LRNLT,0),U,2)
168LR64 ;
169 K DIC,DA
170 W !!
171 S DIC=64,DIC(0)="ENMZ",X=LRNLT
172 D ^DIC
173 I Y<1 D EXIT S LREND=1 Q
174 I $D(DTOUT)!($D(DUOUT)) K DTOUT,DUOUT D EXIT S LREND=1 Q
175 I 'Y S LRNEXT=1 Q
176 S LRNLT=+Y
177 Q
178CHECK ;Check to see if already mapped to a LOINC code
179 I $D(^LAM(LRNLT,5,LRSPEC,1,"B",LRTIME)) D SHOWPRE I $D(DIRUT) D EXIT S LREND=1 Q
180 I Y<1 S LRNEXT=1
181 Q
182MAP ;DIE call to add data name,time aspect,units, LOINC code, and lab test fields
183 L +^LAM(LRNLT,5):1 I '$T W !,"Another user is editing this record" H 5 Q
184 I '$D(^LAM(LRNLT,5,0)) D
185 .S DIC("P")=$P(^DD(64,20,0),"^",2)
186 I '$D(^LAM(LRNLT,5,LRSPEC)) D
187 .K DD,DO
188 .S DA(1)=LRNLT,DA=LRSPEC
189 .S DIC="^LAM("_DA(1)_",5,",DIC(0)="L",DLAYGO=64,X=LRSPEC,DINUM=X
190 .D FILE^DICN
191 I '$D(^LAM(LRNLT,5,LRSPEC,1,0)) D
192 .S DIC("P")=$P(^DD(64.01,30,0),"^",2)
193 S DA(2)=LRNLT,DA(1)=LRSPEC,X=LRTIME,DINUM=X
194 S DIC="^LAM("_DA(2)_",5,"_DA(1)_",1,"
195 I '$D(^LAM(LRNLT,5,LRSPEC,1,LRTIME)) D
196 .K DD,DO
197 .S DIC(0)="L",DLAYGO=64
198 .D FILE^DICN
199 S DA=LRTIME
200 K DIE,DR S DIE=DIC K DIC
201 S DR="1////"_LRUNITS_";2////"_LRDATA_";3////"_LRIEN_";4////"_LRCODE
202 D ^DIE
203 L -^LAM(LRNLT,5)
204 ;HERE SHOW WHAT WAS MAPPED
205 W @IOF
206 W !!
207 W !,"NLT: ",$P($G(^LAM(LRNLT,0)),U)
208 W !,"WKLD CODE: ",$P($G(^LAM(LRNLT,0)),U,2)
209 W !,"SPECIMEN: ",$P($G(^LAB(61,LRSPEC,0)),U)
210 K DIC,DR
211 S DIC=DIE
212 S S=$Y
213 D EN^DIQ
214INDEX60 ;Stores LOINC code in Laboratory Test file (#60) so know what tests are mapped.
215 Q:'$L($P($G(^LAB(60,LRIEN,0)),U,5)) ;set only atomic tests
216 N LRDA,LRFDA,LRERR
217 I '$G(^LAB(60,LRIEN,1,LRSPEC,0)) D
218 . K LRFDA,LRDA
219 . S LRFDA(1,60.01,"+1,"_LRIEN_",",.01)=LRSPEC
220 . S LRDA(1)=LRSPEC
221 . D UPDATE^DIE("","LRFDA(1)","LRDA","LRERR")
222 Q:$D(LRERR)
223 K LRFDA
224 S LRFDA(2,60.01,LRSPEC_","_LRIEN_",",95.3)=LRCODE
225 D FILE^DIE("","LRFDA(2)","LRERR")
226 Q
227SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
228 S LRLNC=$P($G(^LAM(LRNLT,5,LRSPEC,1,LRTIME,1)),U)
229 W !!,"This test and specimen is already mapped to:"
230 W !,"LOINC code: ",LRLNC," ",$G(^LAB(95.3,+LRLNC,80))
231 W !
232 K DIR S DIR("B")="No"
233 S DIR(0)="Y",DIR("A")="Do you want to change this mapping"
234 S DIR("?")="If you enter yes, the current LOINC code will be overwritten with the LOINC code that you have chosen."
235 D ^DIR K DIR
236 Q
237CHKSPEC ;Check that specimen of LOINC code same as specimen of test
238 I LRLNC0(8)=$G(LRELEC) Q
239 I (LRLNC0(8)=74!(LRLNC0(8)=83)!(LRLNC0(8)=114)!(LRLNC0(8)=1376))&($G(LRELEC)=74!($G(LRELEC)=83)!($G(LRELEC)=114)!($G(LRELEC)=1376)) Q
240 W !!,"The LOINC code that you have selected does not have the"
241 W !,"same specimen that you chose to map."
242 S DIR(0)="Y",DIR("A")="Are you sure you want to do this"
243 S DIR("?")="If you enter yes, the test will be mapped to this LOINC code."
244 S DIR("B")="Yes"
245 D ^DIR K DIR
246 I $D(DIRUT) S LREND=1 Q
247 I Y<1 S LRNO=1
248 Q
2496206 ;LOINC mapping ANTIMICROBIAL [^LAB(62.060)]
250 W !!
251 D EXITMI
252 S (LRDEL,LRDFONLY)=1
253 S DIR(0)="PO^62.06:QENMZ",DIR("A")="Select Antimicrobial "
254 S DIR("?")="Select Antimicrobial Susceptibility Drug"
255 D ^DIR K DIR
256 I $D(DIRUT)!(Y<1) K DIRUT D EXITMI Q
257 S LRIEN=Y,LRTEST=$P(Y(0),U,2)
258 L +^LAB(62.06,LRIEN):2 I '$T W !?4,"Being edited by another user" H 5 G 6206
259 ;Display Mapped code
260 S (LRNLTX,LRNLT)=+$P($G(^LAB(62.06,+LRIEN,64)),U)
261 I LRNLT D
262 . N LR64DIS
263 . S LR64DIS=1 D DIS64
264 D
265 . N DIE,DA,DR
266 . S DIE="^LAB(62.06,",DIC=DIE,DA=+LRIEN,DR=64 D ^DIE
267 L -^LAB(62.06,LRIEN)
268 I '$G(^LAB(62.06,+LRIEN,64))!($D(DTOUT))!($D(DUOUT)) G 6206
269 S LRDATA="LAB(62.06,"_+LRIEN_",",LRIEN=+LRIEN
270 S LRNLT=$P($G(^LAB(62.06,+LRIEN,64)),U)
271 I LRNLT S LRTEST=$$GET1^DIQ(64,LRNLT_",",.01,"ERR","ANS")
272 I LRNLT W ! D DEFAULT
273 G 6206
274 Q
275EXITMI ;Clean up 6206 variables.
276 K ANS,DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,ERR,LRANS,LRDATA,LRDEF,LRDFONLY,LRNLT,LRNLTX,LRIEN,LRTEST
277 K LRDEL,LRDFONLY,X,Y
278 Q
Note: See TracBrowser for help on using the repository browser.