source: ePrescribing/trunk/p/C0PALGY2.m@ 1700

Last change on this file since 1700 was 1595, checked in by George Lilly, 12 years ago

initial release of ePrescribing

File size: 9.2 KB
Line 
1C0PALGY2 ; ERX/GPL/SMH - eRx Allergy utilities ; 5/8/12 11:52pm
2 ;;1.0;C0P;;Apr 25, 2012;Build 103
3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU
4 ;General Public License See attached copy of the License.
5 ;
6 ;This program is free software; you can redistribute it and/or modify
7 ;it under the terms of the GNU General Public License as published by
8 ;the Free Software Foundation; either version 2 of the License, or
9 ;(at your option) any later version.
10 ;
11 ;This program is distributed in the hope that it will be useful,
12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;GNU General Public License for more details.
15 ;
16 ;You should have received a copy of the GNU General Public License along
17 ;with this program; if not, write to the Free Software Foundation, Inc.,
18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19 ;
20 Q
21 ;
22 ; THESE ROUTINES ARE USED TO TEST AND VALIDATE THE USE OF THE RXNORM
23 ; DATABASE FOR LOOKING UP IDS AND MATCHING FIRST DATA BANK IDS TO
24 ; RXNORM CONCEPT IDS AND THEN FROM RXNORM CONCEPT IDS TO VISTA VUIDS
25 ; THE PARTICULAR INTEREST HERE IS FOR MATCHING ALLERGIES TO A MEDICATION
26 ; IN ADDITION THERE ARE ROUTINES HERE TO POPULATE THE C0P FDB ALLERGIES
27 ; FILE.
28 ; NONE OF THESE ROUTINES ARE USED IN REGULAR ERX ACTIVITIES. THEY
29 ; ARE BROUGHT FORWARD AS PART OF THE ERX PACKAGE FOR DEBUGGING AND
30 ; FUTURE DEVELOPMENT
31 ; GPL JUN 2010
32TESTBASE ; TEST LOOKING UP CONCEPT IDS IN RXNORM
33 ;
34 N ZI
35 S ZI=""
36 S (COUNT,FOUND)=0
37 F S ZI=$O(^C0PALGY("TYPE","BASE",ZI)) Q:ZI="" D ; FOR EACH BASE CONCEPT
38 . S COUNT=COUNT+1
39 . S ZJ=$$GET1^DIQ(113059005,ZI_",",1,"E")
40 . S ZN=$$GET1^DIQ(113059005,ZI_",",.01,"E")
41 . S ZV=$$BASE^C0PALGY1(ZJ) ;LOOKUP VISTA MATCH
42 . I ZV'="" S FOUND=FOUND+1
43 . W !,ZJ," ",ZN," :: ",ZV
44 W !,"COUNT:",COUNT," FOUND:",FOUND
45 Q
46 ;
47TESTNAME ; TEST LOOKING UP CONCEPT IDS IN RXNORM
48 ;
49 N ZI
50 S ZI=""
51 S (COUNT,FOUND)=0
52 F S ZI=$O(^C0PALGY("TYPE","NAME",ZI)) Q:ZI="" D ; FOR EACH BASE CONCEPT
53 . S COUNT=COUNT+1
54 . S ZJ=$$GET1^DIQ(113059005,ZI_",",1,"E")
55 . S ZN=$$GET1^DIQ(113059005,ZI_",",.01,"E")
56 . S ZV=$$NAME^C0PALGY1($$UP^XLFSTR(ZN)) ;LOOKUP VISTA MATCH
57 . I ZV'="" S FOUND=FOUND+1
58 . W !,ZJ," ",ZN," :: ",ZV
59 W !,"COUNT:",COUNT," FOUND:",FOUND
60 Q
61 ;
62TEST3 ;
63 ;
64 S ZI=0
65 S (COUNT,FOUND)=0
66 F S ZI=$O(^PSNDF(50.6,ZI)) Q:+ZI=0 D ; FOR EVERY DRUG IN THE NDF
67 . S COUNT=COUNT+1
68 . S ZJ=$G(^PSNDF(50.6,ZI,"VUID")) ;VUID
69 . S ZJ=$P(ZJ,"^",1) ;JUST THE FIRST PIECE
70 . S ZJN=$G(^PSNDF(50.6,ZI,0)) ; VA NAME
71 . W !,ZJN," ",ZJ
72 . S ZK=$$NDDFBAS2^C0PLKUP(ZJ)
73 . I ZK'=0 D ; FDB CONCEPT ID FOUND
74 . . S ZL=$O(^C0PALGY("C2","BASE",ZK,""))
75 . . S ZN=$$GET1^DIQ(113059005,ZL_",",.01,"E")
76 . . I ZN'="" D ;
77 . . . S FOUND=FOUND+1
78 . . . S ZP=ZI_";PSNDF(50.6,"
79 . . . S C0PFDA(113059005,ZL_",",6)=ZP
80 . . . D UPDIE
81 . . W $C(9),ZI," ",ZJ," :: ",ZK," ",ZN
82 W !,"COUNT:",COUNT," FOUND:",FOUND
83 Q
84 ;
85TEST4 ;
86 ;
87 S ZI=0
88 S (COUNT,FOUND)=0
89 F S ZI=$O(^PS(50.416,ZI)) Q:+ZI=0 D ; DRUG INGREDIENTS FILE
90 . S COUNT=COUNT+1
91 . S ZJ=$G(^PS(50.416,ZI,"VUID")) ;VUID
92 . S ZJ=$P(ZJ,"^",1) ;JUST THE FIRST PIECE
93 . S ZJN=$G(^PS(50.416,ZI,0)) ; VA NAME
94 . W !,ZJN," ",ZJ
95 . S ZK=$$NDDFBAS2^C0PLKUP(ZJ)
96 . ;I ZI=3912 B
97 . I ZK'=0 D ; FDB CONCEPT ID FOUND
98 . . S ZL=$O(^C0PALGY("C2","BASE",ZK,""))
99 . . S ZN=$$GET1^DIQ(113059005,ZL_",",.01,"E")
100 . . I ZN'="" D ;
101 . . . S FOUND=FOUND+1
102 . . . W $C(9),ZI," ",ZJ," :: ",ZK," ",ZN
103 . . . S ZP=ZI_";PS(50.416,"
104 . . . S C0PFDA(113059005,ZL_",",6)=ZP
105 . . . D UPDIE
106 W !,"COUNT:",COUNT," FOUND:",FOUND
107 Q
108 ;
109TEST5 ; VA PRODUCT FILE
110 ;
111 S ZI=0
112 S (COUNT,FOUND)=0
113 F S ZI=$O(^PSNDF(50.68,ZI)) Q:+ZI=0 D ; FOR EVERY DRUG IN THE NDF
114 . S COUNT=COUNT+1
115 . S ZJ=$G(^PSNDF(50.68,ZI,"VUID")) ;VUID
116 . S ZJ=$P(ZJ,"^",1) ;JUST THE FIRST PIECE
117 . S ZJN=$G(^PSNDF(50.68,ZI,0)) ; VA NAME
118 . ;W !,ZJN," ",ZJ
119 . S ZK=$$NDDFBAS2^C0PLKUP(ZJ)
120 . I ZK'=0 D ; FDB CONCEPT ID FOUND
121 . . S ZL=$O(^C0PALGY("C2","NAME",ZK,""))
122 . . S ZN=$$GET1^DIQ(113059005,ZL_",",.01,"E")
123 . . I ZN'="" D ;
124 . . . S FOUND=FOUND+1
125 . . . S ZP=ZI_";PSNDF(50.68,"
126 . . . S C0PFDA(113059005,ZL_",",6)=ZP
127 . . . D UPDIE
128 . . W !,ZJN," ",ZJ
129 . . W $C(9),ZI," ",ZJ," :: ",ZK," ",ZN
130 W !,"COUNT:",COUNT," FOUND:",FOUND
131 Q
132 ;
133TEST6 ; CHECK ALL VUIDS IN VA PRODUCT FILE AGAINST RXNORM CONCEPT FILE
134 ;
135 S ZI=0
136 S (COUNT,FOUND)=0
137 F S ZI=$O(^PSNDF(50.68,ZI)) Q:+ZI=0 D ; FOR EVERY DRUG IN THE NDF
138 . S COUNT=COUNT+1
139 . S ZJ=$G(^PSNDF(50.68,ZI,"VUID")) ;VUID
140 . S ZJ=$P(ZJ,"^",1) ;JUST THE FIRST PIECE
141 . S ZJN=$G(^PSNDF(50.68,ZI,0)) ; VA NAME
142 . ;W !,ZJN," ",ZJ
143 . S ZRXN=$O(^C0P("RXN","VUID",ZJ,""))
144 . I ZRXN'="" S FOUND=FOUND+1
145 W !,"COUNT:",COUNT," FOUND:",FOUND
146 Q
147 ;
148TEST7 ; CHECK ALL CONCEPT IDS IN THE FDB ALLERGY FILE AGAINST THE
149 ;RXNORM CONCEPT FILE - THIS APPOACH DOESN'T WORK.
150 ;
151 S ZI=0
152 S (COUNT,FOUND)=0
153 F S ZI=$O(^C0PALGY("C",ZI)) Q:+ZI=0 D ; EVERY FDB ALLERGY CONCEPT
154 . S ZIN=$$GET1^DIQ(113059005,ZI_",",.01) ;NAME OF CONCEPT
155 . S ZJ=$O(^C0P("RXN","B",ZI,"")) ; RXNORM CONCEPT FIELD IS .01
156 . S COUNT=COUNT+1
157 . I ZJ'="" D ; FOUND
158 . . S FOUND=FOUND+1
159 . . S ZJN=$G(^C0P("RXN",ZJ,1,1,0)) ;NAME OF CONCEPT
160 . . ;S ZJNNN=$$GET1^DIQ(1130590011.101,ZJ_",",,ZJN)
161 . . I ZIN'="" W !,ZI,ZIN," :: ",ZJ," ",ZJN
162 W !,"COUNT:",COUNT," FOUND:",FOUND
163 Q
164 ;
165TESTC ; PRINT OUT DUPLICATES IN THE FROM THE C INDEX OF THE ALLERGY FILE
166 ;
167 S (COUNT,COUNT2)=0
168 S ZI=""
169 F S ZI=$O(^C0PALGY("C",ZI)) Q:ZI="" D ;
170 . S ZJ=$O(^C0PALGY("C",ZI,"")) ;IEN
171 . I $O(^C0PALGY("C",ZI,ZJ))'="" D ;
172 . . S ZZ=""
173 . . F S ZZ=$O(^C0PALGY("C",ZI,ZZ)) Q:ZZ="" D ;
174 . . . S COUNT=COUNT+1
175 . . . S ZK=$$GET1^DIQ(113059005,ZZ_",",6)
176 . . . S ZL=$$GET1^DIQ(113059005,ZZ_",",.01)
177 . . . S ZT=$$GET1^DIQ(113059005,ZZ_",",2)
178 . . . I ZK'="" S COUNT2=COUNT2+1
179 . . . S DUPS(ZI,ZL,ZT)=ZK
180 . . . W !,ZK," ",ZI
181 Q
182 ;
183COUNT ; COUNT THE NUMBER OF MAPPINGS IN VA POINTER INDEX OF FDB ALLERGIES
184 ;
185 N ZI,ZJ,COUNT
186 S COUNT=0
187 S ZI="" S ZJ=""
188 F S ZI=$O(^C0PALGY("VA",ZI)) Q:ZI="" D ;
189 . S ZJ=""
190 . F S ZJ=$O(^C0PALGY("VA",ZI,ZJ)) Q:ZJ="" D ;
191 . . S COUNT=COUNT+1
192 W !,"COUNT: ",COUNT,!
193 Q
194 ;
195CHECK ; CHECK ALL ALLERGIES IN THE PATIENT ALLERGY FILE FOR MATCHES IN
196 ; THE FDB ALLERGY FILE
197 N ZI,ZJ,COUNT
198 S (ZI,ZJ)=0 S COUNT=0 S COUNT2=0
199 F S ZI=$O(^GMR(120.8,ZI)) Q:+ZI=0 D ; FOR EACH ENTRY
200 . S ZJ=^GMR(120.8,ZI,0) ; ZERO NODE
201 . S PAT=$P(ZJ,U,1) ;PATIENT
202 . S ZN=$P(ZJ,U,2) ;REACTANT NAME
203 . S GMR=$P(ZJ,U,3) ;POINTER
204 . S COUNT=COUNT+1
205 . S FOUND=$O(^C0PALGY("VA",GMR,"")) ; VA POINTER INDEX
206 . S ZF=""
207 . I FOUND'="" D ;
208 . . S COUNT2=COUNT2+1
209 . . S ZF=$$GET1^DIQ(113059005,FOUND_",",.01,"E")
210 . W !,"PAT:",PAT," ",ZN," ",GMR," :: ",FOUND," ",ZF
211 W !,"COUNT:",COUNT," FOUND:",COUNT2
212 Q
213 ;
214LOADRXN ; LOAD THE FDB TO RXNORM CSV FILE INTO ^TMP
215 ; THE FILE NAME IS CompositeAllergyID2RxCui.csv
216 ; AND IT IS STORED IN /home/dev
217 N ZG
218 S ZG=$NA(^TMP("C0PALGY","RXNCSV",1))
219 W $$FTG^%ZISH("/home/dev/","CompositeAllergyID2RxCui.csv",ZG,3) ;INCREMENT
220 ; 3rd NODE
221 Q
222 ;
223ADDRXN ; ADD THE CompositeAllergyID to rxcui mapping to the
224 ; C0P FDB ALLERGY file
225 ; the csv file with the mapping has been loaded into
226 ; ^TMP("C0PALGY","RXNCSV") - see LOADRXN routine above
227 N ZI,ZJ,ZARY,ZF,C0PFDA
228 S ZF=113059005 ; FILE NUMBER FOR C0P FDB ALLERGY FILE
229 S ZARY=$NA(^TMP("C0PALGY","RXNCSV"))
230 S ZJ=$O(@ZARY@(""),-1) ; NUMBER OF ROWS IN THE ARRAY
231 F ZI=2:1:ZJ D ; SKIP ROW 1, WHICH HAS THE COLUMN NAMES
232 . N ZFDA,ZRXN,ZROW
233 . K C0PFDA
234 . S ZROW=@ZARY@(ZI) ; EACH ROW IS ""X"",""Y""
235 . S ZFDA=$P(ZROW,",",1) ; CompositeAllergyID
236 . S ZFDA=$TR(ZFDA,"""") ; GET RID OF EXTRA QUOTES
237 . S ZRXN=$P(ZROW,",",2) ; rxcui
238 . S ZRXN=$TR(ZRXN,"""") ; GET RID OF EXTRA QUOTES
239 . W !,ZFDA," ",ZRXN
240 . S ZOHONE=$$GET1^DIQ(ZF,ZFDA_",",.01)
241 . S C0PFDA(ZF,ZFDA_",",.01)=ZOHONE
242 . S C0PFDA(ZF,ZFDA_",",7)=ZRXN ; SET rxcui for ien ZFDA
243 . D UPDIE
244 Q
245 ;
246LOOKRXN ; LOOK UP RXCUI VALUES IN THE RXNORM CONCEPT FILE
247 ;
248 S COUNT=0 S FOUND=0
249 S ZI=""
250 F S ZI=$O(^C0PALGY("RXCUI",ZI)) Q:ZI="" D ;
251 . S COUNT=COUNT+1
252 . S ZJ=$O(^C0P("RXN","B",ZI,"")) ;
253 . W !,ZI," ",ZJ
254 W !,COUNT," FOUND"
255 Q
256 ;
257LOOKFDB ;LOOK UP FDB NUMBERS IN THE RXNORM FILE
258 ;
259 S ZI=""
260 F S ZI=$O(^C0PALGY("C",ZI)) Q:ZI="" D ;
261 . S ZJ=$O(^C0PALGY("C",ZI,""))
262 . W !,ZI," ",ZJ
263 Q
264 ;
265MKRNF ; CREATING AN RNF FILE FOR THE FDB ALLERGY TABLE
266 ;
267 F ZI=1:1:999999 F ZJ=1:1:7 D ;
268 . I ZJ=1 S ^GRNF("V",ZI,$O(^GRNF("F",ZJ,"")))=ZI
269 . S ZK=$P(^GPLFDB(ZI),""",""",ZJ)
270 . S ZK=$TR(ZK,"""")
271 . I ZJ=6 D ;STATUS
272 . . I (ZK'="A")&(ZK'="I") D ERROR^C0PMAIN(",U113059009,",$ST($ST,"PLACE"),"ERX-INVALID-DATA","Invalid Data") QUIT
273 . I ZK'="" D ;
274 . . S ^GRNF("V",ZI,$O(^GRNF("F",ZJ,"")))=ZK
275 Q
276 ;
277FILEFDB ;POPULATE C0P FDB ALLERGIES FROM RNF STRUCTURE IN ^GRNF
278 ;
279 F ZI=1:1:999999 D ;
280 . K C0PFDA
281 . S C0PFDA(113059005,"?+1,",.01)=^GRNF("V",ZI,"Description")
282 . S C0PFDA(113059005,"?+1,",.05)=$G(^GRNF("V",ZI,"CompositeAllergyID"))
283 . S C0PFDA(113059005,"?+1,",1)=^GRNF("V",ZI,"ConceptID")
284 . S C0PFDA(113059005,"?+1,",2)=^GRNF("V",ZI,"ConceptType")
285 . S C0PFDA(113059005,"?+1,",3)=^GRNF("V",ZI,"Source")
286 . S C0PFDA(113059005,"?+1,",4)=^GRNF("V",ZI,"Status")
287 . S C0PFDA(113059005,"?+1,",5)=^GRNF("V",ZI,"TouchDate")
288 . ;ZWR C0PFDA
289 . ;B
290 . D UPDIE
291 Q
292 ;
293UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
294 K ZERR
295 D CLEAN^DILF
296 D UPDATE^DIE("","C0PFDA","","ZERR")
297 I $D(ZERR) D ERROR^C0PMAIN(",U113059008,",$ST($ST,"PLACE"),"ERX-UPDIE-FAIL","Fileman Data Update Failure") QUIT
298 K C0PFDA
299 Q
Note: See TracBrowser for help on using the repository browser.