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

ICDDRG5.m

Go to the documentation of this file.
  1. ICDDRG5 ;ALB/GRR/EG/MRY/ADL - FIX SURGERY HIERARCHY ;3/20/03 10:36am
  1. ;;18.0;DRG Grouper;**2,5,7,10,20,22,31,37,64,77**;Oct 20, 2000;Build 2
  1. ;
  1. Q:$O(ICDODRG(0))'>0 K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0 S ICDJJ(ICDJ)="" D
  1. .I ICDDATE<3051001 D F Q
  1. .E I ICDDATE<3071001 D FY2007 Q
  1. .E I ICDDATE<3081001 D FY2008 Q
  1. .E I ICDDATE<3081001 D FY2009 Q
  1. .E D FY2015
  1. END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0 S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q
  1. F I ICDJ=103 S ICDJ(1)=ICDJ Q
  1. I ICDJ=525 S ICDJ(2)=ICDJ Q
  1. I ICDJ=104 S ICDJ(3)=ICDJ Q
  1. I ICDJ=535 S ICDJ(4)=ICDJ Q
  1. I ICDJ=536 S ICDJ(5)=ICDJ Q
  1. I ICDJ=515 S ICDJ(6)=ICDJ Q
  1. I ICDJ=108 S ICDJ(7)=ICDJ Q
  1. I ICDJ=106 S ICDJ(8)=ICDJ Q
  1. I ICDJ=110 S ICDJ(9)=ICDJ Q
  1. I ICDJ=111 S ICDJ(10)=ICDJ Q
  1. I ICDJ=113 S ICDJ(11)=ICDJ Q
  1. I ICDJ=115 S ICDJ(12)=ICDJ Q
  1. I ICDJ=116 S ICDJ(13)=ICDJ Q
  1. I ICDJ=526 S ICDJ(14)=ICDJ Q
  1. I ICDJ=527 S ICDJ(15)=ICDJ Q
  1. I ICDJ=516 S ICDJ(16)=ICDJ Q
  1. I ICDJ=517 S ICDJ(17)=ICDJ Q
  1. I ICDJ=518 S ICDJ(18)=ICDJ Q
  1. I ICDJ=478 S ICDJ(19)=ICDJ Q
  1. I ICDJ=479 S ICDJ(20)=ICDJ Q
  1. ;I ICDJ=112 S ICDJ(13)=ICDJ Q
  1. I ICDJ=114 S ICDJ(21)=ICDJ Q
  1. I ICDJ=118 S ICDJ(22)=ICDJ Q
  1. I ICDJ=117 S ICDJ(23)=ICDJ Q
  1. I ICDJ=119 S ICDJ(24)=ICDJ Q
  1. I ICDJ=120 S ICDJ(25)=ICDJ
  1. Q
  1. FY2007 ;
  1. I ICDJ=103 S ICDJ(1)=ICDJ Q
  1. I ICDJ=525 S ICDJ(2)=ICDJ Q
  1. I ICDJ=104 S ICDJ(3)=ICDJ Q
  1. I ICDJ=535 S ICDJ(4)=ICDJ Q
  1. I ICDJ=536 S ICDJ(5)=ICDJ Q
  1. I ICDJ=515 S ICDJ(6)=ICDJ Q
  1. I ICDJ=108 S ICDJ(7)=ICDJ Q
  1. I ICDJ=106 S ICDJ(8)=ICDJ Q
  1. I ICDJ=110 S ICDJ(9)=ICDJ Q
  1. I ICDJ=111 S ICDJ(10)=ICDJ Q
  1. I ICDJ=547 S ICDJ(11)=ICDJ Q
  1. I ICDJ=548 S ICDJ(12)=ICDJ Q
  1. I ICDJ=549 S ICDJ(13)=ICDJ Q
  1. I ICDJ=550 S ICDJ(14)=ICDJ Q
  1. I ICDJ=113 S ICDJ(15)=ICDJ Q
  1. I ICDJ=551 S ICDJ(16)=ICDJ Q
  1. I ICDJ=552 S ICDJ(17)=ICDJ Q
  1. I ICDJ=557 S ICDJ(18)=ICDJ Q
  1. I ICDJ=555 S ICDJ(19)=ICDJ Q
  1. I ICDJ=558 S ICDJ(20)=ICDJ Q
  1. I ICDJ=556 S ICDJ(21)=ICDJ Q
  1. I ICDJ=518 S ICDJ(22)=ICDJ Q
  1. I ICDJ=553 S ICDJ(23)=ICDJ Q
  1. I ICDJ=554 S ICDJ(24)=ICDJ Q
  1. I ICDJ=478 S ICDJ(25)=ICDJ Q
  1. I ICDJ=479 S ICDJ(26)=ICDJ Q
  1. I ICDJ=114 S ICDJ(27)=ICDJ Q
  1. I ICDJ=118 S ICDJ(28)=ICDJ Q
  1. I ICDJ=117 S ICDJ(29)=ICDJ Q
  1. I ICDJ=119 S ICDJ(30)=ICDJ Q
  1. I ICDJ=120 S ICDJ(31)=ICDJ
  1. Q
  1. FY2008 ;
  1. I ICDJ=215 S ICDJ(1)=ICDJ Q
  1. I ICDJ=221 S ICDJ(2)=ICDJ Q
  1. I ICDJ=223 S ICDJ(3)=ICDJ Q
  1. I ICDJ=225 S ICDJ(4)=ICDJ Q
  1. I ICDJ=227 S ICDJ(5)=ICDJ Q
  1. I ICDJ=230 S ICDJ(6)=ICDJ Q
  1. I ICDJ=232 S ICDJ(7)=ICDJ Q
  1. I ICDJ=234 S ICDJ(8)=ICDJ Q
  1. I ICDJ=236 S ICDJ(9)=ICDJ Q
  1. I ICDJ=238 S ICDJ(10)=ICDJ Q
  1. I ICDJ=241 S ICDJ(11)=ICDJ Q
  1. I ICDJ=244 S ICDJ(12)=ICDJ Q
  1. I ICDJ=245 S ICDJ(13)=ICDJ Q
  1. I ICDJ=247 S ICDJ(14)=ICDJ Q
  1. I ICDJ=249 S ICDJ(15)=ICDJ Q
  1. I ICDJ=251 S ICDJ(16)=ICDJ Q
  1. I ICDJ=254 S ICDJ(17)=ICDJ Q
  1. I ICDJ=257 S ICDJ(18)=ICDJ Q
  1. I ICDJ=259 S ICDJ(19)=ICDJ Q
  1. I ICDJ=262 S ICDJ(20)=ICDJ Q
  1. I ICDJ=263 S ICDJ(21)=ICDJ Q
  1. I ICDJ=264 S ICDJ(22)=ICDJ Q
  1. Q
  1. FY2009 ;
  1. I ICDJ=215 S ICDJ(1)=ICDJ Q
  1. I ICDJ=221 S ICDJ(2)=ICDJ Q
  1. I ICDJ=223 S ICDJ(3)=ICDJ Q
  1. I ICDJ=225 S ICDJ(4)=ICDJ Q
  1. I ICDJ=227 S ICDJ(5)=ICDJ Q
  1. I ICDJ=230 S ICDJ(6)=ICDJ Q
  1. I ICDJ=232 S ICDJ(7)=ICDJ Q
  1. I ICDJ=234 S ICDJ(8)=ICDJ Q
  1. I ICDJ=236 S ICDJ(9)=ICDJ Q
  1. I ICDJ=238 S ICDJ(10)=ICDJ Q
  1. I ICDJ=241 S ICDJ(11)=ICDJ Q
  1. I ICDJ=244 S ICDJ(12)=ICDJ Q
  1. I ICDJ=245 S ICDJ(13)=ICDJ Q
  1. I ICDJ=265 S ICDJ(14)=ICDJ Q
  1. I ICDJ=247 S ICDJ(15)=ICDJ Q
  1. I ICDJ=249 S ICDJ(16)=ICDJ Q
  1. I ICDJ=251 S ICDJ(17)=ICDJ Q
  1. I ICDJ=254 S ICDJ(18)=ICDJ Q
  1. I ICDJ=257 S ICDJ(19)=ICDJ Q
  1. I ICDJ=259 S ICDJ(20)=ICDJ Q
  1. I ICDJ=262 S ICDJ(21)=ICDJ Q
  1. I ICDJ=263 S ICDJ(22)=ICDJ Q
  1. I ICDJ=264 S ICDJ(23)=ICDJ Q
  1. Q
  1. FY2015 ;
  1. I ICDJ=215 S ICDJ(1)=ICDJ Q
  1. I ICDJ=221 S ICDJ(2)=ICDJ Q
  1. I ICDJ=267 S ICDJ(3)=ICDJ Q
  1. I ICDJ=223 S ICDJ(4)=ICDJ Q
  1. I ICDJ=225 S ICDJ(5)=ICDJ Q
  1. I ICDJ=227 S ICDJ(6)=ICDJ Q
  1. I ICDJ=230 S ICDJ(7)=ICDJ Q
  1. I ICDJ=232 S ICDJ(8)=ICDJ Q
  1. I ICDJ=234 S ICDJ(9)=ICDJ Q
  1. I ICDJ=236 S ICDJ(10)=ICDJ Q
  1. I ICDJ=238 S ICDJ(11)=ICDJ Q
  1. I ICDJ=241 S ICDJ(12)=ICDJ Q
  1. I ICDJ=244 S ICDJ(13)=ICDJ Q
  1. I ICDJ=245 S ICDJ(14)=ICDJ Q
  1. I ICDJ=265 S ICDJ(15)=ICDJ Q
  1. I ICDJ=247 S ICDJ(16)=ICDJ Q
  1. I ICDJ=249 S ICDJ(17)=ICDJ Q
  1. I ICDJ=251 S ICDJ(18)=ICDJ Q
  1. I ICDJ=254 S ICDJ(19)=ICDJ Q
  1. I ICDJ=257 S ICDJ(20)=ICDJ Q
  1. I ICDJ=259 S ICDJ(21)=ICDJ Q
  1. I ICDJ=262 S ICDJ(22)=ICDJ Q
  1. I ICDJ=263 S ICDJ(23)=ICDJ Q
  1. I ICDJ=264 S ICDJ(24)=ICDJ Q
  1. Q
  1. EN1 S (ICDCC3,ICDCC2)=0
  1. I $D(ICDOP(" 00.50")) S ICDCC3=1
  1. I $D(ICDOP(" 00.52")) I $D(ICDOP(" 00.53")) S ICDCC3=1
  1. I $D(ICDOP(" 37.70"))!($D(ICDOP(" 37.71")))!($D(ICDOP(" 37.73"))) D MORE Q
  1. I $D(ICDOP(" 37.72")) I $D(ICDOP(" 37.80"))!($D(ICDOP(" 37.83"))) S ICDCC3=1 Q
  1. I $D(ICDOP(" 37.74")) I $D(ICDOP(" 37.80"))!($D(ICDOP(" 37.81")))!($D(ICDOP(" 37.82")))!($D(ICDOP(" 37.83")))!($D(ICDOP(" 37.85")))!($D(ICDOP(" 37.86")))!($D(ICDOP(" 37.87"))) S ICDCC3=1 Q
  1. I $D(ICDOP(" 37.76")) I $D(ICDOP(" 37.80"))!($D(ICDOP(" 37.85")))!($D(ICDOP(" 37.86")))!($D(ICDOP(" 37.87"))) S ICDCC3=1 Q
  1. I $D(ICDOP(" 00.53")) I $D(ICDOP(" 37.70"))!($D(ICDOP(" 37.71")))!($D(ICDOP(" 37.72")))!($D(ICDOP(" 37.73")))!($D(ICDOP("37.74 ")))!($D(ICDOP(" 37.76"))) S ICDCC3=1
  1. I $D(ICDOP(" 00.54"))!$D(ICDOP(" 37.95"))!$D(ICDOP(" 37.96"))!$D(ICDOP(" 37.97"))!$D(ICDOP(" 37.98"))!$D(ICDOP(" 00.52")) S ICDCC2=1
  1. Q
  1. MORE I $D(ICDOP(" 37.80"))!($D(ICDOP(" 37.81")))!($D(ICDOP(" 37.82")))!($D(ICDOP(" 37.85")))!($D(ICDOP(" 37.86")))!($D(ICDOP(" 37.87"))) S ICDCC3=1 Q
  1. Q
  1. VALV ;valve procedure
  1. N ICDTMP
  1. S (ICDCATH,ICDAJ)="" F ICDI=1:1 Q:'$D(ICDPRC(ICDI)) S ICDAJ=ICDPRC(ICDI),ICDTMP=$$ICDOP^ICDEX(+ICDAJ,$G(ICDDATE),2,"I"),$P(ICDTMP,"^",3)=$TR($P(ICDTMP,"^",3),";",""),ICDY(0)=$S((ICDTMP>0&$P(ICDTMP,U,10)):$P(ICDTMP,U,2,99),1:0) I ICDY(0) D
  1. . S ICDOP($P(ICDY(0),"^",1))="",ICDCATH=ICDCATH_$P(ICDY(0),"^",2)
  1. S ICDE1=$S($D(ICDOP(37.95))&($D(ICDOP(37.96))):1,1:0),ICDE2=$S($D(ICDOP(37.97))&($D(ICDOP(37.98))):1,1:0)
  1. Q
  1. S:ICDCATH["H" ICDRG=$S(ICDCATH["N"&ICDE1:104,ICDCATH["N"&ICDE2:104,ICDCATH["O":104,1:ICDRG)
  1. S:ICDCATH'["H" ICDRG=$S(ICDCATH["N"&ICDE1:105,ICDCATH["N"&ICDE2:105,ICDCATH["O":105,1:ICDRG)
  1. K ICDCATH,ICDAJ,ICDE1,ICDE2,ICDI,ICDOP,ICDY Q
  1. VALV1 ;dx combo's for DRG120
  1. S ICDE1=$S($D(ICDOP(" 37.95"))&($D(ICDOP(" 37.96"))):1,1:0),ICDE2=$S($D(ICDOP(" 37.97"))&($D(ICDOP(" 37.98"))):1,1:0)
  1. S ICDRG=$S((ICDE1&(ICDOR["H")):104,(ICDE1&(ICDOR'["H")):105,(ICDE2&(ICDOR["H")):104,(ICDE2&(ICDOR'["H")):105,1:120)
  1. K ICDE1,ICDE2
  1. Q