Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDDG010

ICDDG010.m

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