source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDCODE.m@ 808

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1ICDCODE ;DLS/DEK/KER/FJF - ICD CODE APIS ; 09/20/07 8:54am
2 ;;18.0;DRG Grouper;**6,12,14,29**;Oct 20, 2000;Build 18
3 ;
4 ; External References
5 ; DBIA 10103 $$DT^XLFDT
6 ;
7ICDDX(CODE,CDT,DFN,SRC) ; Return ICD Dx Code Info
8 ;Input:
9 ; CODE Code/IEN (required)
10 ; CDT Date (default = TODAY)
11 ; DFN Not in use
12 ; SRC Source
13 ; 0 = exclude local codes
14 ; 1 = include local codes
15 ;
16 ;Output:
17 ; Returns an 19 piece string delimited by ^
18 ; 1 IEN of code in ^ICD9(
19 ; 2 ICD-9 Dx Code (#.01)
20 ; 3 Id (#2)
21 ; 4 Versioned Dx (67 multiple)
22 ; 5 Unacceptable as Principal Dx (#101)
23 ; 6 Major Dx Cat (#5)
24 ; 7 MDC13 (5.5)
25 ; 8 Compl/Comorb (#70)
26 ; 9 ICD Expanded (#8) 1:Yes 0:No
27 ; 10 Status (66 multiple)
28 ; 11 Sex (#9.5)
29 ; 12 Inactive Date (66 multiple)
30 ; 13 MDC24 (#5.7)
31 ; 14 MDC25 (#5.9)
32 ; 15 Age Low (#14)
33 ; 16 Age High (#15)
34 ; 17 Activation Date (.01 of 66 multiple)
35 ; 18 Message
36 ; 19 Versioned Complication/Comorbidity (#103)
37 ;
38 ; or
39 ;
40 ; -1^Error Description
41 ;
42 N DATA,EFF,INV,MDC,DRGFY
43 I $G(CODE)="" Q "-1^NO CODE SELECTED"
44 S INV="-1^INVALID CODE",CODE=+$$CODEN(CODE,80)
45 I CODE<1 Q INV
46 I '$D(^ICD9(CODE)) Q INV
47 I '$G(SRC),$P(^ICD9(CODE,0),U,8) Q "-1^VA LOCAL CODE SELECTED"
48 S DATA=$G(^ICD9(CODE,0)) I '$L(DATA) Q "-1^NO DATA"
49 S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT))
50 S EFF=$$EFF^ICDSUPT(80,CODE,CDT)
51 S $P(DATA,U,6)=$$VMDC^ICDREF(CODE)
52 S $P(DATA,U,9)=$S(EFF<1:0,1:$P(EFF,U))
53 S $P(DATA,U,11)=$P(EFF,U,2),$P(DATA,U,16)=$P(EFF,U,3)
54 S $P(DATA,U,3)=$$VSTD(CODE,CDT)
55 S $P(DATA,U,17)=$$MSG^ICDAPIU(CDT)
56 S $P(DATA,U,18)=$S($$COMCOM(CODE,CDT)'=-1:$$COMCOM(CODE,CDT),1:"")
57 Q CODE_U_DATA
58 ;
59ICDOP(CODE,CDT,DFN,SRC) ; Return ICD Operation/Procedure Code Info
60 ;Input:
61 ; CODE ICD code or IEN format, (required)
62 ; CDT Date (default = TODAY)
63 ; DFN Not in use
64 ; SRC Source
65 ; 0 = exclude local codes
66 ; 1 = include local codes
67 ;
68 ;Output:
69 ; Returns an 14 piece string delimited by ^
70 ; 1 IEN of code in ^ICD9(
71 ; 2 ICD-9 code (#.01)
72 ; 3 Id (#2)
73 ; 4 MDC24 (#5)
74 ; 5 Versioned Oper/Proc (67 multiple)
75 ; 6 <null>
76 ; 7 <null>
77 ; 8 <null>
78 ; 9 ICD Expanded (#8) 1:Yes 0:No
79 ; 10 Status (66 multiple)
80 ; 11 Use with Sex (#9.5)
81 ; 12 Inactive Date (66 multiple)
82 ; 13 Activation Date (66 multiple)
83 ; 14 Message
84 ;
85 ; or
86 ;
87 ; -1^Error Description
88 ;
89 N DATA,EFF,STR,INV
90 I $G(CODE)="" Q "-1^NO CODE SELECTED"
91 S INV="-1^INVALID CODE",CODE=+$$CODEN(CODE,80.1)
92 I CODE<1 Q INV
93 I '$D(^ICD0(CODE)) Q INV
94 I '$G(SRC),$P(^ICD0(CODE,0),U,8) Q "-1^VA LOCAL CODE SELECTED"
95 S DATA=$G(^ICD0(CODE,0)) I '$L(DATA) Q "-1^NO DATA"
96 S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT))
97 S EFF=$$EFF^ICDSUPT(80.1,CODE,CDT)
98 S $P(DATA,U,9)=$S(EFF<1:0,1:$P(EFF,U))
99 S $P(DATA,U,11,12)=$P(EFF,U,2,3)
100 S $P(DATA,U,4)=$$VSTP(CODE,CDT)
101 Q CODE_U_DATA_U_$$MSG^ICDAPIU(CDT)
102 ;
103ICDD(CODE,OUTARR,CDT) ; returns ICD description in array
104 ;Input:
105 ; CODE ICD Code or IEN (required)
106 ; ARY Array Name for description
107 ; e.g. "ABC" or "ABC("TEST")"
108 ; Default = ^TMP("ICDD",$J)
109 ; CDT Date (default = TODAY)
110 ;
111 ;Output:
112 ; # Number of lines in array
113 ;
114 ; @ARY(1:n) - Versioned Description (68 multiple)
115 ; @ARY(n+1) - blank
116 ; @ARY(n+1) - message: CODE TEXT MAY BE INACCURATE
117 ;
118 ; or
119 ;
120 ; -1^Error Description
121 ;
122 ; ** NOTE - USER MUST INITIALIZE ^TMP("ICDD",$J), IF USED **
123 ;
124 N ARR,END,I,N,GLOB,INV
125 I $G(CODE)="" Q "-1^NO CODE SELECTED"
126 S INV="-1^INVALID CODE"
127 I CODE?1.9N Q "-1^"_INV
128 S CODE=$$CODEN(CODE),GLOB=$P(CODE,"~",2),CODE=+CODE
129 I CODE<1!(GLOB["INVALID") Q INV ;if no code, return error
130 I '$D(@(GLOB_CODE_")")) Q INV ;if no code, return error
131 I $G(OUTARR)="" S OUTARR="^TMP(""ICDD"",$J,"
132 ;ensure OUTARR is proper format
133 I OUTARR'["(" S OUTARR=OUTARR_"("
134 I OUTARR[")" S OUTARR=$P(OUTARR,")")
135 S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
136 ;clear ^TMP("ICDD",$J - if used
137 I OUTARR="^TMP(""ICDD"",$J," K ^TMP("ICDD",$J)
138 S I=0,N=0,CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT))
139 S N=N+1,ARR=OUTARR_N_")",@ARR=$$VLT(CODE,CDT,GLOB)
140 S N=N+1,ARR=OUTARR_N_")",@ARR=" "
141 S N=N+1,ARR=OUTARR_N_")",@ARR=$$MSG^ICDAPIU(CDT)
142 Q N
143 ;
144CODEN(CODE,FILE) ; return ien of ICD code
145 ;Input:
146 ; CODE - ICD code (required)
147 ; FILE - File Number to search for code
148 ; 80 = ICD Dx file
149 ; 80.1 = ICD Oper/Proc file
150 ;
151 ;Output:
152 ; ien~global root
153 ; where global root is:
154 ; "^ICD9(" - File 80
155 ; "^ICD0(" - File 80.1
156 ; or
157 ; -1~error message
158 ;
159 I $G(CODE)="" Q "-1~NO CODE SELECTED"
160 N Y,GLOB,INV
161 S INV="INVALID ",CODE=$P(CODE," ")
162 ;use FILE if passed
163 I $G(FILE) D Q Y_"~"_GLOB
164 .S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:INV_"FILE")
165 .I $E(GLOB)'=U S Y=-1,GLOB=INV_"FILE" Q
166 .S Y=$S(CODE?1.9N:$$CODEZ(CODE,GLOB),1:$$CODEBA(CODE,GLOB))
167 ;FILE not passed - report where found
168 I CODE?1.9N S GLOB="^ICD9(",Y=$$CODEZ(CODE,GLOB) D G CODENQ
169 .I Y<1 S GLOB="^ICD0(",Y=$$CODEZ(CODE,GLOB)
170 S GLOB=$S(CODE?2N1"."1.3N:"^ICD0(",CODE?3N1".".3N!(CODE?1U2.3N1".".2N):"^ICD9(",1:-1)
171 S Y=$S('GLOB:$$CODEBA(CODE,GLOB),1:-1)
172CODENQ I Y<1 S GLOB=INV_"CODE"
173 Q Y_"~"_GLOB
174 ;
175CODEC(CODE,FILE) ;return the ICD code of an ien
176 ;Input:
177 ; CODE - IEN of ICD code REQUIRED
178 ; FILE - File Number to search for code
179 ; 80 = ICD Dx file
180 ; 80.1 = ICD Oper/Proc file
181 ;
182 ;Output: ICD code, -1 if not found
183 ;
184 S CODE=$G(CODE) Q:CODE'?1.9N -1
185 N Y,GLOB
186 I $G(FILE) D Q Y
187 .S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:-1)
188 .S Y=$S(GLOB<0:-1,1:$$CODEZ(CODE,GLOB))
189 ;FILE not passed - Search for 1st match
190 S Y=$$CODEZ(CODE,"^ICD9(",1)
191 Q $S(+Y<0:$$CODEZ(CODE,"^ICD0(",1),1:Y)
192 ;
193CODEZ(CODE,ROOT,FLG) ; Based on IEN/root:
194 N Y,ICDL ; if 'FLG return code existence, else zero node - piece 1
195 S Y=$P($G(@(ROOT_CODE_",0)")),U),ICDL=$L(Y) I ICDL,'$G(FLG) Q CODE
196 Q $S('ICDL:-1,1:Y)
197CODEBA(CODE,ROOT) ; Return IEN based on code/root
198 N IEN
199 S IEN=$O(@(ROOT_"""BA"","""_CODE_" "","""")"),-1)
200 Q $S('IEN:-1,1:IEN)
201 ;
202COMCOM(IEN,VDT) ; Return versioned complication/comorbidity
203 ;returns a code for complication/comorbidity
204 ; 0 - non-CC
205 ; 1 - CC
206 ; 2 - MCC
207 ; -1 - versioned CC not on file for date
208 N CCDATE,CCIEN
209 S CCDATE=$O(^ICD9(IEN,69,"B",VDT+.0001),-1)
210 I CCDATE="" Q -1
211 S CCIEN=$O(^ICD9(IEN,69,"B",CCDATE,""),-1)
212 Q $P(^ICD9(IEN,69,CCIEN,0),U,2)
213 ;
214VST(IEN,VDT,TYPE) ; Versioned Short Text
215 Q:TYPE["ICD9(" $$VSTD($G(IEN),$G(VDT))
216 Q:TYPE["ICD0(" $$VSTP($G(IEN),$G(VDT))
217 Q ""
218VSTD(IEN,VDT) ; Versioned Short Text (Dx)
219 N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT S ICDI=+($G(IEN)) Q:+ICDI'>0 "" Q:'$D(^ICD9(+ICDI)) ""
220 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N "" S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0,U,1) Q:'$L(ICDC) ""
221 S STD=$O(^ICD9("AST",(ICDC_" "),(ICDT+.000001)),-1)
222 I +STD>0 D Q:$L($G(TXT)) $G(TXT)
223 .S STI=$O(^ICD9("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),U,2))
224 S STD=$O(^ICD9(+ICDI,67,"B",0)) I +STD>0 D Q:$L($G(TXT)) $G(TXT)
225 .S STI=$O(^ICD9(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),U,2))
226 Q $$TRIM($P(ICD0,U,3))
227VSTP(IEN,VDT) ; Versioned Short Text (Proc)
228 N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT S ICDI=+($G(IEN)) Q:+ICDI'>0 "" Q:'$D(^ICD0(+ICDI)) ""
229 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N "" S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0,U,1) Q:'$L(ICDC) ""
230 S STD=$O(^ICD0("AST",(ICDC_" "),(ICDT+.000001)),-1)
231 I +STD>0 D Q:$L($G(TXT)) $G(TXT)
232 .S STI=$O(^ICD0("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),U,2))
233 S STD=$O(^ICD0(+ICDI,67,"B",0)) I +STD>0 D Q:$L($G(TXT)) $G(TXT)
234 .S STI=$O(^ICD0(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),U,2))
235 Q $$TRIM($P(ICD0,U,4))
236VLT(IEN,VDT,TYPE) ; Version Description - Long Text
237 Q:TYPE["ICD9(" $$VLTD($G(IEN),$G(VDT))
238 Q:TYPE["ICD0(" $$VLTP($G(IEN),$G(VDT))
239 Q ""
240VLTD(IEN,VDT) ; Versioned Description - Long Text (Dx)
241 N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT
242 S ICDI=+($G(IEN)) Q:+ICDI'>0 "" Q:'$D(^ICD9(+ICDI)) ""
243 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N ""
244 S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0,U,1) Q:'$L(ICDC) ""
245 S STD=$O(^ICD9("ADS",(ICDC_" "),(ICDT+.000001)),-1)
246 I +STD>0 D Q:$L($G(TXT)) $G(TXT)
247 .S STI=$O(^ICD9("ADS",(ICDC_" "),STD,+ICDI," "),-1)
248 .S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),U,1))
249 S STD=$O(^ICD9(+ICDI,68,"B",0))
250 I +STD>0 D Q:$L($G(TXT)) $G(TXT)
251 .S STI=$O(^ICD9(+ICDI,68,"B",STD,0))
252 .S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),U,1))
253 S TXT=$$TRIM($G(^ICD9(+ICDI,1))) Q:$L($G(TXT)) $G(TXT)
254 Q $$TRIM($P(ICD0,U,3))
255VLTP(IEN,VDT) ; Versioned Description - Long Text (Proc)
256 N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT
257 S ICDI=+($G(IEN)) Q:+ICDI'>0 "" Q:'$D(^ICD0(+ICDI)) ""
258 S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N ""
259 S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0,U,1) Q:'$L(ICDC) ""
260 S STD=$O(^ICD0("ADS",(ICDC_" "),(ICDT+.000001)),-1)
261 I +STD>0 D Q:$L($G(TXT)) $G(TXT)
262 .S STI=$O(^ICD0("ADS",(ICDC_" "),STD,+ICDI," "),-1)
263 .S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),U,1))
264 S STD=$O(^ICD0(+ICDI,68,"B",0))
265 I +STD>0 D Q:$L($G(TXT)) $G(TXT)
266 .S STI=$O(^ICD0(+ICDI,68,"B",STD,0))
267 .S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),U,1))
268 S TXT=$$TRIM($G(^ICD0(+ICDI,1))) Q:$L($G(TXT)) $G(TXT)
269 Q $$TRIM($P(ICD0,U,4))
270TRIM(X) ; Trim Spaces
271 S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
272 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
273 F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
274 Q X
Note: See TracBrowser for help on using the repository browser.