- 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 Feb 18, 2025@23:16:25 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 ;