Routine: ICDDRG14

ICDDRG14 ;ALB/GRR - FIX SURGERY HIERARCHY ; 9/29/04 3:48pm

 ;;18.0;DRG Grouper;**14,31**;Oct 20, 2000;Build 7

 G POST:ICDPD'["D" I ICDOR["c" D  Q

 . I ICDDATE>3070930.9 S ICDRG=766

 . E  S ICDRG=$S(ICDCC:370,1:371)

NOV I ICDOR["s"!(ICDOR["g") D  Q

 . I ICDDATE>3070930.9 S ICDRG=$S(ICDOR["s":767,1:768)

 . E  S ICDRG=$S(ICDOR["s":374,1:375)

 I ICDDATE>3070930.9 S ICDRG=$S(ICDSD["n"!(ICDPD["n"):774,1:775) Q

 E  S ICDRG=$S(ICDSD["n"!(ICDPD["n"):372,1:373) Q

POST N DRGFY,ICDREF

 S (DRGFY,ICDREF)=""

 I ICDPD["d" S ICDRG=$S(ICDOR["O":377,1:376) Q

 S ICDRG=$O(ICDRG(0)) I ICDRG'>0 S ICDRG=469 Q

 S DRGFY=$O(^ICD(ICDRG,2,"B",+ICDDATE),-1)

 S ICDREF=$O(^ICD(ICDRG,2,"B",$S($G(DRGFY):DRGFY,1:3041001),ICDREF))

 S ICDREF=$P($G(^ICD(ICDRG,2,+ICDREF,0)),U,3)

 I ICDREF'="" S ICDREF="DRG"_ICDRG_"^"_ICDREF D @ICDREF K ICDREF

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDDRG14   850     printed  Feb 18, 2025@23:16:35                                                                                                                                                                                                     Page 2

ICDDRG14  ;ALB/GRR - FIX SURGERY HIERARCHY ; 9/29/04 3:48pm

 +1       ;;18.0;DRG Grouper;**14,31**;Oct 20, 2000;Build 7

 +2       ;

 +3        if ICDPD'["D"

               GOTO POST

           IF ICDOR["c"

               Begin DoDot:1

 +4                IF ICDDATE>3070930.9

                       SET ICDRG=766

 +5               IF '$TEST

                       SET ICDRG=$SELECT(ICDCC:370,1:371)

               End DoDot:1

               QUIT

NOV        IF ICDOR["s"!(ICDOR["g")

               Begin DoDot:1

 +1                IF ICDDATE>3070930.9

                       SET ICDRG=$SELECT(ICDOR["s":767,1:768)

 +2               IF '$TEST

                       SET ICDRG=$SELECT(ICDOR["s":374,1:375)

               End DoDot:1

               QUIT

 +3       ;

 +4        IF ICDDATE>3070930.9

               SET ICDRG=$SELECT(ICDSD["n"!(ICDPD["n"):774,1:775)

               QUIT

 +5       IF '$TEST

               SET ICDRG=$SELECT(ICDSD["n"!(ICDPD["n"):372,1:373)

               QUIT

 +6       ;

POST       NEW DRGFY,ICDREF

 +1        SET (DRGFY,ICDREF)=""

 +2        IF ICDPD["d"

               SET ICDRG=$SELECT(ICDOR["O":377,1:376)

               QUIT

 +3        SET ICDRG=$ORDER(ICDRG(0))

           IF ICDRG'>0

               SET ICDRG=469

               QUIT

 +4        SET DRGFY=$ORDER(^ICD(ICDRG,2,"B",+ICDDATE),-1)

 +5        SET ICDREF=$ORDER(^ICD(ICDRG,2,"B",$SELECT($GET(DRGFY):DRGFY,1:3041001),ICDREF))

 +6        SET ICDREF=$PIECE($GET(^ICD(ICDRG,2,+ICDREF,0)),U,3)

 +7        IF ICDREF'=""

               SET ICDREF="DRG"_ICDRG_"^"_ICDREF

               DO @ICDREF

               KILL ICDREF

 +8        QUIT

ICDDRG14.m