ICDTLB6C ;ALB/EG/MRY/KUM - GROUPER UTILITY FUNCTIONS FY 2007;9/29/03 2:47pm
;;18.0;DRG Grouper;**24,30,64**;Oct 20, 2000;Build 103
;
DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG405 D DRG404 Q
DRG406 ;
I ICDORNI["K" D
.S ICDRG=$S((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDCC:406,1:407)
I ICDORNI'["K" D DRG408
Q
DRG407 D DRG406 Q
DRG408 I $D(ICDDX(1))&(ICDOPCT=0) D Q:ICDRG=409
.I ICDDX(1)=$$CODEBA^ICDEX("V58.0",80) S ICDRG=409 Q
.I ICDDX(1)=$$CODEBA^ICDEX("V67.1",80) S ICDRG=409 Q
.Q
I $D(ICDDX(1))&(ICDOPCT=0) D Q:"410^492"[ICDRG
.I ICDDX(1)=$$CODEBA^ICDEX("V58.11",80) S ICDRG=$S(ICDSD["2":492,1:410) Q
.I ICDDX(1)=$$CODEBA^ICDEX("V58.12",80) S ICDRG=$S(ICDSD["2":492,1:410) Q
.I ICDDX(1)=$$CODEBA^ICDEX("V67.2",80) S ICDRG=$S(ICDSD["2":492,1:410) Q
I ICDOPCT>0 S ICDRG=$S(ICDPD'["L":408,ICDCC:401,1:402) Q
I ICDOPCT=0 D DRG412
Q
DRG411 S ICDRG=$S(ICDOR["O"!(ICDORNI["O"):408,ICDOR["N":412,1:411) Q
DRG412 ;S ICDRG=$S(ICDOR["O"!(ICDORNI["O"):408,ICDOR["N"&($D(ICDPDRG(412))):412,$D(ICDPDRG(411)):411,ICDCC:413,1:414)
I ICDOPCT>0 D DRG408 Q
D DRG412^ICDTLB61
Q
DRG413 S ICDRG=$S(ICDCC:413,1:414) Q
DRG414 S ICDRG=$S(ICDCC:413,1:414) Q
DRG416 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE>17:576,1:417),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) I ICDRG=576&($D(ICDOP(" 96.72"))) S ICDRG=575
Q
DRG417 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE>17:576,1:417),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG418 S ICDRG=$S(ICDOR["O":579,1:418) Q
DRG419 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE<18:422,ICDCC:419,1:420),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG420 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE<18:422,ICDCC:419,1:420),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG421 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE>17:421,1:422),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG422 S ICDRG=$S(ICDOR["O":578,AGE="":470,AGE>17:421,1:422),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
DRG423 S ICDRG=$S(ICDOR["O":578,1:423) I ICDRG=578&(ICDDX(1)=7615) S ICDRG=579
Q
DRG424 S ICDRG=$S(ICDOR["O":424,1:425) Q
DRG425 S ICDRG=$S(ICDOR["O":424,1:425) Q
DRG426 S ICDRG=$S(ICDOR["O":424,1:426) Q
DRG427 S ICDRG=$S(ICDOR["O":424,1:427) Q
DRG428 S ICDRG=$S(ICDOR["O":424,1:428) Q
DRG429 S ICDRG=$S(ICDOR["O":424,1:429) Q
DRG430 S ICDRG=$S(ICDOR["O":424,1:430) Q
DRG431 S ICDRG=$S(ICDOR["O":424,1:431) Q
DRG432 S ICDRG=$S(ICDOR["O":424,1:432) Q
DRG434 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
DRG435 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
DRG436 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
DRG437 S ICDRG=$S(ICDPD["t"!(ICDSD["t"):$S(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435) Q
DRG439 S ICDRG=$S($D(ICDODRG(440)):440,1:439) Q
DRG442 S ICDRG=$S(ICDCC:442,1:443) Q
DRG443 D EN1^ICDDRG5 S ICDRG=$S(ICDCC3:$S(ICDCC:442,1:443),1:"") Q
DRG444 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG445 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG446 S ICDRG=$S(AGE<18:446,ICDCC:444,1:445) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG447 S ICDRG=$S(AGE>17:447,1:448) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG448 S ICDRG=$S(AGE>17:447,1:448) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG449 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG450 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG451 S ICDRG=$S(AGE<18:451,ICDCC:449,1:450) I AGE="" S ICDRG=470,ICDRTC=3
Q
DRG452 S ICDRG=$S(ICDCC:452,1:453) Q
DRG453 S ICDRG=$S(ICDCC:452,1:453) Q
DRG454 S ICDRG=$S(ICDCC:454,1:455) Q
DRG455 S ICDRG=$S(ICDCC:454,1:455) Q
DRG462 S ICDRG=$S(ICDOR["O":461,1:462) Q
DRG463 S ICDRG=$S(ICDOR["O":461,ICDCC:463,1:464) Q
DRG464 S ICDRG=$S(ICDOR["O":461,ICDCC:463,1:464) Q
DRG465 S ICDRG=$S(ICDOR["O":461,ICDSD["m":465,1:466) Q
DRG466 S ICDRG=$S(ICDOR["O":461,ICDSD["m":465,1:466) Q
DRG467 S ICDRG=$S(ICDOR["O":461,1:467) Q
DRG471 S ICDRG=$S($F($P(ICDOR,"M",2,99),"M"):471,1:"") Q
DRG475 S ICDRG=$S(ICDOR["V":475,1:$S($D(ICDPDRG):$O(ICDPDRG(0)),1:468)) I ICDRG<468 D DODRG^ICDDRG0
Q
DRG478 S ICDRG=$S(ICDOR["O"&ICDCC:478,1:479)
I ICDRG=478 D DRG553^ICDTLB6C
Q
DRG479 G DRG478
DRG493 ;I (ICDI-1)=1,'ICDCC S ICDCC=$S($D(^ICD9("ACC",ICDDX(1),ICDDX(1))):1,1:0)
S ICDRG=$S(ICDCC:493,1:494) Q
DRG494 ;I (ICD-1),'ICDCC S ICDCC=$S($D(^ICD9("ACC",ICDDX(1),ICDDX(1))):1,1:0)
S ICDRG=$S(ICDCC:493,1:494) Q
DRG495 Q
DRG496 S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498)
I ICDRG=497!(ICDRG=498) I ICDPD["6" S ICDRG=546 Q
I ICDRG=497!(ICDRG=498) I $D(ICDDXT("737.40"))!($D(ICDDXT("737.41")))!($D(ICDDXT("737.42")))!($D(ICDDXT("737.43"))) S ICDRG=546
Q
DRG497 G DRG496 ;S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
DRG498 G DRG496 ;S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
DRG499 S ICDRG=$S(ICDCC:499,1:500) Q
DRG500 S ICDRG=$S(ICDCC:499,1:500) Q
DRG501 D
. I (ICDPD["k") D
.. I ICDCC S ICDRG=501
.. I 'ICDCC S ICDRG=502
. E S ICDRG=503
Q
DRG502 D DRG501 Q
DRG503 D DRG501 Q
DRG514 ; Replaced with DRG535
N ICDE1,ICDE2
S ICDE1=$S($D(ICDOP(" 37.95"))&($D(ICDOP(" 37.96"))):1,1:0)
S ICDE2=$S($D(ICDOP(" 37.97"))&($D(ICDOP(" 37.98"))):1,1:0)
S ICDRG=470
I $D(ICDOP(" 37.94")) I ICDE1+ICDE2=0 S ICDRG=515
I '$D(ICDOP(" 37.94")) I ICDE1!ICDE2 S ICDRG=515
; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
I ICDRG=515 I ICDOR["HN" S ICDRG=514
Q
DRG515 D DRG535 Q
DRG516 ; DRG 516,517,526 and 527 replaced by DRG 555-558 respectively
; ICD*18*30 DRG551 is higher in surgical hierarchy
I ICDRG=551 Q
S ICDRG=518
D DRG555
I $D(ICDOP(" 36.06"))!$D(ICDOP(" 92.27")) D DRG556
I $D(ICDOP(" 36.07")) D DRG557
Q
DRG517 D DRG516 Q
DRG518 D DRG516 Q
DRG519 S ICDRG=$S(ICDOR["F":496,ICDCC:519,1:520) Q
DRG520 D DRG519 Q
DRG521 S ICDRG=$S(ICDCC:521,ICDOR["D"!(ICDOR["R"):522,1:523) Q
DRG522 D DRG521 Q
DRG523 D DRG521 Q
DRG526 D DRG516 Q
DRG527 D DRG516 Q
DRG531 S ICDRG=$S(ICDCC:531,1:532) Q
DRG532 D DRG531 Q
DRG533 S ICDRG=$S(ICDCC:533,1:534) I $D(ICDOP(" 00.61"))&($D(ICDOP(" 00.63"))) S ICDRG=577
Q
DRG534 D DRG533 Q
DRG535 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=470
I $D(ICDOP(" 37.94"))!$D(ICDOP(" 00.51")) I ICDE1+ICDE2+ICDE3+ICDE4=0 S ICDRG=515
I '$D(ICDOP(" 37.94"))&('$D(ICDOP(" 00.51"))) I ICDE1!ICDE2!ICDE3!ICDE4 S ICDRG=515
; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
I ICDRG=515 I ICDOR["HN" I '$D(ICDOP(" 37.26")) S ICDRG=$S(ICDPD["A":535,1:536)
I ICDRG=470 D DRG115^ICDTLB2C
Q
DRG536 D DRG535 Q
DRG537 S ICDRG=$S(ICDCC:537,1:538) Q
DRG538 D DRG537 Q
DRG539 I ICDPD["L"&(ICDMAJ'[3) D DRG401^ICDTLB5C Q:"401^402^403^404^405^470^473"[ICDRG
S ICDRG=$S((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDCC:406,1:407) Q
DRG540 D DRG539 Q
DRG543 S ICDRG=$S((ICDPD["Q")&(ICDOR["Q"):543,ICDOR["Q"&$D(ICDOP(" 00.10")):543,$D(ICDOP(" 02.93"))&($D(ICDOP(" 86.95"))):543,1:ICDRG) Q
DRG544 Q
DRG545 Q
DRG546 Q
DRG547 ; called from DRG106^ICDTLB2C
D MCV
S ICDRG=$S(ICDMCV:547,ICDMCV1:547,1:548) Q
DRG548 G DRG547
DRG549 ; called from DRG106^ICDTLB2C
D MCV
S ICDRG=$S(ICDMCV:549,ICDMCV1:549,1:550) Q
DRG550 G DRG549
DRG551 ; called from DRG115^ICDTLB2C
D MCV
I ICDMCV!(ICDMCV2) S ICDRG=551
Q
DRG552 Q
DRG553 ; called from DRG478
D MCV
S ICDRG=$S(ICDMCV:553,ICDMCV1:553,1:554) Q
DRG554 G DRG553
DRG555 ; called from DRG516
D MCV
I ICDMCV!(ICDMCV1) S ICDRG=555
Q
DRG556 ; called from DRG516
D MCV
I 'ICDMCV&('ICDMCV1) S ICDRG=556
Q
DRG557 ; called from DRG516
D MCV
I ICDMCV!ICDMCV1 S ICDRG=557
E S ICDRG=558
Q
DRG558 G DRG516
DRG559 ;I DGDX(1)["433.01"!(DGDX(1)["433.11")!(DGDX(1)["433.21")!(DGDX(1)["433.31")!(DGDX(1)["433.81")!(DGDX(1)["433.91")!(DGDX(1)["434.01")!(DGDX(1)["434.11")!(DGDX(1)["434.91") S ICDRG=559
I $G(ICDDX(1))=12856!($G(ICDDX(1))=12858)!($G(ICDDX(1))=12860)!($G(ICDDX(1))=12862)!($G(ICDDX(1))=12864)!($G(ICDDX(1))=12866)!($G(ICDDX(1))=12868)!($G(ICDDX(1))=12870)!($G(ICDDX(1))=12872) S ICDRG=559
Q
DRG560 Q
DRG561 Q
DRG562 Q
DRG563 Q
DRG564 Q
DRG565 Q
DRG566 Q
DRG567 Q
DRG568 Q
DRG569 Q
DRG570 Q
DRG571 Q
DRG572 Q
DRG573 Q
DRG574 Q
DRG575 Q
DRG576 Q
DRG577 Q
DRG578 Q
DRG579 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[HICDTLB6C 9693 printed Nov 22, 2024@17:02:54 Page 2
ICDTLB6C ;ALB/EG/MRY/KUM - GROUPER UTILITY FUNCTIONS FY 2007;9/29/03 2:47pm
+1 ;;18.0;DRG Grouper;**24,30,64**;Oct 20, 2000;Build 103
+2 ;
DRG403 SET ICDRG=$SELECT(ICDPD["l":$SELECT(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$SELECT(ICDCC:401,1:402),ICDCC:403,1:404)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG404 SET ICDRG=$SELECT(ICDPD["l":$SELECT(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$SELECT(ICDCC:401,1:402),ICDCC:403,1:404)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG405 DO DRG404
QUIT
DRG406 ;
+1 IF ICDORNI["K"
Begin DoDot:1
+2 SET ICDRG=$SELECT((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDCC:406,1:407)
End DoDot:1
+3 IF ICDORNI'["K"
DO DRG408
+4 QUIT
DRG407 DO DRG406
QUIT
DRG408 IF $DATA(ICDDX(1))&(ICDOPCT=0)
Begin DoDot:1
+1 IF ICDDX(1)=$$CODEBA^ICDEX("V58.0",80)
SET ICDRG=409
QUIT
+2 IF ICDDX(1)=$$CODEBA^ICDEX("V67.1",80)
SET ICDRG=409
QUIT
+3 QUIT
End DoDot:1
if ICDRG=409
QUIT
+4 IF $DATA(ICDDX(1))&(ICDOPCT=0)
Begin DoDot:1
+5 IF ICDDX(1)=$$CODEBA^ICDEX("V58.11",80)
SET ICDRG=$SELECT(ICDSD["2":492,1:410)
QUIT
+6 IF ICDDX(1)=$$CODEBA^ICDEX("V58.12",80)
SET ICDRG=$SELECT(ICDSD["2":492,1:410)
QUIT
+7 IF ICDDX(1)=$$CODEBA^ICDEX("V67.2",80)
SET ICDRG=$SELECT(ICDSD["2":492,1:410)
QUIT
End DoDot:1
if "410^492"[ICDRG
QUIT
+8 IF ICDOPCT>0
SET ICDRG=$SELECT(ICDPD'["L":408,ICDCC:401,1:402)
QUIT
+9 IF ICDOPCT=0
DO DRG412
+10 QUIT
DRG411 SET ICDRG=$SELECT(ICDOR["O"!(ICDORNI["O"):408,ICDOR["N":412,1:411)
QUIT
DRG412 ;S ICDRG=$S(ICDOR["O"!(ICDORNI["O"):408,ICDOR["N"&($D(ICDPDRG(412))):412,$D(ICDPDRG(411)):411,ICDCC:413,1:414)
+1 IF ICDOPCT>0
DO DRG408
QUIT
+2 DO DRG412^ICDTLB61
+3 QUIT
DRG413 SET ICDRG=$SELECT(ICDCC:413,1:414)
QUIT
DRG414 SET ICDRG=$SELECT(ICDCC:413,1:414)
QUIT
DRG416 SET ICDRG=$SELECT(ICDOR["O":578,AGE="":470,AGE>17:576,1:417)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
IF ICDRG=576&($DATA(ICDOP(" 96.72")))
SET ICDRG=575
+1 QUIT
DRG417 SET ICDRG=$SELECT(ICDOR["O":578,AGE="":470,AGE>17:576,1:417)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG418 SET ICDRG=$SELECT(ICDOR["O":579,1:418)
QUIT
DRG419 SET ICDRG=$SELECT(ICDOR["O":578,AGE="":470,AGE<18:422,ICDCC:419,1:420)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG420 SET ICDRG=$SELECT(ICDOR["O":578,AGE="":470,AGE<18:422,ICDCC:419,1:420)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG421 SET ICDRG=$SELECT(ICDOR["O":578,AGE="":470,AGE>17:421,1:422)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG422 SET ICDRG=$SELECT(ICDOR["O":578,AGE="":470,AGE>17:421,1:422)
SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
QUIT
DRG423 SET ICDRG=$SELECT(ICDOR["O":578,1:423)
IF ICDRG=578&(ICDDX(1)=7615)
SET ICDRG=579
+1 QUIT
DRG424 SET ICDRG=$SELECT(ICDOR["O":424,1:425)
QUIT
DRG425 SET ICDRG=$SELECT(ICDOR["O":424,1:425)
QUIT
DRG426 SET ICDRG=$SELECT(ICDOR["O":424,1:426)
QUIT
DRG427 SET ICDRG=$SELECT(ICDOR["O":424,1:427)
QUIT
DRG428 SET ICDRG=$SELECT(ICDOR["O":424,1:428)
QUIT
DRG429 SET ICDRG=$SELECT(ICDOR["O":424,1:429)
QUIT
DRG430 SET ICDRG=$SELECT(ICDOR["O":424,1:430)
QUIT
DRG431 SET ICDRG=$SELECT(ICDOR["O":424,1:431)
QUIT
DRG432 SET ICDRG=$SELECT(ICDOR["O":424,1:432)
QUIT
DRG434 SET ICDRG=$SELECT(ICDPD["t"!(ICDSD["t"):$SELECT(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435)
QUIT
DRG435 SET ICDRG=$SELECT(ICDPD["t"!(ICDSD["t"):$SELECT(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435)
QUIT
DRG436 SET ICDRG=$SELECT(ICDPD["t"!(ICDSD["t"):$SELECT(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435)
QUIT
DRG437 SET ICDRG=$SELECT(ICDPD["t"!(ICDSD["t"):$SELECT(ICDOR["D":437,ICDOR["R":436,ICDCC:434,1:435),ICDCC:434,1:435)
QUIT
DRG439 SET ICDRG=$SELECT($DATA(ICDODRG(440)):440,1:439)
QUIT
DRG442 SET ICDRG=$SELECT(ICDCC:442,1:443)
QUIT
DRG443 DO EN1^ICDDRG5
SET ICDRG=$SELECT(ICDCC3:$SELECT(ICDCC:442,1:443),1:"")
QUIT
DRG444 SET ICDRG=$SELECT(AGE<18:446,ICDCC:444,1:445)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG445 SET ICDRG=$SELECT(AGE<18:446,ICDCC:444,1:445)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG446 SET ICDRG=$SELECT(AGE<18:446,ICDCC:444,1:445)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG447 SET ICDRG=$SELECT(AGE>17:447,1:448)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG448 SET ICDRG=$SELECT(AGE>17:447,1:448)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG449 SET ICDRG=$SELECT(AGE<18:451,ICDCC:449,1:450)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG450 SET ICDRG=$SELECT(AGE<18:451,ICDCC:449,1:450)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG451 SET ICDRG=$SELECT(AGE<18:451,ICDCC:449,1:450)
IF AGE=""
SET ICDRG=470
SET ICDRTC=3
+1 QUIT
DRG452 SET ICDRG=$SELECT(ICDCC:452,1:453)
QUIT
DRG453 SET ICDRG=$SELECT(ICDCC:452,1:453)
QUIT
DRG454 SET ICDRG=$SELECT(ICDCC:454,1:455)
QUIT
DRG455 SET ICDRG=$SELECT(ICDCC:454,1:455)
QUIT
DRG462 SET ICDRG=$SELECT(ICDOR["O":461,1:462)
QUIT
DRG463 SET ICDRG=$SELECT(ICDOR["O":461,ICDCC:463,1:464)
QUIT
DRG464 SET ICDRG=$SELECT(ICDOR["O":461,ICDCC:463,1:464)
QUIT
DRG465 SET ICDRG=$SELECT(ICDOR["O":461,ICDSD["m":465,1:466)
QUIT
DRG466 SET ICDRG=$SELECT(ICDOR["O":461,ICDSD["m":465,1:466)
QUIT
DRG467 SET ICDRG=$SELECT(ICDOR["O":461,1:467)
QUIT
DRG471 SET ICDRG=$SELECT($FIND($PIECE(ICDOR,"M",2,99),"M"):471,1:"")
QUIT
DRG475 SET ICDRG=$SELECT(ICDOR["V":475,1:$SELECT($DATA(ICDPDRG):$ORDER(ICDPDRG(0)),1:468))
IF ICDRG<468
DO DODRG^ICDDRG0
+1 QUIT
DRG478 SET ICDRG=$SELECT(ICDOR["O"&ICDCC:478,1:479)
+1 IF ICDRG=478
DO DRG553^ICDTLB6C
+2 QUIT
DRG479 GOTO DRG478
DRG493 ;I (ICDI-1)=1,'ICDCC S ICDCC=$S($D(^ICD9("ACC",ICDDX(1),ICDDX(1))):1,1:0)
+1 SET ICDRG=$SELECT(ICDCC:493,1:494)
QUIT
DRG494 ;I (ICD-1),'ICDCC S ICDCC=$S($D(^ICD9("ACC",ICDDX(1),ICDDX(1))):1,1:0)
+1 SET ICDRG=$SELECT(ICDCC:493,1:494)
QUIT
DRG495 QUIT
DRG496 SET ICDRG=$SELECT(ICDOR["F":496,ICDCC:497,1:498)
+1 IF ICDRG=497!(ICDRG=498)
IF ICDPD["6"
SET ICDRG=546
QUIT
+2 IF ICDRG=497!(ICDRG=498)
IF $DATA(ICDDXT("737.40"))!($DATA(ICDDXT("737.41")))!($DATA(ICDDXT("737.42")))!($DATA(ICDDXT("737.43")))
SET ICDRG=546
+3 QUIT
DRG497 ;S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
GOTO DRG496
DRG498 ;S ICDRG=$S(ICDOR["F":496,ICDCC:497,1:498) Q
GOTO DRG496
DRG499 SET ICDRG=$SELECT(ICDCC:499,1:500)
QUIT
DRG500 SET ICDRG=$SELECT(ICDCC:499,1:500)
QUIT
DRG501 Begin DoDot:1
+1 IF (ICDPD["k")
Begin DoDot:2
+2 IF ICDCC
SET ICDRG=501
+3 IF 'ICDCC
SET ICDRG=502
End DoDot:2
+4 IF '$TEST
SET ICDRG=503
End DoDot:1
+5 QUIT
DRG502 DO DRG501
QUIT
DRG503 DO DRG501
QUIT
DRG514 ; Replaced with DRG535
+1 NEW ICDE1,ICDE2
+2 SET ICDE1=$SELECT($DATA(ICDOP(" 37.95"))&($DATA(ICDOP(" 37.96"))):1,1:0)
+3 SET ICDE2=$SELECT($DATA(ICDOP(" 37.97"))&($DATA(ICDOP(" 37.98"))):1,1:0)
+4 SET ICDRG=470
+5 IF $DATA(ICDOP(" 37.94"))
IF ICDE1+ICDE2=0
SET ICDRG=515
+6 IF '$DATA(ICDOP(" 37.94"))
IF ICDE1!ICDE2
SET ICDRG=515
+7 ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
+8 IF ICDRG=515
IF ICDOR["HN"
SET ICDRG=514
+9 QUIT
DRG515 DO DRG535
QUIT
DRG516 ; DRG 516,517,526 and 527 replaced by DRG 555-558 respectively
+1 ; ICD*18*30 DRG551 is higher in surgical hierarchy
+2 IF ICDRG=551
QUIT
+3 SET ICDRG=518
+4 DO DRG555
+5 IF $DATA(ICDOP(" 36.06"))!$DATA(ICDOP(" 92.27"))
DO DRG556
+6 IF $DATA(ICDOP(" 36.07"))
DO DRG557
+7 QUIT
DRG517 DO DRG516
QUIT
DRG518 DO DRG516
QUIT
DRG519 SET ICDRG=$SELECT(ICDOR["F":496,ICDCC:519,1:520)
QUIT
DRG520 DO DRG519
QUIT
DRG521 SET ICDRG=$SELECT(ICDCC:521,ICDOR["D"!(ICDOR["R"):522,1:523)
QUIT
DRG522 DO DRG521
QUIT
DRG523 DO DRG521
QUIT
DRG526 DO DRG516
QUIT
DRG527 DO DRG516
QUIT
DRG531 SET ICDRG=$SELECT(ICDCC:531,1:532)
QUIT
DRG532 DO DRG531
QUIT
DRG533 SET ICDRG=$SELECT(ICDCC:533,1:534)
IF $DATA(ICDOP(" 00.61"))&($DATA(ICDOP(" 00.63")))
SET ICDRG=577
+1 QUIT
DRG534 DO DRG533
QUIT
DRG535 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=470
+7 IF $DATA(ICDOP(" 37.94"))!$DATA(ICDOP(" 00.51"))
IF ICDE1+ICDE2+ICDE3+ICDE4=0
SET ICDRG=515
+8 IF '$DATA(ICDOP(" 37.94"))&('$DATA(ICDOP(" 00.51")))
IF ICDE1!ICDE2!ICDE3!ICDE4
SET ICDRG=515
+9 ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
+10 IF ICDRG=515
IF ICDOR["HN"
IF '$DATA(ICDOP(" 37.26"))
SET ICDRG=$SELECT(ICDPD["A":535,1:536)
+11 IF ICDRG=470
DO DRG115^ICDTLB2C
+12 QUIT
DRG536 DO DRG535
QUIT
DRG537 SET ICDRG=$SELECT(ICDCC:537,1:538)
QUIT
DRG538 DO DRG537
QUIT
DRG539 IF ICDPD["L"&(ICDMAJ'[3)
DO DRG401^ICDTLB5C
if "401^402^403^404^405^470^473"[ICDRG
QUIT
+1 SET ICDRG=$SELECT((ICDPD["L")&(ICDCC):539,ICDPD["L":540,ICDCC:406,1:407)
QUIT
DRG540 DO DRG539
QUIT
DRG543 SET ICDRG=$SELECT((ICDPD["Q")&(ICDOR["Q"):543,ICDOR["Q"&$DATA(ICDOP(" 00.10")):543,$DATA(ICDOP(" 02.93"))&($DATA(ICDOP(" 86.95"))):543,1:ICDRG)
QUIT
DRG544 QUIT
DRG545 QUIT
DRG546 QUIT
DRG547 ; called from DRG106^ICDTLB2C
+1 DO MCV
+2 SET ICDRG=$SELECT(ICDMCV:547,ICDMCV1:547,1:548)
QUIT
DRG548 GOTO DRG547
DRG549 ; called from DRG106^ICDTLB2C
+1 DO MCV
+2 SET ICDRG=$SELECT(ICDMCV:549,ICDMCV1:549,1:550)
QUIT
DRG550 GOTO DRG549
DRG551 ; called from DRG115^ICDTLB2C
+1 DO MCV
+2 IF ICDMCV!(ICDMCV2)
SET ICDRG=551
+3 QUIT
DRG552 QUIT
DRG553 ; called from DRG478
+1 DO MCV
+2 SET ICDRG=$SELECT(ICDMCV:553,ICDMCV1:553,1:554)
QUIT
DRG554 GOTO DRG553
DRG555 ; called from DRG516
+1 DO MCV
+2 IF ICDMCV!(ICDMCV1)
SET ICDRG=555
+3 QUIT
DRG556 ; called from DRG516
+1 DO MCV
+2 IF 'ICDMCV&('ICDMCV1)
SET ICDRG=556
+3 QUIT
DRG557 ; called from DRG516
+1 DO MCV
+2 IF ICDMCV!ICDMCV1
SET ICDRG=557
+3 IF '$TEST
SET ICDRG=558
+4 QUIT
DRG558 GOTO DRG516
DRG559 ;I DGDX(1)["433.01"!(DGDX(1)["433.11")!(DGDX(1)["433.21")!(DGDX(1)["433.31")!(DGDX(1)["433.81")!(DGDX(1)["433.91")!(DGDX(1)["434.01")!(DGDX(1)["434.11")!(DGDX(1)["434.91") S ICDRG=559
+1 IF $GET(ICDDX(1))=12856!($GET(ICDDX(1))=12858)!($GET(ICDDX(1))=12860)!($GET(ICDDX(1))=12862)!($GET(ICDDX(1))=12864)!($GET(ICDDX(1))=12866)!($GET(ICDDX(1))=12868)!($GET(ICDDX(1))=12870)!($GET(ICDDX(1))=12872)
SET ICDRG=559
+2 QUIT
DRG560 QUIT
DRG561 QUIT
DRG562 QUIT
DRG563 QUIT
DRG564 QUIT
DRG565 QUIT
DRG566 QUIT
DRG567 QUIT
DRG568 QUIT
DRG569 QUIT
DRG570 QUIT
DRG571 QUIT
DRG572 QUIT
DRG573 QUIT
DRG574 QUIT
DRG575 QUIT
DRG576 QUIT
DRG577 QUIT
DRG578 QUIT
DRG579 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
