Routine: ICDJC

ICDJC ;ALB/ARH - DRG GROUPER CALCULATOR 2015 ;05/26/2016

 ;;18.0;DRG Grouper;**89,97**;Oct 20, 2000;Build 5

 ; DRG Calcuation for re-designed grouper ICD-10 2015

 ; called from ICDDRG when effective date of care results in a ICD-10 DRG

 ; Input:  ICDDX(x)=DX (80), ICDPRC(x)=PR (80.1), ICDPOA(x)= Y,N,W,U or null (assumed Yes if not defined)

 S ICDEXP=+$G(ICDEXP) ; 1 if patient expired/not discharged alive

 S ICDTRS=+$G(ICDTRS) ; 1 if patient transfer to acute care facility

 S ICDDMS=+$G(ICDDMS) ; 1 if patient has irregular discharge/discharged AMA

 S SEX=$G(SEX) ; patient gender (M-Male, F-Female)

 S ICDDATE=$G(ICDDATE)\1 I ICDDATE'?7N S ICDDATE=DT  ; date to calculate DRG for or event date

 ; Output:  ICDJDRG - returned with pointer to calculated DRG (80.2)

DRG N IX,PRATT,DXATT,CDSET,DRG,DRGLST,DRGIFN,DRG0,DRGHRCY,DATE,ORDIFN,HRCY,CCMCC,ARRHRCY S ICDJDRG=""

 S IX=0 F  S IX=$O(ICDDX(IX)) Q:'IX  I 'ICDDX(IX) K ICDDX(IX) ; clean-up input arrays

 S IX=0 F  S IX=$O(ICDPRC(IX)) Q:'IX  I 'ICDPRC(IX) K ICDPRC(IX) ; remove any nodes with no code ien

 S IX=+$O(ICDDX(0)) I '$O(^ICDD(83.5,"B",+$G(ICDDX(IX)),0)) S ICDJDRG=999 G EXIT ; primary dx must be defined in DRG

 D PRATT^ICDJC1(.ICDPRC,ICDDATE,.PRATT) ; get procedure attributes - OR/Non-OR and MDC

 D PRCLS^ICDJC1(.ICDPRC,ICDDATE,.PRATT) ; identify procedure clusters and update OR/Non-OR

 D DXATT^ICDJC1(.ICDDX,ICDDATE,ICDEXP,.DXATT) ; get diagnosis attributes - MCC/CC and MDC

 D DXHAC^ICDJC1(.ICDDX,.ICDPRC,ICDDATE,.ICDPOA,.DXATT) ; identify HAC diagnosis and update MCC/CC

 D CDSET^ICDJC2(.ICDDX,.ICDPRC,ICDDATE,.PRATT,.CDSET) ; get all Code Sets that apply based on diagnosis and procedures

 D DRGLS^ICDJC3(ICDDATE,.PRATT,.DXATT,.CDSET,.DRGLST) ; get all DRGs that apply based on Code Sets and DRG Case

 ; order selected DRGs by hierarchy

 S DRGIFN=0 F  S DRGIFN=$O(DRGLST(DRGIFN)) Q:'DRGIFN  D

. ;

 . S DATE=ICDDATE+.0001 S DATE=$O(^ICDD(83.11,"B",DATE),-1) S ORDIFN=$O(^ICDD(83.11,"B",+DATE,0)) Q:'ORDIFN

 . S DRGHRCY=$O(^ICDD(83.11,ORDIFN,10,"B",+DRGIFN,0)) Q:'DRGHRCY

. ;

 . S HRCY=10000+DRGHRCY S ARRHRCY(HRCY)=DRGIFN

 ; loop through all selected DRGs in hierachical order and apply drg attibutes - select first that matchs all

 S HRCY=0 F  S HRCY=$O(ARRHRCY(HRCY)) Q:'HRCY  D  I +ICDJDRG Q

 . S DRGIFN=ARRHRCY(HRCY)

 . S DRG0=$G(^ICDD(83.1,DRGIFN,0)) S CCMCC=DRGLST(DRGIFN)

. ;

 . I $P(DRG0,U,9)=1,'ICDDMS Q  ; drg requires patient left AMA

 . I $P(DRG0,U,9)=2,+ICDEXP Q  ; drg requires patient discharged alive

 . I $P(DRG0,U,9)=3,'ICDEXP Q  ; drg requires patient expired

 . I $P(DRG0,U,9)=4,'ICDTRS Q  ; drg requires patient transfered to acute care facility

 . I $P(DRG0,U,9)=5,'ICDTRS,'ICDEXP Q  ; drg requires either patient expired or transferred to acute care facility

. ;

 . I $P(DRG0,U,6)'="",$P(DRG0,U,6)'=SEX Q  ; drg specific to sex, requires patient either male or female

. ;

 . I $P(DRG0,U,7,8)[1 I $S(+$P(DRG0,U,7)&(CCMCC="MCC"):0,+$P(DRG0,U,8)&(CCMCC="CC"):0,1:1) Q  ; drg requires MCC/CC

. ;

 . S ICDJDRG=+$P(DRG0,U,1) ; DRG Selected <<<

EXIT I 'ICDJDRG S ICDJDRG=999

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDJC   3188     printed  Mar 13, 2025@20:55:34                                                                                                                                                                                                       Page 2

ICDJC     ;ALB/ARH - DRG GROUPER CALCULATOR 2015 ;05/26/2016

 +1       ;;18.0;DRG Grouper;**89,97**;Oct 20, 2000;Build 5

 +2       ;

 +3       ; DRG Calcuation for re-designed grouper ICD-10 2015

 +4       ; called from ICDDRG when effective date of care results in a ICD-10 DRG

 +5       ;

 +6       ;

 +7       ; Input:  ICDDX(x)=DX (80), ICDPRC(x)=PR (80.1), ICDPOA(x)= Y,N,W,U or null (assumed Yes if not defined)

 +8       ;

 +9       ; 1 if patient expired/not discharged alive

           SET ICDEXP=+$GET(ICDEXP)

 +10      ; 1 if patient transfer to acute care facility

           SET ICDTRS=+$GET(ICDTRS)

 +11      ; 1 if patient has irregular discharge/discharged AMA

           SET ICDDMS=+$GET(ICDDMS)

 +12      ; patient gender (M-Male, F-Female)

           SET SEX=$GET(SEX)

 +13      ; date to calculate DRG for or event date

           SET ICDDATE=$GET(ICDDATE)\1

           IF ICDDATE'?7N

               SET ICDDATE=DT

 +14      ;

 +15      ; Output:  ICDJDRG - returned with pointer to calculated DRG (80.2)

 +16      ;

 +17      ;

DRG        NEW IX,PRATT,DXATT,CDSET,DRG,DRGLST,DRGIFN,DRG0,DRGHRCY,DATE,ORDIFN,HRCY,CCMCC,ARRHRCY

           SET ICDJDRG=""

 +1       ; clean-up input arrays

           SET IX=0

FOR

               SET IX=$ORDER(ICDDX(IX))

               if 'IX

                   QUIT

               IF 'ICDDX(IX)

                   KILL ICDDX(IX)

 +2       ; remove any nodes with no code ien

           SET IX=0

FOR

               SET IX=$ORDER(ICDPRC(IX))

               if 'IX

                   QUIT

               IF 'ICDPRC(IX)

                   KILL ICDPRC(IX)

 +3       ;

 +4       ; primary dx must be defined in DRG

           SET IX=+$ORDER(ICDDX(0))

           IF '$ORDER(^ICDD(83.5,"B",+$GET(ICDDX(IX)),0))

               SET ICDJDRG=999

               GOTO EXIT

 +5       ;

 +6       ;

 +7       ; get procedure attributes - OR/Non-OR and MDC

           DO PRATT^ICDJC1(.ICDPRC,ICDDATE,.PRATT)

 +8       ; identify procedure clusters and update OR/Non-OR

           DO PRCLS^ICDJC1(.ICDPRC,ICDDATE,.PRATT)

 +9       ;

 +10      ; get diagnosis attributes - MCC/CC and MDC

           DO DXATT^ICDJC1(.ICDDX,ICDDATE,ICDEXP,.DXATT)

 +11      ; identify HAC diagnosis and update MCC/CC

           DO DXHAC^ICDJC1(.ICDDX,.ICDPRC,ICDDATE,.ICDPOA,.DXATT)

 +12      ;

 +13      ; get all Code Sets that apply based on diagnosis and procedures

           DO CDSET^ICDJC2(.ICDDX,.ICDPRC,ICDDATE,.PRATT,.CDSET)

 +14      ;

 +15      ; get all DRGs that apply based on Code Sets and DRG Case

           DO DRGLS^ICDJC3(ICDDATE,.PRATT,.DXATT,.CDSET,.DRGLST)

 +16      ;

 +17      ;

 +18      ; order selected DRGs by hierarchy

 +19       SET DRGIFN=0

FOR

               SET DRGIFN=$ORDER(DRGLST(DRGIFN))

               if 'DRGIFN

                   QUIT

               Begin DoDot:1

 +20      ;

 +21               SET DATE=ICDDATE+.0001

                   SET DATE=$ORDER(^ICDD(83.11,"B",DATE),-1)

                   SET ORDIFN=$ORDER(^ICDD(83.11,"B",+DATE,0))

                   if 'ORDIFN

                       QUIT

 +22               SET DRGHRCY=$ORDER(^ICDD(83.11,ORDIFN,10,"B",+DRGIFN,0))

                   if 'DRGHRCY

                       QUIT

 +23      ;

 +24               SET HRCY=10000+DRGHRCY

                   SET ARRHRCY(HRCY)=DRGIFN

               End DoDot:1

 +25      ;

 +26      ;

 +27      ; loop through all selected DRGs in hierachical order and apply drg attibutes - select first that matchs all

 +28       SET HRCY=0

FOR

               SET HRCY=$ORDER(ARRHRCY(HRCY))

               if 'HRCY

                   QUIT

               Begin DoDot:1

 +29               SET DRGIFN=ARRHRCY(HRCY)

 +30               SET DRG0=$GET(^ICDD(83.1,DRGIFN,0))

                   SET CCMCC=DRGLST(DRGIFN)

 +31      ;

 +32      ; drg requires patient left AMA

                   IF $PIECE(DRG0,U,9)=1

                       IF 'ICDDMS

                           QUIT

 +33      ; drg requires patient discharged alive

                   IF $PIECE(DRG0,U,9)=2

                       IF +ICDEXP

                           QUIT

 +34      ; drg requires patient expired

                   IF $PIECE(DRG0,U,9)=3

                       IF 'ICDEXP

                           QUIT

 +35      ; drg requires patient transfered to acute care facility

                   IF $PIECE(DRG0,U,9)=4

                       IF 'ICDTRS

                           QUIT

 +36      ; drg requires either patient expired or transferred to acute care facility

                   IF $PIECE(DRG0,U,9)=5

                       IF 'ICDTRS

                           IF 'ICDEXP

                               QUIT

 +37      ;

 +38      ; drg specific to sex, requires patient either male or female

                   IF $PIECE(DRG0,U,6)'=""

                       IF $PIECE(DRG0,U,6)'=SEX

                           QUIT

 +39      ;

 +40      ; drg requires MCC/CC

                   IF $PIECE(DRG0,U,7,8)[1

                       IF $SELECT(+$PIECE(DRG0,U,7)&(CCMCC="MCC"):0,+$PIECE(DRG0,U,8)&(CCMCC="CC"):0,1:1)

                           QUIT

 +41      ;

 +42      ; DRG Selected <<<

                   SET ICDJDRG=+$PIECE(DRG0,U,1)

               End DoDot:1

               IF +ICDJDRG

                   QUIT

 +43      ;

EXIT       IF 'ICDJDRG

               SET ICDJDRG=999

 +1        QUIT

ICDJC.m