ICDDRG2.m

ICDDRG2 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:39am

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

 Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D

 .I ICDDATE<3061001 D F Q

 .E  I ICDDATE<3071001 D FY2007 Q

 .E  D FY2008

END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q

F I ICDJ=37 S ICDJ(1)=ICDJ Q

 I ICDJ=40 S ICDJ(2)=ICDJ Q

 I ICDJ=36 S ICDJ(3)=ICDJ Q

 I ICDJ=42 S ICDJ(4)=ICDJ Q

 I ICDJ=39 S ICDJ(5)=ICDJ Q

 I ICDJ=38 S ICDJ(6)=ICDJ Q

 Q

FY2007 ;

 I ICDJ=37 S ICDJ(1)=ICDJ Q

 I ICDJ=40 S ICDJ(2)=ICDJ Q

 I ICDJ=42 S ICDJ(3)=ICDJ Q

 I ICDJ=36 S ICDJ(4)=ICDJ Q

 I ICDJ=39 S ICDJ(5)=ICDJ Q

 I ICDJ=38 S ICDJ(6)=ICDJ Q

 Q

FY2008 ;

 I ICDJ=114 S ICDJ(1)=ICDJ Q

 I ICDJ=115 S ICDJ(2)=ICDJ Q

 I ICDJ=117 S ICDJ(3)=ICDJ Q

 Q

VER S ICDF="",ICDL39=0 F ICDFZ=1:1 S ICDF=$O(ICDOP(ICDF)) Q:ICDF=""  S ICD=$P(ICDF," ",2) I "12.91^12.92^14.71^14.72^14.73^14.74^14.75^14.79"'[ICD S ICDL39=1 Q

 S ICDRG=$S(ICDL39:39,1:42)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ICDDRG2   1028     printed  Apr 09, 2024@20:55:06                                                                                                                                                                                                     Page 2

ICDDRG2   ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:39am

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

 +2        if $ORDER(ICDODRG(0))'>0

               QUIT 

           KILL ICDJ

           FOR ICDJ=0:0

               SET ICDJ=$ORDER(ICDODRG(ICDJ))

               if ICDJ'>0

                   QUIT 

               Begin DoDot:1

 +3                IF ICDDATE<3061001

                       DO F

                       QUIT 

 +4               IF '$TEST

                       IF ICDDATE<3071001

                           DO FY2007

                           QUIT 

 +5               IF '$TEST

                       DO FY2008

               End DoDot:1

END        SET ICDJ=$ORDER(ICDJ(0))

           if ICDJ'>0

               QUIT 

           SET ICDJ=ICDJ(ICDJ)

           KILL ICDODRG

           SET ICDODRG(ICDJ)=""

           KILL ICDJ

           QUIT 

F          IF ICDJ=37

               SET ICDJ(1)=ICDJ

               QUIT 

 +1        IF ICDJ=40

               SET ICDJ(2)=ICDJ

               QUIT 

 +2        IF ICDJ=36

               SET ICDJ(3)=ICDJ

               QUIT 

 +3        IF ICDJ=42

               SET ICDJ(4)=ICDJ

               QUIT 

 +4        IF ICDJ=39

               SET ICDJ(5)=ICDJ

               QUIT 

 +5        IF ICDJ=38

               SET ICDJ(6)=ICDJ

               QUIT 

 +6        QUIT 

FY2007    ;

 +1        IF ICDJ=37

               SET ICDJ(1)=ICDJ

               QUIT 

 +2        IF ICDJ=40

               SET ICDJ(2)=ICDJ

               QUIT 

 +3        IF ICDJ=42

               SET ICDJ(3)=ICDJ

               QUIT 

 +4        IF ICDJ=36

               SET ICDJ(4)=ICDJ

               QUIT 

 +5        IF ICDJ=39

               SET ICDJ(5)=ICDJ

               QUIT 

 +6        IF ICDJ=38

               SET ICDJ(6)=ICDJ

               QUIT 

 +7        QUIT 

FY2008    ;

 +1        IF ICDJ=114

               SET ICDJ(1)=ICDJ

               QUIT 

 +2        IF ICDJ=115

               SET ICDJ(2)=ICDJ

               QUIT 

 +3        IF ICDJ=117

               SET ICDJ(3)=ICDJ

               QUIT 

 +4        QUIT 

VER        SET ICDF=""

           SET ICDL39=0

           FOR ICDFZ=1:1

               SET ICDF=$ORDER(ICDOP(ICDF))

               if ICDF=""

                   QUIT 

               SET ICD=$PIECE(ICDF," ",2)

               IF "12.91^12.92^14.71^14.72^14.73^14.74^14.75^14.79"'[ICD

                   SET ICDL39=1

                   QUIT 

 +1        SET ICDRG=$SELECT(ICDL39:39,1:42)

 +2        QUIT