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