ICDDG010 ;KUM - DRG GROUPER PROCESSING BEGINS ;05/02/12 4:06pm
;;18.0;DRG Grouper;**64,82**;Oct 20, 2000;Build 21
;
;GROUPING PROCESS BEGINS
;
GROUP ;
N ICDFOUND,ICDRGH,ICDNODOD,ICDPREQ
S (ICDFOUND,ICDNODOD)=0
D PRECOND I ICDRTC=4,ICDRG=999 G GLAST ; Handle PRE-CONDITIONS
I 'ICDFOUND D VARIABLS^ICDDRGX2
I 'ICDFOUND D MDCSPROC ; PROCESSING FOR MDC5, MDC19, MDC23, MDC14, MDC20, MDC22, MDC15
;MDCSPROC may have found a DRG group but still needs to Do DODRG to apply CC/MCC rules, so ICDFOUND=1 and ICDNODOD=0
D NEONATE ; Handle Neonatal Processing
;NEONATE may have found an actual DRG and does not need to Do DODRG to apply CC/MCC rules, so ICDFOUND=1 and ICDNODOD=1
I 'ICDFOUND D SURGICAL ; Apply Surgical Hierarchy
I 'ICDFOUND D DEFAULT ; Default Processing
; MDC24 PROCESSING
; MDC25 PROCESSING
; PREMDC PROCESSING
; MDC4 PROCESSING
D END
GLAST ;
S ICDDRG=ICDRG
D KILL^ICDDRG
S:+$G(ICDRG)'>0 ICDRG=999
Q
;
PRECOND ; PRE - CONDITIONS
I $D(ICDSEX(1))&($D(ICDSEX(2))) S ICDRTC=4,ICDRG=999
Q
;
MDCSPROC ; Processing for MDCs 5, 19, 23, 14, 20, 22 and 15
N ICDMDCL
S ICDMDCL="/14/15/17/18/19/20/23/"[("/"_ICDMDC_"/")
I 'ICDMDCL D:ICDOPCT<2 I "^983^986^989^"[(U_ICDRG_U) S ICDFOUND=1 Q
. I $D(ICDF) Q
. I $D(ICD10PD("M")),'$D(ICD10OR("y")) S ICDOPCT=0 Q
. I $D(ICD10OR("O")),ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(769)),'$D(ICD10ORNI("p")) S ICDRG=$S($D(ICD10ORNI("O")):983,$D(ICD10ORNI("y")):986,$D(ICD10ORNI("z")):989,1:983),ICDFOUND=1 Q
. I ICDOPNR S ICDRG=$S($D(ICD10ORNI("y")):986,1:983),ICDOPNR=0,ICDFOUND=1 Q
;
;if number of non-extensive ORs eqs # OR, 477
;
I 'ICDMDCL,'$D(ICD10ORNI("y"))&($D(ICD10ORNI))&($D(ICD10ORNI("z"))) D I ICDRG=989 S ICDFOUND=1 Q
. I $D(ICDF) Q
. NEW K S K=$$ORNI(ICDORNI) I K=ICDOPCT S ICDRG=989,ICDFOUND=1 Q
;
;if number of non-extensive ORs+prostatics eqs # OR, 476
;
I 'ICDMDCL,$D(ICD10ORNI("y"))&($D(ICDORNI)) D I ICDRG=986 S ICDFOUND=1 Q
. N K S K=$$ORNI(ICDORNI) I K=ICDOPCT&(ICDNOR=ICDONR) S ICDRG=986 S ICDFOUND=1 Q
I 'ICDMDCL,ICDNOR=ICDONR&(ICDOPCT>0) S ICDRG=983,ICDFOUND=1 Q
I ICDMDC=5,'$D(ICD10OR("O")) S ICDRTC=$S(ICDEXP="":5,1:"") S:ICDRTC'="" ICDRG=999 D:ICDRTC="" MI Q
I ICDMDC=19,ICDOCNT>0,$D(ICD10OR("O")) S (ICDRG,ICDRGH)=876,ICDFOUND=1 Q
I ICDMDC=23,$D(ICD10OR("O"))!($D(ICD10ORNI("O"))) S ICDRG=941,ICDFOUND=1 Q
;I ICDMDC=14 D ^ICDDRG14 I ICDRG]"" S ICDFOUND=1 Q
I ICDMDC=20 S ICDRTC=$S(ICDDMS="":7,1:"") I ICDDMS'=0 S ICDRG=$S(ICDDMS="":999,1:894),ICDFOUND=1 Q
I ICDMDC=22 S ICDRTC=$S(ICDTRS="":6,1:"") S:ICDRTC'="" ICDRG=999,ICDFOUND=1 D:ICDRTC="" CKBURN
;I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I ICDTRS'=0 S ICDRG=$S(ICDRTC'="":999,1:789),ICDFOUND=1 Q
;
Q
NEONATE ; Neonatal Processing
N ICDOLD
S ICDOLD=29,X1=$S($G(DGADM):$G(DGADM),1:DT),X2=$G(DOB) I X1,X2 D ^%DTC S ICDOLD=X
I ICDOLD<29 S ICDMDC=15
E Q
I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I +ICDTRS'=0 D S (ICDFOUND,ICDNODOD)=1 Q
. S ICDRG=$S(ICDRTC'="":999,1:789) ;Transferred to another acute care facility
I ICDMDC'=15 Q
I ICDEXP S ICDRG=789,(ICDFOUND,ICDNODOD)=1 Q
;If no Procedure Codes entered or no DRGs found for Procedure Codes that were entered:
I 'ICDNOR!('$D(ICDODRG)) S ICDRG=$O(ICDPDRG(0)) X "I ICDMDC=15,$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG D NEONATF^ICDDRG0" D Q
. N X,X1,X2,%
. I ICDOLD<29 D NBCOMP Q
. I ICDRG<789!(ICDRG>795) Q
. I $O(ICDRG(795)) S ICDRG=$O(ICDRG(795)),(ICDFOUND,ICDNODOD)=1 Q
. I 'ICDRG S ICDRG=999,ICDRTC=8
I AGE="",ICDMDC=3 S ICDRTC=3 S ICDRG=999,(ICDFOUND,ICDNODOD)=1 Q
S ICDDRG=ICDRG,(ICDFOUND,ICDNODOD)=1
Q
;
NEONATF ;NEONATE - Continuation of xecute line
S ICDRG=$S($D(ICDPDRG(795)):795,$D(ICDPDRG(791)):791,1:$O(ICDSDRG(0)))
Q
;
NBCOMP ; check for complication related to Newborn
N ICDSDXCK,ICDN,ICDX,ICDPREM,ICDMJR,ICDIMM,ICDSIG
;Check for Premature and Major Problem in PDX or SDX
;ICDPREM 1=PREMATURE (ID="p") ICDIMM 1=EXTREME IMMATURE (ID="E") ICDMJR 1=MAJORPROBLEMS (ID="J")
S (ICDN,ICDPREM,ICDIMM,ICDMJR,ICDSIG)=0 F S ICDN=$O(ICDDX(ICDN)) Q:'ICDN D
.S:$D(ICD10PD("p"))!($D(ICD10SD("p"))) ICDPREM=1 S:$D(ICD10PD("J"))!($D(ICD10SD("J"))) ICDMJR=1
.S:$D(ICD10PD("E"))!($D(ICD10SD("E"))) ICDIMM=1 S:$D(ICD10PD("S"))!($D(ICD10SD("S"))) ICDSIG=1
I ICDSIG S ICDRG=794,(ICDFOUND,ICDNODOD)=1 Q
I ICDIMM S ICDRG=790,(ICDFOUND,ICDNODOD)=1 Q
I ICDPREM=1 S:ICDMJR ICDRG=791,(ICDFOUND,ICDNODOD)=1 S:'ICDMJR ICDRG=792,(ICDFOUND,ICDNODOD)=1 Q
I 'ICDPREM S:ICDMJR ICDRG=793,(ICDFOUND,ICDNODOD)=1 S:'ICDMJR ICDRG=795,(ICDFOUND,ICDNODOD)=1 Q
Q
;
SURGICAL ; Apply Surgical Hierarchy
N ICDJ,ICDSTOP,ICDDGIEN,ICDDRGT,ICDMIEN
S ICDDRG=0,ICDSTOP=0,ICDDA=$O(^ICDRS("B",ICDDATE_".1"),-1) I 'ICDDA Q
S ICDIEN=$O(^ICDRS("B",ICDDA,"")) I 'ICDIEN Q
S ICDMIEN=$O(^ICDRS(ICDIEN,1,"B",ICDMDC,"")) I 'ICDMIEN Q
F ICDJ=0:0 S ICDJ=$O(^ICDRS(ICDIEN,1,ICDMIEN,2,"C",ICDJ)) Q:ICDJ'>0!(ICDSTOP) S ICDDGIEN=$O(^ICDRS(ICDIEN,1,ICDMIEN,2,"C",ICDJ,"")) I ICDDGIEN D
. S ICDDRGT=$P(^ICDRS(ICDIEN,1,ICDMIEN,2,ICDDGIEN,0),U,1) I $D(ICDODRG(ICDDRGT)) D
. . S ICDCCT=$$ICDRGCC(ICDDRGT,ICDDATE) I ICDCCT=ICDCC S ICDRG=ICDDRGT,ICDSTOP=1 Q
Q
;
ICDRGCC(DRG,CDT) ;Get CC/MCC flag from DRG
;
; Input:
; DRG DRG Number
; CDT Effective Date
;
; Output: CC/MCC Flag 0-3
;
N ICDCC,ICDIEN,ICDDA,ICDAIEN
S ICDCC=0,ICDIEN=$O(^ICD("B","DRG"_DRG,"")) I ICDIEN D
. S ICDDA=$O(^ICD(ICDIEN,2,"B",(CDT_".1")),-1) I ICDDA D
. . S ICDAIEN=$O(^ICD(ICDIEN,2,"B",ICDDA,"")) I ICDAIEN D
. . . S ICDCC=$P(^ICD(ICDIEN,2,ICDAIEN,0),U,4)
Q ICDCC
;
DEFAULT G:ICDMDC=15 GETMOR S (ICDRG,ICDRGH)=$O(ICDODRG(0)) G:ICDRG'>0 ENTER
D DODRG
G:ICDRG'>0 AGAIN
Q
ENTER I 'ICDNOR,ICDORNR'=0,ICDMDC'=20,ICDMDC'=15 S ICDRG=983
GETMOR S (ICDRG,ICDRGH)=$O(ICDPDRG(0)) S:ICDRG'>0 (ICDRG,ICDRGH)=998
CKDRG D DODRG
Q
;I ICDRG="" K ICDPDRG(ICDRGH) G GETMOR
DODRG ;Go to DRG file and retrieve table entry to use if defined
Q:ICDNODOD=1 ;Actual DRG was found prior Ex: Neonate
N ICDMCV,ICDMCV1,ICDMCV2
N DRGFY,ICDREF S (DRGFY,ICDREF)=""
I ICDRG S DRGFY=$O(^ICD(ICDRG,2,"B",$P(+$G(ICDDATE),".")_.01),-1)
I 'DRGFY S DRGFY=ICDDATE ;default to current fiscal year
S ICDREF=$O(^ICD(+ICDRG,2,"B",+DRGFY,ICDREF))
I ICDREF'="" D
. S ICDREF=$P($G(^ICD(+ICDRG,2,ICDREF,0)),U,3)
. S ICDREF="DRG"_ICDRG_"^"_ICDREF D @ICDREF K ICDREF
Q
ORNI(X) ;
N I,K
S K=0 F I=1:1:$L(ICDORNI) I $E(ICDORNI,I,I)="z"!($E(ICDORNI,I,I)="y") S K=K+1
Q K
END ;
; - MDC24 PROCESSING
; - MDC25 PROCESSING
; - PREMDC PROCESSING
; - MDC4 PROCESSING
; - CHECK FOR MCC/CC
;
;MDC24 PROCESSING
D:ICDP24'=""!($D(ICDS24)) CKMST^ICDDRGX1 S ICDDRG=ICDRG
I ICDRG=976!(ICDRG=977)!(ICDRG=24&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=24 S ICDRG=99
;MDC25 PROCESSING
D:$G(ICDP25)=1!(($G(ICDP25)>1)&($D(ICDS25(1)))) CKHIV^ICDDRGX1 S ICDDRG=ICDRG
;PRE-MDC PROCESSING
;I $D(ICDNMDC(1)) I ICDNMDC(1)="" D CKNMDC^ICDDRGX1 S ICDDRG=ICDRG K ICDNMDC
S ICDPREQ=0 D PREMDC
Q:ICDPREQ
;PREMDC may have found an actual DRG and does not need to Do DODRG to apply CC/MCC rules, so ICDFOUND=1 and ICDNODOD=1
;MDC4 PROCESSING
I ICDRG=983 D CHKMDC4^ICDDRGX1
; CHECK FOR MCC/CC
D:'ICDNODOD DODRG ;check for MCC/CC
S:ICDRTC="" ICDRTC=0
S ICDTMP=$$DRG^ICDGTDRG(ICDRG,ICDDATE) I '$P(ICDTMP,U,14) S ICDRG=999
Q
G KILL^ICDDRG
AGAIN G:'$D(ICDODRG) ENTER
K ICDODRG(ICDRGH) I $O(ICDODRG(ICDRGH))'>0 K ICDODRG Q
S ICDRG=$O(ICDODRG(ICDRGH))
Q
;
CKBURN ; MDC22 - Burns (extensive, full thickness, or non-extensive)
D
. I $D(ICD10PD("*"))!($D(ICD10SD("*"))) S ICDRG=$S($D(ICD10OR("k")):927,1:933) Q
. I $D(ICD10PD("b"))!($D(ICD10SD("b"))) D FTBURN Q
. S ICDRG=$S(ICDCC!($D(ICD10PD("T")))!($D(ICD10SD("T"))):935,1:935)
Q
; FTBURN ; full thickness burn check
I $D(ICD10SD("j"))!($D(ICD10OR("k"))) D
. I ICDCC!($D(ICD10PD("T")))!($D(ICD10SD("T"))) S ICDRG=928
. E S ICDRG=929
E D
. I ICDCC!($D(ICD10PD("T")))!($D(ICD10SD("T"))) S ICDRG=934
. E S ICDRG=934
Q
;
FTBURN ; full thickness burn check
I $D(ICD10SD("j"))!($D(ICD10OR("k"))) D
. I ICDCC!($D(ICD10PD("T")))!($D(ICD10SD("T"))) S ICDRG=928
. E S ICDRG=929
E D
. I ICDCC!($D(ICD10PD("T")))!($D(ICD10SD("T"))) S ICDRG=934
. E S ICDRG=934
Q
;
MI ;
; if PTCA and not a bypass
I $D(ICD10OR("1"))!($D(ICDOP(" 37.90"))) I '$D(ICD10OR("b"))&('$D(ICD10OR("6"))) D CMS516^ICDTBL2 Q
I $D(ICDPD("A")) D EN1^ICDDRG5 I ICDCC3 S ICDRG=$O(ICDODRG(0)) D DODRG Q
I ($D(ICD10PD("A"))&($D(ICD10PD("I"))))!($D(ICD10SD("A"))&($D(ICD10SD("I")))) D Q
. S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):285,$D(ICD10PD("V"))!($D(ICD10SD("V"))):280,1:282)
I $D(ICDOP(" 37.26"))&($D(ICDOP(" 39.61"))) S ICDRG=230 Q
I $D(ICD10OR("H")) S ICDRG=$S($D(ICD10PD("X"))!($D(ICD10SD("X"))):286,1:287) Q
K ICDPDRG(286),ICDPDRG(287)
I $D(ICD10OR("p")) S ICDRG=$O(ICDODRG(0)) D DODRG Q
I $D(ICD10OR("F")) S ICDRG=$O(ICDODRG(0)) D DODRG Q
E K ICDPDRG(280),ICDPDRG(281),ICDPDRG(282) S ICDRG=$O(ICDPDRG(0)) D DODRG Q
Q
;
PREMDC ; Check if any Surgical Procedure Code in Pre-MDC and, if so, use that DRG group
N ICDTMP,ICDPC,ICDX,ICDI,ICDCCT,ICDRGT
S ICDPC="",ICDRGT=999 F S ICDPC=$O(ICDPRC(ICDPC)) Q:ICDPC="" I $D(ICD10OR(80)) S ICDTMP=$$GETDRG^ICDEX(80.1,ICDPRC(ICDPC),ICDDATE,98) D
. I $P(ICDTMP,";",1)'=-1 S ICDX=$P(ICDTMP,";",1) F ICDI=1:1 Q:$P(ICDX,U,ICDI)="" D
. . S ICDCCT=$$ICDRGCC^ICDRGAPI($P(ICDX,U,ICDI),ICDDATE) I ICDCCT=ICDMCC!(ICDCCT=3&(ICDMCC=1!(ICDMCC=2))) S:$P(ICDX,U,1)<ICDRGT ICDRGT=$P(ICDX,U,ICDI) Q
D
. I $D(ICD10OR("q")) S ICDRGT=$S(ICDMCC=2:1,1:2) Q ;Heart Transplant
. I $D(ICD10OR("r")) S ICDRGT=7 Q ;Lung Transplant
. I $D(ICD10OR(245)) S ICDRGT=8 Q ;Simultaneous Pancreas/Kidney Transplant
. I $D(ICD10OR(116)) S ICDRGT=10 Q ;Pancreas Transplant
. ;Next Block for DRGs 3 and 4: PreMDC ECMO/Tracheostomy/MV96+/Major OR/PDX Except Face,Mount not DRG11,12 or 13
. I $D(ICD10OR(44)) S ICDRGT=3 Q ;ECMO
. I $D(ICD10OR(150)) S ICDRGT=$S($D(ICD10OR(81)):3,1:4) Q ;Tracheostomy
. ;End of ECMO etc..
. I ($D(ICD10OR(68))&(ICDMCC=2))!($D(ICD10OR(59))) S ICDRGT=5 Q ;(Liver Transplant w/MCC) OR (Intestinal Implant)
. I $D(ICD10OR(68)),ICDMCC=0 S ICDRGT=6 Q ;Intestinal implant
. I $D(ICD10OR(151))!($D(ICD10OR(66))) S ICDRGT=$S(ICDMCC=2:11,ICDMCC=1:12,1:13) Q ;151=Tracheostomy for Face, Mouth and Neck Diagnoses 66=Laryngectomy
. I $D(ICD10OR(14)) S ICDRGT=14 Q ;Allogeneic Bone Marrow Transplant
. I $D(ICD10OR(22)) S ICDRGT=$S(ICDMCC>0:16,1:17) Q ;Autologous Bone Marrow Transplant
I ICDRGT'=999 S ICDRG=ICDRGT,(ICDFOUND,ICDNODOD,ICDPREQ)=1
Q
;
PDX11T13() ;Is PDX assigned to DRG 11, 12 or 12
I $D(ICDPDRG(11))!($D(ICD10PDRG(12)))!($D(ICD10PDRG(13))) Q 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDDG010 10937 printed Sep 23, 2025@19:26:05 Page 2
ICDDG010 ;KUM - DRG GROUPER PROCESSING BEGINS ;05/02/12 4:06pm
+1 ;;18.0;DRG Grouper;**64,82**;Oct 20, 2000;Build 21
+2 ;
+3 ;GROUPING PROCESS BEGINS
+4 ;
GROUP ;
+1 NEW ICDFOUND,ICDRGH,ICDNODOD,ICDPREQ
+2 SET (ICDFOUND,ICDNODOD)=0
+3 ; Handle PRE-CONDITIONS
DO PRECOND
IF ICDRTC=4
IF ICDRG=999
GOTO GLAST
+4 IF 'ICDFOUND
DO VARIABLS^ICDDRGX2
+5 ; PROCESSING FOR MDC5, MDC19, MDC23, MDC14, MDC20, MDC22, MDC15
IF 'ICDFOUND
DO MDCSPROC
+6 ;MDCSPROC may have found a DRG group but still needs to Do DODRG to apply CC/MCC rules, so ICDFOUND=1 and ICDNODOD=0
+7 ; Handle Neonatal Processing
DO NEONATE
+8 ;NEONATE may have found an actual DRG and does not need to Do DODRG to apply CC/MCC rules, so ICDFOUND=1 and ICDNODOD=1
+9 ; Apply Surgical Hierarchy
IF 'ICDFOUND
DO SURGICAL
+10 ; Default Processing
IF 'ICDFOUND
DO DEFAULT
+11 ; MDC24 PROCESSING
+12 ; MDC25 PROCESSING
+13 ; PREMDC PROCESSING
+14 ; MDC4 PROCESSING
+15 DO END
GLAST ;
+1 SET ICDDRG=ICDRG
+2 DO KILL^ICDDRG
+3 if +$GET(ICDRG)'>0
SET ICDRG=999
+4 QUIT
+5 ;
PRECOND ; PRE - CONDITIONS
+1 IF $DATA(ICDSEX(1))&($DATA(ICDSEX(2)))
SET ICDRTC=4
SET ICDRG=999
+2 QUIT
+3 ;
MDCSPROC ; Processing for MDCs 5, 19, 23, 14, 20, 22 and 15
+1 NEW ICDMDCL
+2 SET ICDMDCL="/14/15/17/18/19/20/23/"[("/"_ICDMDC_"/")
+3 IF 'ICDMDCL
if ICDOPCT<2
Begin DoDot:1
+4 IF $DATA(ICDF)
QUIT
+5 IF $DATA(ICD10PD("M"))
IF '$DATA(ICD10OR("y"))
SET ICDOPCT=0
QUIT
+6 IF $DATA(ICD10OR("O"))
IF ICDNOR=ICDONR
IF ICDNOR>0
IF '$DATA(ICDPDRG(769))
IF '$DATA(ICD10ORNI("p"))
SET ICDRG=$SELECT($DATA(ICD10ORNI("O")):983,$DATA(ICD10ORNI("y")):986,$DATA(ICD10ORNI("z")):989,1:983)
SET ICDFOUND=1
QUIT
+7 IF ICDOPNR
SET ICDRG=$SELECT($DATA(ICD10ORNI("y")):986,1:983)
SET ICDOPNR=0
SET ICDFOUND=1
QUIT
End DoDot:1
IF "^983^986^989^"[(U_ICDRG_U)
SET ICDFOUND=1
QUIT
+8 ;
+9 ;if number of non-extensive ORs eqs # OR, 477
+10 ;
+11 IF 'ICDMDCL
IF '$DATA(ICD10ORNI("y"))&($DATA(ICD10ORNI))&($DATA(ICD10ORNI("z")))
Begin DoDot:1
+12 IF $DATA(ICDF)
QUIT
+13 NEW K
SET K=$$ORNI(ICDORNI)
IF K=ICDOPCT
SET ICDRG=989
SET ICDFOUND=1
QUIT
End DoDot:1
IF ICDRG=989
SET ICDFOUND=1
QUIT
+14 ;
+15 ;if number of non-extensive ORs+prostatics eqs # OR, 476
+16 ;
+17 IF 'ICDMDCL
IF $DATA(ICD10ORNI("y"))&($DATA(ICDORNI))
Begin DoDot:1
+18 NEW K
SET K=$$ORNI(ICDORNI)
IF K=ICDOPCT&(ICDNOR=ICDONR)
SET ICDRG=986
SET ICDFOUND=1
QUIT
End DoDot:1
IF ICDRG=986
SET ICDFOUND=1
QUIT
+19 IF 'ICDMDCL
IF ICDNOR=ICDONR&(ICDOPCT>0)
SET ICDRG=983
SET ICDFOUND=1
QUIT
+20 IF ICDMDC=5
IF '$DATA(ICD10OR("O"))
SET ICDRTC=$SELECT(ICDEXP="":5,1:"")
if ICDRTC'=""
SET ICDRG=999
if ICDRTC=""
DO MI
QUIT
+21 IF ICDMDC=19
IF ICDOCNT>0
IF $DATA(ICD10OR("O"))
SET (ICDRG,ICDRGH)=876
SET ICDFOUND=1
QUIT
+22 IF ICDMDC=23
IF $DATA(ICD10OR("O"))!($DATA(ICD10ORNI("O")))
SET ICDRG=941
SET ICDFOUND=1
QUIT
+23 ;I ICDMDC=14 D ^ICDDRG14 I ICDRG]"" S ICDFOUND=1 Q
+24 IF ICDMDC=20
SET ICDRTC=$SELECT(ICDDMS="":7,1:"")
IF ICDDMS'=0
SET ICDRG=$SELECT(ICDDMS="":999,1:894)
SET ICDFOUND=1
QUIT
+25 IF ICDMDC=22
SET ICDRTC=$SELECT(ICDTRS="":6,1:"")
if ICDRTC'=""
SET ICDRG=999
SET ICDFOUND=1
if ICDRTC=""
DO CKBURN
+26 ;I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I ICDTRS'=0 S ICDRG=$S(ICDRTC'="":999,1:789),ICDFOUND=1 Q
+27 ;
+28 QUIT
NEONATE ; Neonatal Processing
+1 NEW ICDOLD
+2 SET ICDOLD=29
SET X1=$SELECT($GET(DGADM):$GET(DGADM),1:DT)
SET X2=$GET(DOB)
IF X1
IF X2
DO ^%DTC
SET ICDOLD=X
+3 IF ICDOLD<29
SET ICDMDC=15
+4 IF '$TEST
QUIT
+5 IF ICDMDC=15
SET ICDRTC=$SELECT(ICDEXP="":5,ICDTRS="":6,1:"")
IF +ICDTRS'=0
Begin DoDot:1
+6 ;Transferred to another acute care facility
SET ICDRG=$SELECT(ICDRTC'="":999,1:789)
End DoDot:1
SET (ICDFOUND,ICDNODOD)=1
QUIT
+7 IF ICDMDC'=15
QUIT
+8 IF ICDEXP
SET ICDRG=789
SET (ICDFOUND,ICDNODOD)=1
QUIT
+9 ;If no Procedure Codes entered or no DRGs found for Procedure Codes that were entered:
+10 IF 'ICDNOR!('$DATA(ICDODRG))
SET ICDRG=$ORDER(ICDPDRG(0))
XECUTE "I ICDMDC=15,$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG D NEONATF^ICDDRG0"
Begin DoDot:1
+11 NEW X,X1,X2,%
+12 IF ICDOLD<29
DO NBCOMP
QUIT
+13 IF ICDRG<789!(ICDRG>795)
QUIT
+14 IF $ORDER(ICDRG(795))
SET ICDRG=$ORDER(ICDRG(795))
SET (ICDFOUND,ICDNODOD)=1
QUIT
+15 IF 'ICDRG
SET ICDRG=999
SET ICDRTC=8
End DoDot:1
QUIT
+16 IF AGE=""
IF ICDMDC=3
SET ICDRTC=3
SET ICDRG=999
SET (ICDFOUND,ICDNODOD)=1
QUIT
+17 SET ICDDRG=ICDRG
SET (ICDFOUND,ICDNODOD)=1
+18 QUIT
+19 ;
NEONATF ;NEONATE - Continuation of xecute line
+1 SET ICDRG=$SELECT($DATA(ICDPDRG(795)):795,$DATA(ICDPDRG(791)):791,1:$ORDER(ICDSDRG(0)))
+2 QUIT
+3 ;
NBCOMP ; check for complication related to Newborn
+1 NEW ICDSDXCK,ICDN,ICDX,ICDPREM,ICDMJR,ICDIMM,ICDSIG
+2 ;Check for Premature and Major Problem in PDX or SDX
+3 ;ICDPREM 1=PREMATURE (ID="p") ICDIMM 1=EXTREME IMMATURE (ID="E") ICDMJR 1=MAJORPROBLEMS (ID="J")
+4 SET (ICDN,ICDPREM,ICDIMM,ICDMJR,ICDSIG)=0
FOR
SET ICDN=$ORDER(ICDDX(ICDN))
if 'ICDN
QUIT
Begin DoDot:1
+5 if $DATA(ICD10PD("p"))!($DATA(ICD10SD("p")))
SET ICDPREM=1
if $DATA(ICD10PD("J"))!($DATA(ICD10SD("J")))
SET ICDMJR=1
+6 if $DATA(ICD10PD("E"))!($DATA(ICD10SD("E")))
SET ICDIMM=1
if $DATA(ICD10PD("S"))!($DATA(ICD10SD("S")))
SET ICDSIG=1
End DoDot:1
+7 IF ICDSIG
SET ICDRG=794
SET (ICDFOUND,ICDNODOD)=1
QUIT
+8 IF ICDIMM
SET ICDRG=790
SET (ICDFOUND,ICDNODOD)=1
QUIT
+9 IF ICDPREM=1
if ICDMJR
SET ICDRG=791
SET (ICDFOUND,ICDNODOD)=1
if 'ICDMJR
SET ICDRG=792
SET (ICDFOUND,ICDNODOD)=1
QUIT
+10 IF 'ICDPREM
if ICDMJR
SET ICDRG=793
SET (ICDFOUND,ICDNODOD)=1
if 'ICDMJR
SET ICDRG=795
SET (ICDFOUND,ICDNODOD)=1
QUIT
+11 QUIT
+12 ;
SURGICAL ; Apply Surgical Hierarchy
+1 NEW ICDJ,ICDSTOP,ICDDGIEN,ICDDRGT,ICDMIEN
+2 SET ICDDRG=0
SET ICDSTOP=0
SET ICDDA=$ORDER(^ICDRS("B",ICDDATE_".1"),-1)
IF 'ICDDA
QUIT
+3 SET ICDIEN=$ORDER(^ICDRS("B",ICDDA,""))
IF 'ICDIEN
QUIT
+4 SET ICDMIEN=$ORDER(^ICDRS(ICDIEN,1,"B",ICDMDC,""))
IF 'ICDMIEN
QUIT
+5 FOR ICDJ=0:0
SET ICDJ=$ORDER(^ICDRS(ICDIEN,1,ICDMIEN,2,"C",ICDJ))
if ICDJ'>0!(ICDSTOP)
QUIT
SET ICDDGIEN=$ORDER(^ICDRS(ICDIEN,1,ICDMIEN,2,"C",ICDJ,""))
IF ICDDGIEN
Begin DoDot:1
+6 SET ICDDRGT=$PIECE(^ICDRS(ICDIEN,1,ICDMIEN,2,ICDDGIEN,0),U,1)
IF $DATA(ICDODRG(ICDDRGT))
Begin DoDot:2
+7 SET ICDCCT=$$ICDRGCC(ICDDRGT,ICDDATE)
IF ICDCCT=ICDCC
SET ICDRG=ICDDRGT
SET ICDSTOP=1
QUIT
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
ICDRGCC(DRG,CDT) ;Get CC/MCC flag from DRG
+1 ;
+2 ; Input:
+3 ; DRG DRG Number
+4 ; CDT Effective Date
+5 ;
+6 ; Output: CC/MCC Flag 0-3
+7 ;
+8 NEW ICDCC,ICDIEN,ICDDA,ICDAIEN
+9 SET ICDCC=0
SET ICDIEN=$ORDER(^ICD("B","DRG"_DRG,""))
IF ICDIEN
Begin DoDot:1
+10 SET ICDDA=$ORDER(^ICD(ICDIEN,2,"B",(CDT_".1")),-1)
IF ICDDA
Begin DoDot:2
+11 SET ICDAIEN=$ORDER(^ICD(ICDIEN,2,"B",ICDDA,""))
IF ICDAIEN
Begin DoDot:3
+12 SET ICDCC=$PIECE(^ICD(ICDIEN,2,ICDAIEN,0),U,4)
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT ICDCC
+14 ;
DEFAULT if ICDMDC=15
GOTO GETMOR
SET (ICDRG,ICDRGH)=$ORDER(ICDODRG(0))
if ICDRG'>0
GOTO ENTER
+1 DO DODRG
+2 if ICDRG'>0
GOTO AGAIN
+3 QUIT
ENTER IF 'ICDNOR
IF ICDORNR'=0
IF ICDMDC'=20
IF ICDMDC'=15
SET ICDRG=983
GETMOR SET (ICDRG,ICDRGH)=$ORDER(ICDPDRG(0))
if ICDRG'>0
SET (ICDRG,ICDRGH)=998
CKDRG DO DODRG
+1 QUIT
+2 ;I ICDRG="" K ICDPDRG(ICDRGH) G GETMOR
DODRG ;Go to DRG file and retrieve table entry to use if defined
+1 ;Actual DRG was found prior Ex: Neonate
if ICDNODOD=1
QUIT
+2 NEW ICDMCV,ICDMCV1,ICDMCV2
+3 NEW DRGFY,ICDREF
SET (DRGFY,ICDREF)=""
+4 IF ICDRG
SET DRGFY=$ORDER(^ICD(ICDRG,2,"B",$PIECE(+$GET(ICDDATE),".")_.01),-1)
+5 ;default to current fiscal year
IF 'DRGFY
SET DRGFY=ICDDATE
+6 SET ICDREF=$ORDER(^ICD(+ICDRG,2,"B",+DRGFY,ICDREF))
+7 IF ICDREF'=""
Begin DoDot:1
+8 SET ICDREF=$PIECE($GET(^ICD(+ICDRG,2,ICDREF,0)),U,3)
+9 SET ICDREF="DRG"_ICDRG_"^"_ICDREF
DO @ICDREF
KILL ICDREF
End DoDot:1
+10 QUIT
ORNI(X) ;
+1 NEW I,K
+2 SET K=0
FOR I=1:1:$LENGTH(ICDORNI)
IF $EXTRACT(ICDORNI,I,I)="z"!($EXTRACT(ICDORNI,I,I)="y")
SET K=K+1
+3 QUIT K
END ;
+1 ; - MDC24 PROCESSING
+2 ; - MDC25 PROCESSING
+3 ; - PREMDC PROCESSING
+4 ; - MDC4 PROCESSING
+5 ; - CHECK FOR MCC/CC
+6 ;
+7 ;MDC24 PROCESSING
+8 if ICDP24'=""!($DATA(ICDS24))
DO CKMST^ICDDRGX1
SET ICDDRG=ICDRG
+9 IF ICDRG=976!(ICDRG=977)!(ICDRG=24&($GET(ICDOR)=""))
SET ICDRG=$PIECE($GET(ICDPDRG),U,2)
IF ICDRG=24
SET ICDRG=99
+10 ;MDC25 PROCESSING
+11 if $GET(ICDP25)=1!(($GET(ICDP25)>1)&($DATA(ICDS25(1))))
DO CKHIV^ICDDRGX1
SET ICDDRG=ICDRG
+12 ;PRE-MDC PROCESSING
+13 ;I $D(ICDNMDC(1)) I ICDNMDC(1)="" D CKNMDC^ICDDRGX1 S ICDDRG=ICDRG K ICDNMDC
+14 SET ICDPREQ=0
DO PREMDC
+15 if ICDPREQ
QUIT
+16 ;PREMDC may have found an actual DRG and does not need to Do DODRG to apply CC/MCC rules, so ICDFOUND=1 and ICDNODOD=1
+17 ;MDC4 PROCESSING
+18 IF ICDRG=983
DO CHKMDC4^ICDDRGX1
+19 ; CHECK FOR MCC/CC
+20 ;check for MCC/CC
if 'ICDNODOD
DO DODRG
+21 if ICDRTC=""
SET ICDRTC=0
+22 SET ICDTMP=$$DRG^ICDGTDRG(ICDRG,ICDDATE)
IF '$PIECE(ICDTMP,U,14)
SET ICDRG=999
+23 QUIT
+24 GOTO KILL^ICDDRG
AGAIN if '$DATA(ICDODRG)
GOTO ENTER
+1 KILL ICDODRG(ICDRGH)
IF $ORDER(ICDODRG(ICDRGH))'>0
KILL ICDODRG
QUIT
+2 SET ICDRG=$ORDER(ICDODRG(ICDRGH))
+3 QUIT
+4 ;
CKBURN ; MDC22 - Burns (extensive, full thickness, or non-extensive)
+1 Begin DoDot:1
+2 IF $DATA(ICD10PD("*"))!($DATA(ICD10SD("*")))
SET ICDRG=$SELECT($DATA(ICD10OR("k")):927,1:933)
QUIT
+3 IF $DATA(ICD10PD("b"))!($DATA(ICD10SD("b")))
DO FTBURN
QUIT
+4 SET ICDRG=$SELECT(ICDCC!($DATA(ICD10PD("T")))!($DATA(ICD10SD("T"))):935,1:935)
End DoDot:1
+5 QUIT
+6 ; FTBURN ; full thickness burn check
+7 IF $DATA(ICD10SD("j"))!($DATA(ICD10OR("k")))
Begin DoDot:1
+8 IF ICDCC!($DATA(ICD10PD("T")))!($DATA(ICD10SD("T")))
SET ICDRG=928
+9 IF '$TEST
SET ICDRG=929
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 IF ICDCC!($DATA(ICD10PD("T")))!($DATA(ICD10SD("T")))
SET ICDRG=934
+12 IF '$TEST
SET ICDRG=934
End DoDot:1
+13 QUIT
+14 ;
FTBURN ; full thickness burn check
+1 IF $DATA(ICD10SD("j"))!($DATA(ICD10OR("k")))
Begin DoDot:1
+2 IF ICDCC!($DATA(ICD10PD("T")))!($DATA(ICD10SD("T")))
SET ICDRG=928
+3 IF '$TEST
SET ICDRG=929
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 IF ICDCC!($DATA(ICD10PD("T")))!($DATA(ICD10SD("T")))
SET ICDRG=934
+6 IF '$TEST
SET ICDRG=934
End DoDot:1
+7 QUIT
+8 ;
MI ;
+1 ; if PTCA and not a bypass
+2 IF $DATA(ICD10OR("1"))!($DATA(ICDOP(" 37.90")))
IF '$DATA(ICD10OR("b"))&('$DATA(ICD10OR("6")))
DO CMS516^ICDTBL2
QUIT
+3 IF $DATA(ICDPD("A"))
DO EN1^ICDDRG5
IF ICDCC3
SET ICDRG=$ORDER(ICDODRG(0))
DO DODRG
QUIT
+4 IF ($DATA(ICD10PD("A"))&($DATA(ICD10PD("I"))))!($DATA(ICD10SD("A"))&($DATA(ICD10SD("I"))))
Begin DoDot:1
+5 SET ICDRG=$SELECT($SELECT($DATA(ICDEXP):ICDEXP,1:0):285,$DATA(ICD10PD("V"))!($DATA(ICD10SD("V"))):280,1:282)
End DoDot:1
QUIT
+6 IF $DATA(ICDOP(" 37.26"))&($DATA(ICDOP(" 39.61")))
SET ICDRG=230
QUIT
+7 IF $DATA(ICD10OR("H"))
SET ICDRG=$SELECT($DATA(ICD10PD("X"))!($DATA(ICD10SD("X"))):286,1:287)
QUIT
+8 KILL ICDPDRG(286),ICDPDRG(287)
+9 IF $DATA(ICD10OR("p"))
SET ICDRG=$ORDER(ICDODRG(0))
DO DODRG
QUIT
+10 IF $DATA(ICD10OR("F"))
SET ICDRG=$ORDER(ICDODRG(0))
DO DODRG
QUIT
+11 IF '$TEST
KILL ICDPDRG(280),ICDPDRG(281),ICDPDRG(282)
SET ICDRG=$ORDER(ICDPDRG(0))
DO DODRG
QUIT
+12 QUIT
+13 ;
PREMDC ; Check if any Surgical Procedure Code in Pre-MDC and, if so, use that DRG group
+1 NEW ICDTMP,ICDPC,ICDX,ICDI,ICDCCT,ICDRGT
+2 SET ICDPC=""
SET ICDRGT=999
FOR
SET ICDPC=$ORDER(ICDPRC(ICDPC))
if ICDPC=""
QUIT
IF $DATA(ICD10OR(80))
SET ICDTMP=$$GETDRG^ICDEX(80.1,ICDPRC(ICDPC),ICDDATE,98)
Begin DoDot:1
+3 IF $PIECE(ICDTMP,";",1)'=-1
SET ICDX=$PIECE(ICDTMP,";",1)
FOR ICDI=1:1
if $PIECE(ICDX,U,ICDI)=""
QUIT
Begin DoDot:2
+4 SET ICDCCT=$$ICDRGCC^ICDRGAPI($PIECE(ICDX,U,ICDI),ICDDATE)
IF ICDCCT=ICDMCC!(ICDCCT=3&(ICDMCC=1!(ICDMCC=2)))
if $PIECE(ICDX,U,1)<ICDRGT
SET ICDRGT=$PIECE(ICDX,U,ICDI)
QUIT
End DoDot:2
End DoDot:1
+5 Begin DoDot:1
+6 ;Heart Transplant
IF $DATA(ICD10OR("q"))
SET ICDRGT=$SELECT(ICDMCC=2:1,1:2)
QUIT
+7 ;Lung Transplant
IF $DATA(ICD10OR("r"))
SET ICDRGT=7
QUIT
+8 ;Simultaneous Pancreas/Kidney Transplant
IF $DATA(ICD10OR(245))
SET ICDRGT=8
QUIT
+9 ;Pancreas Transplant
IF $DATA(ICD10OR(116))
SET ICDRGT=10
QUIT
+10 ;Next Block for DRGs 3 and 4: PreMDC ECMO/Tracheostomy/MV96+/Major OR/PDX Except Face,Mount not DRG11,12 or 13
+11 ;ECMO
IF $DATA(ICD10OR(44))
SET ICDRGT=3
QUIT
+12 ;Tracheostomy
IF $DATA(ICD10OR(150))
SET ICDRGT=$SELECT($DATA(ICD10OR(81)):3,1:4)
QUIT
+13 ;End of ECMO etc..
+14 ;(Liver Transplant w/MCC) OR (Intestinal Implant)
IF ($DATA(ICD10OR(68))&(ICDMCC=2))!($DATA(ICD10OR(59)))
SET ICDRGT=5
QUIT
+15 ;Intestinal implant
IF $DATA(ICD10OR(68))
IF ICDMCC=0
SET ICDRGT=6
QUIT
+16 ;151=Tracheostomy for Face, Mouth and Neck Diagnoses 66=Laryngectomy
IF $DATA(ICD10OR(151))!($DATA(ICD10OR(66)))
SET ICDRGT=$SELECT(ICDMCC=2:11,ICDMCC=1:12,1:13)
QUIT
+17 ;Allogeneic Bone Marrow Transplant
IF $DATA(ICD10OR(14))
SET ICDRGT=14
QUIT
+18 ;Autologous Bone Marrow Transplant
IF $DATA(ICD10OR(22))
SET ICDRGT=$SELECT(ICDMCC>0:16,1:17)
QUIT
End DoDot:1
+19 IF ICDRGT'=999
SET ICDRG=ICDRGT
SET (ICDFOUND,ICDNODOD,ICDPREQ)=1
+20 QUIT
+21 ;
PDX11T13() ;Is PDX assigned to DRG 11, 12 or 12
+1 IF $DATA(ICDPDRG(11))!($DATA(ICD10PDRG(12)))!($DATA(ICD10PDRG(13)))
QUIT 1
+2 QUIT 0
+3 ;
