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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDJC 3188 printed Sep 23, 2025@19:26:58 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
