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

ICDDRGXM.m

Go to the documentation of this file.
  1. ICDDRGXM ;ALB/MRY/KUM - GROUPER PROCESS ;26 Mar 2013 12:33 PM
  1. ;;18.0;DRG Grouper;**31,50,62,64**;Oct 20, 2000;Build 103
  1. CKHIV ;MDC25 grouping; MS-DRG
  1. ;Q:ICDP25=""
  1. I ICDPD'["h"&(ICDSD'["h") Q
  1. S ICDRG=$S(ICDOR["x":970,ICDPD["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: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. .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&(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. CKNMDC ;non MDC drg's ;MS-DRG
  1. ;S:(ICDRG>5)&(ICDRG<14) ICDRG=999
  1. ; ICD*18*1 - reorder drg 103 higher than all Pre-MDCs 480-83 & 495
  1. I ICDRG=2 S ICDRTC=0 Q
  1. S ICDCDSY=$S(ICDDATE'<$$IMPDATE^LEXU("10D"):30,1:1)
  1. ;use FY logic to resolve DRG if no FY defined user current FY
  1. N ICDDXFY S ICDDXFY=""
  1. I ICDDATE>3040930.9 D I ICDRG=3!(ICDRG=4) S ICDRTC=0 Q ;Use DRG FY 05 logic
  1. .I $D(ICDOP(" 39.65")) S ICDRG=3 Q
  1. .I $D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29"))) I $TR($P($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")'["Y"!(($D(ICDOP(" 96.72")))) S ICDRG=4
  1. .I $D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29"))) I $TR($P($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")'["Y"!(($D(ICDOP(" 96.72")))) I ICDOR["O"&(ICDOR'["z")&(ICDOR'["y") S ICDRG=3
  1. ;S ICDRG=$S((ICDOR["l")&($D(ICDOP(" 46.97"))):5,ICDOR["l":6,1:ICDRG) I ICDRG=5!(ICDRG=6) S ICDRTC=0 Q
  1. S ICDRG=$S(ICDOR["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(ICDOR["r":7,1:ICDRG) I ICDRG=7 S ICDRTC=0 Q ;check for lung tx
  1. S ICDRG=$S(ICDOR["q":2,1:ICDRG) I ICDRG=2 S ICDRTC=0 Q ;check for heart tx
  1. S ICDRG=$S((ICDOR["B")&(ICDDATE<3101001):9,(ICDOR["B")&(ICDDATE>3100930.9):14,1:ICDRG) S ICDRTC=0,ICDMDC=""
  1. S ICDRG=$S($D(ICDOP(" 30.3"))!$D(ICDOP(" 30.4")):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
  1. S ICDRG=$S(ICDOR["t"&($TR($P($$ICDDX^ICDEX(ICDDX(1),ICDDATE,ICDCDSY,"I"),"^",3),";","")["Y"):13,1:ICDRG) I ICDRG=13 S ICDRTC=0 Q
  1. Q