ICDTBL2G ;ALB/JDG - GROUPER UTILITY FUNCTIONS;08/09/2010
;;18.0;DRG Grouper;**77,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^ICDTBL9G 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)
I $D(ICDOP(" 35.05"))!($D(ICDOP(" 35.06")))!($D(ICDOP(" 35.07")))!($D(ICDOP(" 35.08")))!($D(ICDOP(" 35.09"))) D DRG266 Q
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
DRG266 ;
DRG267 S ICDRG=$S(ICDMCC=2:266,1:267) 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^ICDTBL9G 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^ICDTBL2G Q
I ICDPDRG["308^309^310^",$G(ICDOPFLG)=1 D DRG310^ICDTBL3G 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,ICDCC2=0,ICDCC3=0 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[HICDTBL2G 9126 printed Dec 13, 2024@01:51:28 Page 2
ICDTBL2G ;ALB/JDG - GROUPER UTILITY FUNCTIONS;08/09/2010
+1 ;;18.0;DRG Grouper;**77,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^ICDTBL9G
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 IF $DATA(ICDOP(" 35.05"))!($DATA(ICDOP(" 35.06")))!($DATA(ICDOP(" 35.07")))!($DATA(ICDOP(" 35.08")))!($DATA(ICDOP(" 35.09")))
DO DRG266
QUIT
+9 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
DRG266 ;
DRG267 SET ICDRG=$SELECT(ICDMCC=2:266,1:267)
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^ICDTBL9G
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^ICDTBL2G
QUIT
+4 IF ICDPDRG["308^309^310^"
IF $GET(ICDOPFLG)=1
DO DRG310^ICDTBL3G
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 ICDCC2=0
IF ICDCC3=0
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
