source: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDCODE.m@ 636

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

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