source: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXTRAN.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1LEXTRAN ; ISL/FJF - Lexicon code and text wrapper API's ; 01/31/2006
2 ;;2.0;LEXICON UTILITY;**41**;Sep 23, 1996;Build 34
3 ; Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5CODE(LEXCODE,LEXSRC,LEXVDT,LEXRAY) ;
6 ; Lexicon wrapper application to obtain concept data for a given code
7 ; and source
8 ;
9 ; Input
10 ;
11 ; LEXCODE code - mandatory
12 ; LEXSRC code system source abbreviation e.g. SCT (SNOMED CT)
13 ; - mandatory
14 ; LEXVDT effective date (defaults to current date) - optional
15 ; LEXRAY output array (defaults to 'LEX') optionaL
16 ;
17 ; Output
18 ;
19 ; if call finds an active code for the source
20 ; "1^LEXCODE"
21 ; LEX - an array containing information about the code
22 ; LEX(0) - a five piece string:
23 ; 1. code
24 ; 2. hierarchy
25 ; 3. version
26 ; 4. legacy code
27 ; 5. code status
28 ; LEX("F") fully specified name
29 ; LEX("P") preferred term
30 ; LEX("S",n) synonyms (n is the nth synonym)
31 ;
32 ; if call cannot find specified code on file
33 ; "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
34 ; where LEXSCNM is the source name
35 ; LEXCODE is the code
36 ;
37 ; if call finds an inactive code for the source
38 ; "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
39 ; LEX - an array containing information about the code
40 ; LEX(0) - a five piece string:
41 ; 1. code
42 ; 2. hierarchy
43 ; 3. version
44 ; 4. legacy code
45 ; 5. code status
46 ;
47 ; otherwise
48 ; "-1^error text"
49 ;
50 ; example of LEX array:
51 ; LEX(0)="67922002^Substance^20050701^T-C2500^1"
52 ; LEX("F")="Serum (Substance)"
53 ; LEX("P")="Serum"
54 ;
55 ; check passed parameter arguments
56 ;
57 I $G(LEXCODE)="" Q "-1^no code specified"
58 I $G(LEXSRC)="" Q "-1^no source specified"
59 I '$D(^LEX(757.03,"B",LEXSRC)) Q "-1^source not recognized"
60 I $D(^TMP("LEXSCH",$J,"VDT",0)) S LEXVDT=^(0)
61 I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
62 I $G(LEXVDT)=-1 Q "-1^invalid date format"
63 I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
64 I $G(LEXRAY)="" K LEXRAY
65 ;
66 ; obtain source mnemonic and ASAB
67 ;
68 N LEXSCNM,LEXSIEN,LEXASAB,LEXCIEN,VALCODE,LEXSTAT,LEXPIEN,T
69 ;
70 S LEXSIEN=$O(^LEX(757.03,"B",LEXSRC,""))
71 S T=^LEX(757.03,LEXSIEN,0)
72 S LEXSCNM=$P(T,U,2)
73 S LEXASAB=$E($P(T,U),1,3)
74 ;
75 ; check for code existence for source
76 ;
77 S LEXCIEN="",VALCODE=0
78 F Q:VALCODE=1 D Q:LEXCIEN=""
79 .S LEXCIEN=$O(^LEX(757.02,"CODE",LEXCODE_" ",LEXCIEN)) Q:LEXCIEN="" D
80 .I $D(^LEX(757.02,"ASRC",LEXASAB,LEXCIEN)) S VALCODE=1 Q
81 I 'VALCODE Q "-2^"_LEXSCNM_" code "_LEXCODE_" not on file"
82 ;
83 ; now we know that the code belongs to the source and that it is known
84 ; in our files
85 ; check that code is valid for date
86 ;
87 K LEXSTAT,LEX
88 K ^TMP("LEXSCH",$J)
89 S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT)
90 I +LEXSTAT=0 D Q "-4^"_LEXSCNM_" code "_LEXCODE_" not active for "_LEXVDT
91 .S LEXPIEN=$P(LEXSTAT(1),U)
92 .D INFO^LEXA(LEXPIEN)
93 .D GETINFO
94 .I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
95 ;
96 ; if we've got this far we have a good code that is active
97 S LEXPIEN=$P(LEXSTAT(1),U)
98 ;Q "1^"_LEXCODE
99 D INFO^LEXA(LEXPIEN)
100 D GETINFO
101 I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
102 ;
103 Q "1^"_LEXCODE
104 ;
105GETINFO ; obtain information for code and populate LEX array
106 ;
107 N LEXFSN,LEXHIER,LEXLGY,LEXVER,N,LEXSEP,I
108 I $D(LEX("SEL","EXP","C","FUL")) D
109 .S LEXFSN=LEX("SEL","EXP",$O(LEX("SEL","EXP","C","FUL","")))
110 .S LEXHIER=$P($P(LEXFSN,"(",$L(LEXFSN,"(")),")")
111 ; legacy code
112 S LEXLGY=$$GET1^DIQ(757.02,LEXCIEN_",",13)
113 ; version
114 S LEXVER=$$VERSION(LEXSRC,LEXCODE,LEXVDT)
115 ; create return array
116 ;S LEXSEP=" ["_LEXCODE_"]"
117 S LEX(0)=LEXCODE_U_$G(LEXHIER)_U_$S(+LEXVER=-1:"",1:$P(LEXVER,U,3))
118 S LEX(0)=LEX(0)_U_LEXLGY_U_+LEXSTAT
119 S LEX("P")=$P(LEX("SEL","EXP",$O(LEX("SEL","EXP","C","MAJ",""))),U,2)
120 I $D(LEXFSN) S LEX("F")=$P(LEXFSN,"^",2)
121 S N=""
122 F I=1:1 S N=$O(LEX("SEL","EXP","C","SYN",N)) Q:N="" D
123 .S LEX("S",I)=$P(LEX("SEL","EXP",N),U,2)
124 K LEX("SEL")
125 Q
126 ;
127TEXT(LEXTEXT,LEXVDT,LEXSUB,LEXSRC,LEXRAY) ;
128 ;
129 ; Lexicon wrapper application to obtain concept data for a given text
130 ; and source
131 ;
132 ; Input
133 ;
134 ; LEXTEXT the search string - mandatory
135 ; LEXVDT effective date (defaults to current date) - optional
136 ; LEXSUB subset or 'hierarchy' - optional
137 ; LEXSRC code system source abbreviation e.g. SCT (SNOMED CT)
138 ; - optional
139 ; LEXRAY output array (defaults to 'LEX')- optional
140 ;
141 ; Output
142 ;
143 ; LEX or passed array name - an array containing information
144 ; about the code
145 ; LEX(0) - a five piece string:
146 ; 1. code
147 ; 2. hierarchy
148 ; 3. version
149 ; 4. legacy code
150 ; 5. code status
151 ;
152 ; otherwise
153 ; "-1^error text"
154 ;
155 ; example of LEX array:
156 ; LEX(0)="67922002^Substance^20050701^T-C2500^1"
157 ; LEX("F")="Serum (Substance)"
158 ; LEX("P")="Serum"
159 ;
160 I $G(LEXTEXT)="" Q "-1^no search string specified"
161 S LEXSRC=$G(LEXSRC)
162 I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
163 I $G(LEXVDT)=-1 Q "-1^invalid date format"
164 I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
165 S LEXSRC=$G(LEXSRC)
166 S LEXSUB=$G(LEXSUB) I LEXSUB="" S LEXSUB=LEXSRC
167 I $G(LEXRAY)="" K LEXRAY
168 ;
169 N X,LEXPIEN,LEXCODE,LEXSTAT,LEXCIEN,Y
170 K ^TMP("LEXSCH",$J),LEX
171 S X=LEXTEXT
172 D CONFIG^LEXSET(LEXSRC,LEXSUB,LEXVDT)
173 D EN^LEXA1
174 I +Y=-1 Q "-1^search could not find term"
175 ;
176 S LEXPIEN=+Y
177 D INFO^LEXA(LEXPIEN)
178 S LEXCODE=$O(LEX("SEL","SRC","C",""))
179 S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT)
180 S LEXCIEN=$P(LEXSTAT,U,2)
181 S LEXSRC=$P(LEXSTAT(2),U,2)
182 D GETINFO
183 I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
184 Q "1^"_LEXPIEN
185 ;
186VERSION(LEXSRC,LEXCODE,LEXVDT) ;
187 ; infer version of code
188 ; Input
189 ;
190 ; LEXSRC code system source abbreviation e.g. SCT (SNOMED CT)
191 ; LEXCODE code - mandatory
192 ; LEXVDT effective date (defaults to current date) - optional
193 ; - optional
194 ;
195 ; Output
196 ;
197 ; 1^Version
198 ; or
199 ; -1^error message
200 ;
201 I $G(LEXVDT)'="" S LEXVDT=$$INTDAT(LEXVDT)
202 I $G(LEXVDT)=-1 Q "-1^invalid date format"
203 I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT
204 N SIEN,VIEN,VDAT,LEXSTAT
205 S SIEN=$O(^LEX(757.03,"B",LEXSRC,""))
206 I '$D(^LEX(757.03,SIEN,1)) Q "-1^No source version data available"
207 S LEXSTAT=$$STATCHK^LEXSRC2(LEXCODE,LEXVDT,.LEXSTAT)
208 I +LEXSTAT=0 Q "-1^Code not active for date specified"
209 S VDAT=$O(^LEX(757.03,SIEN,1,"B",LEXVDT+1),-1)
210 S VIEN=$O(^LEX(757.03,SIEN,1,"B",VDAT,""))
211 Q "1^"_^LEX(757.03,SIEN,1,VIEN,0)
212 ;
213 ;
214TXT4CS(LEXTEXT,LEXSRC,LEXRAY,LEXSUB) ; Is text valid for an SCT code
215 ;
216 ; Input
217 ;
218 ; LEXTEXT is term being checked
219 ; LEXSRC is code system mnemonic or IEN
220 ; LEXRAY output array (defaults to 'LEX') optional
221 ; LEXSUB subset or 'hierarchy' - optional
222 ;
223 ; Output
224 ;
225 ; 1^no of finds
226 ; plus
227 ; LEX or passed array name - an array containing discovered
228 ; concept IDs and expression type
229 ; for finds
230 ; e.g. LEX(113912006)="MAJOR CONCEPT"
231 ;
232 ; or
233 ;
234 ; -1^error message
235 ;
236 N EXP,EXIEN,MCIEN,FOUND,CIEN,CODE,EXPTYP,FINDS,LAR,HIER,HIERNAM,LEXW
237 I $G(LEXTEXT)="" Q "-1^text not specified"
238 I $G(LEXSRC)="" Q "-1^code system not specified"
239 I $$CSYSIEN(LEXSRC)+$$CSYSMNEM(LEXSRC)=-2 Q "-1^code system unknown in Lexicon"
240 I $G(LEXRAY)="" K LEXRAY
241 S LEXSUB=$G(LEXSUB)
242 I LEXSUB'="",'$D(^LEXT(757.2,"AA",LEXSUB)) Q "-1^hierarchy unknown in Lexicon"
243 S:LEXSRC?.N LEXSRC=$P($$CSYSMNEM(LEXSRC),"^",2)
244 ; text IEN's in 757.01
245 I '$D(^LEX(757.01,"B",$E($$UP^XLFSTR(LEXTEXT),1,63))) Q "-1^expression unknown in Lexicon"
246 ; build an array of expression IENs for text
247 S EXIEN=""
248 F S EXIEN=$O(^LEX(757.01,"B",$$UP^XLFSTR(LEXTEXT),EXIEN)) Q:EXIEN="" D
249 .S EXP(EXIEN)=""
250 ; scan array to find code for expression (LEXTEXT) for code system (LEXSRC)
251 S EXIEN=""
252 K LEXW
253 S (FOUND,FINDS)=0
254 F S EXIEN=$O(EXP(EXIEN)) Q:EXIEN="" D
255 .S MCIEN=$P(^LEX(757.01,EXIEN,1),U)
256 .S EXPTYP=$P(^LEX(757.011,$P(^LEX(757.01,EXIEN,1),U,2),0),U)
257 .S CIEN=""
258 .F S CIEN=$O(^LEX(757.02,"AMC",MCIEN,CIEN)) Q:CIEN="" D
259 ..I $P($$CSYSMNEM($P(^LEX(757.02,CIEN,0),U,3)),U,2)=LEXSRC D
260 ...S CODE=$P(^LEX(757.02,CIEN,0),U,2)
261 ...S (HIER,HIERNAM)=""
262 ...I LEXSUB'="" D
263 ....K LAR
264 ....S LAR=$$CODE(CODE,"SCT",,"LAR")
265 ....S HIER=$P(LAR(0),U,2)
266 ....S HIERNAM=$P(^LEXT(757.2,$O(^LEXT(757.2,"AA",LEXSUB,"")),0),U)
267 ...I LEXSUB'="",HIER'=HIERNAM Q
268 ...S FOUND=1
269 ...S FINDS=FINDS+1
270 ...S LEXW(CODE)=EXPTYP
271 M LEX=LEXW
272 I $D(LEXRAY),LEXRAY'="LEX" M @LEXRAY=LEX K LEX
273 Q FOUND_"^"_FINDS
274 ;
275CSYSIEN(MNEM) ; return code system IEN for mnemonic
276 I '$D(^LEX(757.03,"B",MNEM)) Q "-1^code system unknown in Lexicon"
277 Q "1^"_$O(^LEX(757.03,"B",MNEM,""))
278 ;
279CSYSMNEM(SIEN) ; return code system mnemonic for IEN
280 I '$D(^LEX(757.03,SIEN)) Q "-1^code system unknown in Lexicon"
281 Q "1^"_$P(^LEX(757.03,SIEN,0),"^")
282 ;
283INTDAT(X) ; convert date from external format to VA internal format
284 N Y
285 D ^%DT
286 Q Y
Note: See TracBrowser for help on using the repository browser.