Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDTBL2F

ICDTBL2F.m

Go to the documentation of this file.
  1. ICDTBL2F ;ALB/JDG - GROUPER UTILITY FUNCTIONS;08/09/2010
  1. ;;18.0;DRG Grouper;**72,79**;Oct 20, 2000;Build 6
  1. DRG200 ;
  1. DRG201 I ICDSD["c" S ICDRG=$S(ICDMCC=2:199,ICDMCC=1:200,1:201) Q
  1. S ICDRG=$S(ICDMCC=2:199,ICDMCC=1:200,1:201) Q
  1. DRG202 ;
  1. DRG203 S ICDRG=$S(ICDMCC>0:202,1:203) Q
  1. DRG204 S ICDRG=204 Q
  1. DRG205 ;
  1. DRG206 S ICDRG=$S(ICDMCC=2:205,1:206) Q
  1. DRG207 S ICDRG=207 Q
  1. DRG208 I ICDOR["o"!(ICDOR["V") D DRG982^ICDTBL9F Q
  1. S ICDRG=208 Q
  1. DRG215 S ICDRG=215 Q
  1. DRG216 ;valve procedures
  1. N ICDE1,ICDE2
  1. S ICDE1=$S($D(ICDOP(" 37.95"))&($D(ICDOP(" 37.96"))):1,1:0),ICDE2=$S($D(ICDOP(" 37.97"))&($D(ICDOP(" 37.98"))):1,1:0)
  1. S:ICDOR["H" ICDRG=$S(ICDOR["N"&ICDE1:218,ICDOR["N"&ICDE2:218,ICDOR["O":218,1:ICDRG)
  1. S:ICDOR'["H" ICDRG=$S(ICDOR["N"&ICDE1:221,ICDOR["N"&ICDE2:221,ICDOR["O":221,1:ICDRG)
  1. I ICDOR["P"&(ICDE1+ICDE2=0) S ICDRG=$S(ICDOR["H"&('$D(ICDOP(" 37.68"))):218,1:221)
  1. S:ICDRG=218 ICDRG=$S(ICDMCC=2:216,ICDMCC=1:217,1:218)
  1. S:ICDRG=221 ICDRG=$S(ICDMCC=2:219,ICDMCC=1:220,1:221)
  1. Q
  1. DRG217 D DRG216 Q
  1. DRG218 D DRG216 Q
  1. DRG219 D DRG216 Q
  1. DRG220 D DRG216 Q
  1. DRG221 D DRG216 Q
  1. DRG222 N ICDE1,ICDE2,ICDE3,ICDE4
  1. S ICDE1=$S($D(ICDOP(" 37.95"))&(($D(ICDOP(" 37.96")))!($D(ICDOP(" 00.54")))):1,1:0)
  1. S ICDE2=$S($D(ICDOP(" 37.97"))&(($D(ICDOP(" 37.98")))!($D(ICDOP(" 00.54")))):1,1:0)
  1. S ICDE3=$S($D(ICDOP(" 00.52"))&($D(ICDOP(" 00.54"))):1,1:0)
  1. ;S ICDE4=$S($D(ICDOP(" 00.54"))&($D(ICDOP(" 37.95"))):1,1:0)
  1. S ICDE4=$S($D(ICDOP(" 37.74"))&(($D(ICDOP(" 37.96")))!($D(ICDOP(" 37.98")))!($D(ICDOP(" 00.54")))):1,1:0)
  1. S ICDRG=999
  1. I $D(ICDOP(" 37.94"))!$D(ICDOP(" 00.51")) I ICDE1+ICDE2+ICDE3+ICDE4=0 D
  1. . S ICDRG=$S(ICDMCC=2:226,1:227)
  1. I '$D(ICDOP(" 37.94"))&('$D(ICDOP(" 00.51"))) I ICDE1!ICDE2!ICDE3!ICDE4 D
  1. . S ICDRG=$S(ICDMCC=2:226,1:227)
  1. ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
  1. I (ICDRG=226)!(ICDRG=227) I ICDOR["HN" I '$D(ICDOP(" 37.26")) S ICDRG=$S((ICDPD["A")&(ICDMCC=2):222,(ICDDX(1)=12444)&($D(ICDDXT("428.23")))&($D(ICDDXT("785.51")))&(ICDMCC=2):222,ICDPD["A":223,ICDMCC=2:224,1:225)
  1. I ICDRG=470 D CMS115
  1. Q
  1. DRG223 D DRG222 Q
  1. DRG224 ;
  1. DRG225 D DRG222 Q
  1. DRG226 ;
  1. DRG227 D DRG222 Q
  1. DRG228 ;
  1. DRG229 ;
  1. DRG230 ;DRGs 228-230 note ICDOR["Oo" = operation and DRG CMS108/MS230 procedure
  1. I $D(ICDOP(" 35.33")) D DRG221 Q
  1. I ICDOR["Oo"!($D(ICDOP(" 38.44"))&($D(ICDOP(" 38.45")))) D Q
  1. . S ICDRG=$S(ICDMCC=2:228,ICDMCC=1:229,1:230) Q
  1. G DRG237
  1. DRG231 S ICDRG=999
  1. I ICDOR["b" D DRG235
  1. I ICDOR["b" I $D(ICDOP(" 35.96"))!($D(ICDOP(" 00.66"))) D Q
  1. . S ICDRG=$S(ICDMCC=2:231,1:232)
  1. I ICDOR["b" I $D(ICDOP(" 37.21"))!($D(ICDOP(" 37.22")))!($D(ICDOP(" 37.23"))) D DRG233 Q
  1. I ICDRG'=231&(ICDRG'=232)&(ICDRG'=233)&(ICDRG'=234)&(ICDRG'=235)&(ICDRG'=236) S ICDRG=999 D DRG237
  1. Q
  1. DRG232 D DRG231 Q
  1. DRG233 ; called from DRG231
  1. D MCV
  1. S ICDRG=$S(ICDMCV:233,ICDMCV1:233,1:234)
  1. S ICDRG=$S(ICDMCC=2:233,1:234)
  1. Q
  1. DRG234 D DRG233 Q
  1. DRG235 ;
  1. DRG236 S ICDRG=$S(ICDMCC=2:235,1:236) Q
  1. DRG237 I ICDOR["Oo" D DRG228
  1. S ICDRG=$S((ICDMCC=2)&(ICDOR[7):237,ICDOR[7:238,1:ICDRG)
  1. I ICDDX(1)=12460,$D(ICDDXT("785.51")),ICDRG=237,ICDEXP=1 S ICDRG=238
  1. I "228^229^230^237^238"[ICDRG Q
  1. ;I $D(ICDJJ(478))&('$D(ICDJJ(110))&'($D(ICDJJ(111)))) D DRG478^ICDTBL6C
  1. D DRG239 I "239^240^241"[ICDRG Q
  1. I ICDOR["p" D DRG260
  1. I ICDOR["1" D CMS516
  1. Q
  1. DRG238 S ICDRG=$S(ICDMCC=2:237,1:238) Q
  1. DRG239 ;239-241
  1. DRG240 ;
  1. DRG241 S ICDRG=$S($D(ICDJJ(241)):241,1:ICDRG)
  1. I ICDRG=241 S ICDRG=$S(ICDMCC=2:239,ICDMCC=1:240,1:241)
  1. Q
  1. DRG242 ; called from CMS115
  1. D MCV
  1. I ICDMCV!(ICDMCV1) D
  1. . S ICDRG=$S(ICDMCC=2:242,ICDMCC=1:243,1:244)
  1. Q
  1. DRG243 D CMS115 Q
  1. DRG244 D CMS115 Q
  1. DRG245 I $D(ICDOP(" 37.95"))!($D(ICDOP(" 37.97")))!($D(ICDOP(" 00.52"))) D DRG265 Q
  1. E S ICDRG=245 Q
  1. DRG246 ;
  1. D MCV
  1. I ICDMCV!ICDMCV1 S ICDRG=246
  1. E S ICDRG=247
  1. S ICDRG=$S(ICDMCC=2:246,1:247) D Q
  1. . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.43")) S ICDRG=246
  1. . I $D(ICDOP(" 36.07")),$D(ICDOP(" 00.43")) S ICDRG=246
  1. . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.48")) S ICDRG=246
  1. . I $D(ICDOP(" 36.07")),$D(ICDOP(" 00.48")) S ICDRG=246
  1. Q
  1. DRG247 D CMS516 Q
  1. DRG248 ;Called from CMS516
  1. D MCV
  1. I ICDMCV!(ICDMCV1) S ICDRG=248
  1. S ICDRG=$S(ICDMCC=2:248,1:249) D Q
  1. . I $D(ICDOP(" 36.06")),$D(ICDOP(" 00.43")) S ICDRG=248
  1. . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.43")) S ICDRG=248
  1. . I $D(ICDOP(" 36.06")),$D(ICDOP(" 00.48")) S ICDRG=248
  1. . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.48")) S ICDRG=248
  1. Q
  1. DRG249 ;Called from CMS516
  1. D MCV
  1. I 'ICDMCV&('ICDMCV1) S ICDRG=249
  1. S ICDRG=$S(ICDMCC=2:248,1:249) D Q
  1. . I $D(ICDOP(" 36.06")),$D(ICDOP(" 00.43")) S ICDRG=248
  1. . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.43")) S ICDRG=248
  1. . I $D(ICDOP(" 36.06")),$D(ICDOP(" 00.48")) S ICDRG=248
  1. . I $D(ICDOP(" 00.66")),$D(ICDOP(" 00.48")) S ICDRG=248
  1. Q
  1. DRG250 ;
  1. DRG251 S ICDRG=$S(ICDMCC=2:250,1:251) Q
  1. DRG252 ;
  1. DRG253 ;
  1. DRG254 S ICDRG=$S(ICDMCC=2:252,ICDMCC=1:253,1:254) Q
  1. DRG255 ;
  1. DRG256 ;
  1. DRG257 S ICDRG=$S(ICDMCC=2:255,ICDMCC=1:256,1:257) Q
  1. DRG258 ;I ICDOR["p"
  1. DRG259 D CMS115 I "242^243^244^291^292^293"[ICDRG Q
  1. S ICDRG=$S(ICDMCC=2:258,1:259) Q
  1. DRG260 ;
  1. D CMS115 I "242^243^244^291^292^293"[ICDRG Q
  1. D DRG258 I $D(ICDOP(" 00.56")) S ICDRG=264 Q
  1. I ICDOR["p" S ICDRG=$S(ICDMCC=2:260,ICDMCC=1:261,1:262)
  1. Q
  1. DRG261 D DRG260 Q
  1. DRG262 D DRG260 Q
  1. DRG263 S ICDRG=263 Q
  1. DRG264 S ICDRG=264 Q
  1. DRG265 S ICDRG=265 Q
  1. DRG280 ;
  1. DRG281 ;
  1. DRG282 I ICDPD="" S ICDRG=282
  1. I ICDDX(1)=13639,$D(ICDDXT("410.71")),$D(ICDDXT("428.0")),ICDMCC=2 S ICDMCC=0
  1. I ICDDX(1)=9061,$D(ICDDXT("491.21"))&$D(ICDDXT("410.71")) S ICDMCC=1
  1. I ICDPD["I"&(ICDSD'["I") S ICDRG=$S(ICDMCC=2:280,ICDMCC=1:281,1:282) Q
  1. I ICDPD["I"&(ICDSD'["c") S ICDRG=$S(ICDMCC=2:280,ICDMCC=1:281,1:282) Q
  1. I ICDPD["I"&(ICDSD'["S") S ICDRG=$S(ICDMCC=2:280,ICDMCC=1:281,1:282) Q
  1. I ICDPD["c"&(ICDSD'["I") S ICDRG=$S(ICDMCC=2:280,ICDMCC=1:281,1:282) Q
  1. I ICDPD["c"&(ICDSD'["c") S ICDRG=$S(ICDMCC=2:280,ICDMCC=1:281,1:282) Q
  1. I ICDPD["c"&(ICDSD'["S") S ICDRG=$S(ICDMCC=2:280,ICDMCC=1:281,1:282) Q
  1. I $G(ICDDX(1))=2477!(ICDPD["HJV")&(ICDSD["AI"),ICDMCC=2 S ICDRG=281 Q
  1. S ICDRG=$S(ICDMCC=2&(ICDSD["H"):280,ICDMCC=1&(ICDSD["H"):281,1:282) Q
  1. DRG283 ;
  1. DRG284 ;
  1. DRG285 ;
  1. I $D(ICDDXT("427.41"))&$D(ICDDXT("427.5")) S ICDMCC=1
  1. S ICDRG=$S(ICDMCC=2:283,ICDMCC=1:284,1:285) Q
  1. DRG286 ;
  1. DRG287 I ICDMAJ'=""&(ICDMAJ'["A") D DRG982^ICDTBL9F Q
  1. I '$D(ICDOP(" 37.21"))!('$D(ICDOP(" 37.22")))!('$D(ICDOP(" 37.23")))!('$D(ICDOP(" 88.52")))!('$D(ICDOP(" 88.53"))) S ICDOPFLG=1
  1. I '$D(ICDOP(" 88.54"))!('$D(ICDOP(" 88.55")))!('$D(ICDOP(" 88.56")))!('$D(ICDOP(" 88.57")))!('$D(ICDOP(" 88.58"))) S ICDOPFLG=1
  1. I ICDPDRG["291^292^",$G(ICDOPFLG)=1 D DRG293^ICDTBL2F Q
  1. I ICDPDRG["308^309^310^",$G(ICDOPFLG)=1 D DRG310^ICDTBL3F Q
  1. S ICDRG=$S(ICDMCC=2:286,1:287) Q
  1. DRG288 ;
  1. DRG289 ;
  1. DRG290 S ICDRG=$S(ICDMCC=2:288,ICDMCC=1:289,1:290) Q
  1. DRG291 ;
  1. DRG292 ;
  1. DRG293 I ICDOR["K" D DRG252 Q
  1. I ICDOR["P" D DRG260 Q
  1. I (ICDDX(1)=5458!$D(ICDDXT("785.51"))),'ICDEXP S ICDMCC=2
  1. I (ICDDX(1)=2480&$D(ICDDXT("428.33"))) S ICDMCC=1
  1. S ICDRG=$S(ICDMCC=2:291,ICDMCC=1:292,1:293) Q
  1. DRG294 ;
  1. DRG295 S ICDRG=$S(ICDMCC>0:294,1:295) Q
  1. DRG296 ;
  1. DRG297 ;
  1. DRG298 I (ICDDX(1)=2561!$D(ICDDXT(" 427.5"))),'ICDEXP S ICDMCC=2
  1. S ICDRG=$S(ICDMCC=2:296,ICDMCC=1:297,1:298) Q
  1. DRG299 S ICDRG=$S(ICDMCC=2:299,ICDMCC=1:300,1:301) Q
  1. Q
  1. CMS115 ;convert DRG115^ICDTBL2D code - no MS-DRG 115 existed
  1. D EN1^ICDDRG5
  1. I ICDOR[7,'$D(ICDCC2)!('$D(ICDCC3)) S ICDRG=$S(ICDMCC=2:260,ICDMCC=1:261,1:262) Q
  1. I ICDPD'["I"&(ICDOR'["p")&(ICDCC2=0)&(ICDCC3=0) D Q
  1. .I ICDSD["Z",ICDPDRG["^291^292^293" S ICDMCC=0
  1. .S ICDRG=$S(ICDMCC=2:291,ICDMCC=1:292,1:293)
  1. I ICDCC2=1!(ICDCC3=1) D DRG242
  1. I ((ICDRG>241)&(ICDRG<245)) Q
  1. ; ICDCC2 identifies AICD LEAD OR GNRTR
  1. I ICDCC2=1!(ICDCC3=1) D Q
  1. . S ICDRG=$S(ICDMCC=2:242,ICDMCC=1:243,1:244) Q
  1. I ICDOR["p" D Q
  1. . S ICDRG=$S(ICDMCC=2:242,ICDMCC=1:243,1:244) Q
  1. Q
  1. CMS516 ;convert DRG516^ICDTBL6D code - no MS-DRG 516 exists
  1. I $D(ICDOP(" 37.72")),$D(ICDOP(" 37.83")),"242^243^244"[ICDRG Q
  1. S ICDRG=250
  1. I '$D(ICDOP(" 36.06"))&'$D(ICDOP(" 92.27"))&'$D(ICDOP(" 36.07")) D DRG251
  1. E D DRG248
  1. ;I $D(ICDOP(" 36.06"))!$D(ICDOP(" 92.27")) D DRG249
  1. I $D(ICDOP(" 36.07")) D DRG246
  1. Q
  1. MCV ; checks to see if case qualifies as an MCV (major cardiovascular complications or complex conditions)
  1. S (ICDMCV,ICDMCV1,ICDMCV2)=0
  1. ; ICDPD=identifier for prime dx ICDSD=identifier for any secondary dx
  1. ; DGDX(1)=prime dx ICDDX(1)=ien of prime dx ICDDXT=any secondary dx
  1. I ICDPD["c"!(ICDSD["c") S ICDMCV=1
  1. I ICDSD["s" S ICDMCV=1
  1. ;I DGDX(1)["426.0"!(DGDX(1)["426.53")!(DGDX(1)["426.54") S ICDMCV1=1
  1. I $G(ICDDX(1))=9056!($G(ICDDX(1))=2548)!($G(ICDDX(1))=2549) S ICDMCV1=1
  1. I $D(ICDDXT("426.0"))!($D(ICDDXT("426.53")))!($D(ICDDXT("426.54"))) S ICDMCV1=1
  1. ;I DGDX(1)["411.1"!(DGDX(1)["411.81") S ICDMCV2=1
  1. I $G(ICDDX(1))=2500!($G(ICDDX(1))=12477) S ICDMCV2=1
  1. I $D(ICDDXT("411.1"))!($D(ICDDXT("411.81"))) S ICDMCV2=1
  1. Q