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

ICDDRGX1.m

Go to the documentation of this file.
  1. ICDDRGX1 ;KUM - GROUPER PROCESS ;05/10/12 3:44pm
  1. ;;18.0;DRG Grouper;**64**;Oct 20, 2000;Build 103
  1. ;
  1. CKMST ;MDC24 Grouping
  1. N ICDI
  1. S ICDAJ=0 F ICDS24K=1:1 S ICDAJ=$O(ICDS24(ICDAJ)) Q:ICDAJ=""
  1. S ICDS24K=ICDS24K-1,ICDS24L=0 F ICDI=1:1:8 S:$D(ICDS24(ICDI))&(ICDI'=ICDP24) ICDS24L=$S($D(ICDS24(ICDI)):1,1:0)
  1. I $D(ICD10OR(112)) S ICDS24K=ICDS24K+1 ;112=Other O.R. Procedues for MST
  1. G:((ICDP24=0)&(ICDS24K<2))!((ICDP24>0)&('ICDS24L)) CKMSTE
  1. S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):955,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):955,1:ICDRG) I ICDRG=955 D CKMSTE Q
  1. S:ICDRG'=955 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):956,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):956,1:ICDRG) I ICDRG=956 D CKMSTE Q
  1. S:ICDRG'=956 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):959,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):959,1:ICDRG) I ICDRG=959 D CKMSTE Q
  1. S ICDRG=$S(ICDP24=0&(ICDS24K>1):965,ICDP24>0&ICDS24L:965,1:ICDRG)
  1. S:(ICDRG>954)&(ICDRG<966) ICDRTC=0
  1. CKMSTE K ICDAJ,ICDP24,ICDS24,ICDO24,ICDS24K,ICDO24,ICDS24L
  1. Q
  1. CKHIV ;MDC25 grouping; MS-DRG
  1. I '$D(ICD10PD("h"))&'$D(ICD10SD("h")) Q
  1. S ICDRG=$S($D(ICD10OR("x")):970,$D(ICD10PD("i"))&($D(ICDS25(1))):977,1:ICDRG)
  1. ;S ICDGH=$S("969^976^977"[ICDRG:1,1:0),ICDORNI=$S(ICDOCNT>0:ICDORNI,1:0),ICDORNA=$F(ICDORNI,"O",$F(ICDORNI,"O"))
  1. S ICDGH=$S("969^976^977"[ICDRG:1,1:0),ICDORNI=$S(ICDOCNT>0:ICDORNI,1:0),ICDORNA=$G(ICD10ORNI("O"))-1
  1. S:ICDORNI="" ICDORNI=ICDOR
  1. S ICDRG=$S(ICDP25=1&(ICDORNA>0):970,1:ICDRG) I 'ICDGH&(ICDRG=970) D CKMS Q
  1. S:(ICDOCNT>0) ICDRG=$S(ICDP25>1&(ICDORNA>0)&($D(ICDS25(1))):970,1:ICDRG) I 'ICDGH&(ICDRG=970) D CKMS Q
  1. I ICDOPCT>0 D I ICDRG=970 D CKMS Q
  1. .;count the non-extensive "z" vs the "O"
  1. .N K1,K2,I
  1. .S (K1,K2)=0
  1. .S K1=ICD10ORNI("z")
  1. .S K2=ICD10ORNI("O")
  1. .;F I=1:1:$L(ICDORNI) S:$E(ICDORNI,I,I)="z" K1=K1+1 S:$E(ICDORNI,I,I)="O" K2=K2+1
  1. .I ICDP25=1!(ICDP25>1&($D(ICDS25)>0)) D
  1. ..I K1<K2&(K1<ICDOPCT) D
  1. ...S ICDRG=970 Q
  1. ..I ICDOPCT=1&('$D(ICDORNI("z"))) D
  1. ...S ICDRG=970 Q
  1. S ICDRG=$S(ICDP25=1&('$D(ICDS25))&('$$EXIST^ICDEX(ICDDX(1),30)):977,1:ICDRG) I 'ICDGH&(ICDRG=977) D CKMS Q
  1. S ICDRG=$S(ICDP25=1&($D(ICDS25(2))):976,ICDP25=1&($D(ICDS25(3))):976,1:ICDRG) I 'ICDGH&((ICDRG=976)!(ICDRG=977)) D CKMS Q
  1. S ICDRG=$S(ICDP25=2&($D(ICDS25(1))):976,ICDP25=3&($D(ICDS25(1))):977,1:ICDRG) I 'ICDGH&((ICDRG=976)!(ICDRG=977)) D CKMS Q
  1. S ICDRG=$S((ICDP25&(ICDOCNT=0)&('$D(ICDS25))):977,1:ICDRG) I 'ICDGH&(ICDRG=977) D CKMS Q
  1. I "969^970^974^975^976^977"[ICDRG S ICDRTC=0
  1. K ICDGH,ICDP25,ICDS25,ICDORNA Q
  1. ;
  1. CKMS ;determine severity
  1. I ICDRG=970 S ICDRG=$S(ICDMCC=2:969,1:970) Q
  1. I ICDRG=976 S ICDRG=$S(ICDMCC=2:974,ICDMCC=1:975,1:976) Q
  1. ;MS-DRG 977 has no severity
  1. Q
  1. ;
  1. CHKMDC4 ;MDC 4 drg's
  1. I (ICDMDC=4!(ICDMDC=98)),($D(ICD10OR("f"))) S ICDRG=168
  1. I ICDDRG=983,$G(ICDMDC)=5 S ICDRG=264
  1. I ICDDRG=983,$G(ICDMDC)=5,ICDNOR=1 S ICDRG=264
  1. Q
  1. CKNMDC ;non MDC drg's ;
  1. I ICDRG=2 S ICDRTC=0 Q
  1. S ICDRG=$S($D(ICD10OR("l")):6,1:ICDRG) I ICDRG=6 S ICDRTC=0 Q
  1. I ICDRG=8!(ICDRG=10) S ICDRTC=0 Q
  1. S ICDRG=$S($D(ICD10OR("r")):7,1:ICDRG) I ICDRG=7 S ICDRTC=0 Q ;check for lung tx
  1. S ICDRG=$S($D(ICD10OR("q")):2,1:ICDRG) I ICDRG=2 S ICDRTC=0 Q ;check for heart tx
  1. S ICDRG=$S($D(ICD10OR("B")):14,1:ICDRG) S ICDRTC=0,ICDMDC="" Q
  1. S ICDRG=$S($D(ICD10OR("t"))&$D(ICD10PD("Y")):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
  1. Q