- ICDTLB6B ;ALB/EG/MRY/KUM - GROUPER UTILITY FUNCTIONS FY 2006;9/29/03 2:47pm
- ;;18.0;DRG Grouper;**20,22,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":415,AGE="":470,AGE>17:416,1:417),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
- DRG417 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE>17:416,1:417),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
- DRG418 S ICDRG=$S(ICDOR["O":415,1:418) Q
- DRG419 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE<18:422,ICDCC:419,1:420),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
- DRG420 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE<18:422,ICDCC:419,1:420),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
- DRG421 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE>17:421,1:422),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
- DRG422 S ICDRG=$S(ICDOR["O":415,AGE="":470,AGE>17:421,1:422),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
- DRG423 S ICDRG=$S(ICDOR["O":415,1:423) 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^ICDTLB6B
- 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
- 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) Q
- DRG534 D DRG533 Q
- DRG535 N ICDE1,ICDE2,ICDE3
- 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 ICDRG=470
- I $D(ICDOP(" 37.94"))!$D(ICDOP(" 00.51")) I ICDE1+ICDE2+ICDE3=0 S ICDRG=515
- I '$D(ICDOP(" 37.94"))&('$D(ICDOP(" 00.51"))) I ICDE1!ICDE2!ICDE3 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^ICDTLB2B
- 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^ICDTLB5B 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,1:ICDRG) Q
- DRG544 Q
- DRG545 Q
- DRG546 Q
- DRG547 ; called from DRG106^ICDTLB2B
- D MCV
- S ICDRG=$S(ICDMCV:547,ICDMCV1:547,1:548) Q
- DRG548 G DRG547
- DRG549 ; called from DRG106^ICDTLB2B
- D MCV
- S ICDRG=$S(ICDMCV:549,ICDMCV1:549,1:550) Q
- DRG550 G DRG549
- DRG551 ; called from DRG115^ICDTLB2B
- 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
- 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[HICDTLB6B 9104 printed Jan 18, 2025@02:53:56 Page 2
- ICDTLB6B ;ALB/EG/MRY/KUM - GROUPER UTILITY FUNCTIONS FY 2006;9/29/03 2:47pm
- +1 ;;18.0;DRG Grouper;**20,22,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":415,AGE="":470,AGE>17:416,1:417)
- SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
- QUIT
- DRG417 SET ICDRG=$SELECT(ICDOR["O":415,AGE="":470,AGE>17:416,1:417)
- SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
- QUIT
- DRG418 SET ICDRG=$SELECT(ICDOR["O":415,1:418)
- QUIT
- DRG419 SET ICDRG=$SELECT(ICDOR["O":415,AGE="":470,AGE<18:422,ICDCC:419,1:420)
- SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
- QUIT
- DRG420 SET ICDRG=$SELECT(ICDOR["O":415,AGE="":470,AGE<18:422,ICDCC:419,1:420)
- SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
- QUIT
- DRG421 SET ICDRG=$SELECT(ICDOR["O":415,AGE="":470,AGE>17:421,1:422)
- SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
- QUIT
- DRG422 SET ICDRG=$SELECT(ICDOR["O":415,AGE="":470,AGE>17:421,1:422)
- SET ICDRTC=$SELECT(ICDRG=470:3,1:ICDRTC)
- QUIT
- DRG423 SET ICDRG=$SELECT(ICDOR["O":415,1:423)
- 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^ICDTLB6B
- +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 SET ICDRG=518
- +2 DO DRG555
- +3 IF $DATA(ICDOP(" 36.06"))!$DATA(ICDOP(" 92.27"))
- DO DRG556
- +4 IF $DATA(ICDOP(" 36.07"))
- DO DRG557
- +5 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)
- QUIT
- DRG534 DO DRG533
- QUIT
- DRG535 NEW ICDE1,ICDE2,ICDE3
- +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 ICDRG=470
- +6 IF $DATA(ICDOP(" 37.94"))!$DATA(ICDOP(" 00.51"))
- IF ICDE1+ICDE2+ICDE3=0
- SET ICDRG=515
- +7 IF '$DATA(ICDOP(" 37.94"))&('$DATA(ICDOP(" 00.51")))
- IF ICDE1!ICDE2!ICDE3
- SET ICDRG=515
- +8 ; "HN" in ICDOR represents OR proc 37.21-.23, 37.26, 88.52-.58
- +9 IF ICDRG=515
- IF ICDOR["HN"
- IF '$DATA(ICDOP(" 37.26"))
- SET ICDRG=$SELECT(ICDPD["A":535,1:536)
- +10 IF ICDRG=470
- DO DRG115^ICDTLB2B
- +11 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^ICDTLB5B
- 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,1:ICDRG)
- QUIT
- DRG544 QUIT
- DRG545 QUIT
- DRG546 QUIT
- DRG547 ; called from DRG106^ICDTLB2B
- +1 DO MCV
- +2 SET ICDRG=$SELECT(ICDMCV:547,ICDMCV1:547,1:548)
- QUIT
- DRG548 GOTO DRG547
- DRG549 ; called from DRG106^ICDTLB2B
- +1 DO MCV
- +2 SET ICDRG=$SELECT(ICDMCV:549,ICDMCV1:549,1:550)
- QUIT
- DRG550 GOTO DRG549
- DRG551 ; called from DRG115^ICDTLB2B
- +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
- 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