ICDDRG0 ;ALB/GRR/EG/ADL - DRG GROUPER PROCESSING BEGINS ; 11/13/07 4:06pm
;;18.0;DRG Grouper;**1,2,7,10,14,17,20,24,27,30,31,32,33,37,45,50,53,56,65,72,77,78**;Oct 20, 2000;Build 15
;GROUPING PROCESS BEGINS
;
GROUP ;
I $D(ICDSEX(1))&($D(ICDSEX(2))) S ICDRTC=4,ICDDRG=$S(ICDDATE>3070930.9:999,1:470) G KILL^ICDDRG
I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15 D:ICDOPCT<2 I ((ICDDATE'>3070930.9)&("468^476^477"[ICDRG))!((ICDDATE>3070930.9)&("983^986^989"[ICDRG)) G END
. I $D(ICDF) Q
. I ICDPD["M",ICDOR'["y" S ICDOPCT=0 Q
. I ICDDATE>3070930.9 D
. . I ICDOR["O",ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(769)),ICDORNI'["p" S ICDRG=$S($D(ICDORNI("O")):983,ICDORNI["y":986,ICDORNI["z":989,1:983) Q
. . I ICDOPNR S ICDRG=$S(ICDORNI["y":986,1:983),ICDOPNR=0 Q
. E D
. . I ICDOR["O",ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(377)),ICDORNI'["p" S ICDRG=$S($D(ICDORNI("O")):468,ICDORNI["y":476,ICDORNI["z":477,1:468) Q
. . I ICDOPNR S ICDRG=$S(ICDORNI["y":476,1:468),ICDOPNR=0 Q
;
;if number of non-extensive ORs eqs # OR, 477
;
I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI'["y"&(ICDORNI'="")&(ICDORNI["z") D I ((ICDDATE'>3070930.9)&(ICDRG=477))!((ICDDATE>3070930.9)&(ICDRG=989)) G END
. I $D(ICDF) Q
. NEW K S K=$$ORNI(ICDORNI) I K=ICDOPCT S ICDRG=$S(ICDDATE>3070930.9:989,1:477) Q
;
;if number of non-extensive ORs+prostatics eqs # OR, 476
;
I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI["y"&(ICDORNI'="") D I ((ICDDATE'>3070930.9)&(ICDRG=476))!((ICDDATE>3070930.9)&(ICDRG=986)) G END
.N K S K=$$ORNI(ICDORNI) I K=ICDOPCT&(ICDNOR=ICDONR) S ICDRG=$S(ICDDATE>3070930.9:986,1:476) Q
I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDNOR=ICDONR&(ICDOPCT>0) S ICDRG=$S(ICDDATE>3070930.9:983,1:468) G END
I ICDMDC=5,ICDOR'["O" S ICDRTC=$S(ICDEXP="":5,1:"") S:ICDRTC'="" ICDRG=$S(ICDDATE>3070930.9:999,1:470) D:ICDRTC="" MI G END
;I ICDMDC=18,ICDOR["O"!(ICDORNI["O") S ICDRG=415 G END ;;disabled by ICD*18*24 and new DRGs 578/579 - see ICDTLB6C
I ICDMDC=19,ICDOCNT>0,ICDOR["O" S (ICDRG,HICDRG)=$S(ICDDATE>3070930.9:876,1:424) D CKDRG
I ICDMDC=23,ICDOR["O"!(ICDORNI["O") S ICDRG=$S(ICDDATE>3070930.9:941,1:461) G END
I ICDMDC=14 D ^ICDDRG14 I ICDRG]"" G END
I ICDMDC=20 S ICDRTC=$S(ICDDMS="":7,1:"") I ICDDMS'=0 D G END
. I ICDDATE>3070930.9 S ICDRG=$S(ICDDMS="":999,1:894) Q
. S ICDRG=$S(ICDDMS="":470,1:433)
I ICDMDC=22 S ICDRTC=$S(ICDTRS="":6,1:"") S:ICDRTC'="" ICDRG=$S(ICDDATE>3070930.9:999,1:470) D:ICDRTC="" CKBURN G END
I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I ICDTRS'=0 D G END
. I ICDDATE>3070930.9 S ICDRG=$S(ICDRTC'="":999,1:789) Q
. S ICDRG=$S(ICDRTC'="":470,1:385)
NEONATE I 'ICDNOR!('$D(ICDODRG)) S ICDRG=$O(ICDPDRG(0)) X "I ICDMDC=15,$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG D NEONATF^ICDDRG0" D D DODRG G GETMOR:ICDRG="",END
. N X,X1,X2,%
. S X1=$S($G(DGADM):$G(DGADM),1:DT),X2=$G(DOB) I X1,X2 D ^%DTC I X<29 D NBCOMP Q
. I ICDDATE'>3070930.9 I ICDRG<385!(ICDRG>391) Q
. I ICDDATE>3070930.9 I ICDRG<789!(ICDRG>795) Q
.; I "^11917^11918^11921^"[("^"_ICDDX(1)_"^") S ICDRG=395 Q
. I ICDDATE'>3070930.9 I $O(ICDRG(391)) S ICDRG=$O(ICDRG(391)) Q
. I ICDDATE>3070930.9 I $O(ICDRG(795)) S ICDRG=$O(ICDRG(795)) Q
. I 'ICDRG S ICDRG=$S(ICDDATE>3070930.9:999,1:470),ICDRTC=8
I AGE="",ICDMDC=3 S ICDRTC=3 S ICDRG=$S(ICDDATE>3070930.9:999,1:470) G END
D ^ICDDRG1:ICDMDC=1,^ICDDRG2:ICDMDC=2,^ICDDRG3:ICDMDC=3,^ICDDRG5:ICDMDC=5,^ICDDRG6:ICDMDC=6,^ICDDRG7:ICDMDC=7,^ICDDRG8:ICDMDC=8,^ICDDRG9:ICDMDC=9,^ICDDRG10:ICDMDC=10,^ICDDRG11:ICDMDC=11,^ICDDRG12:ICDMDC=12,^ICDDRG13:ICDMDC=13
D ^ICDDRG17:ICDMDC=17
CONT G:ICDMDC=15 GETMOR S (ICDRG,HICDRG)=$O(ICDODRG(0)) G:ICDRG'>0 ENTER
D DODRG
G:ICDRG'>0 LOOK8:ICDMDC=8,AGAIN G END
ENTER I 'ICDNOR,ICDORNR'=0,ICDMDC'=20,ICDMDC'=15 S ICDRG=$S(ICDDATE>3070930.9:983,1:468) G END
GETMOR S (ICDRG,HICDRG)=$O(ICDPDRG(0)) S:ICDRG'>0 (ICDRG,HICDRG)=$S(ICDDATE>3070930.9:998,1:469)
CKDRG D DODRG
I ICDRG="" K ICDPDRG(HICDRG) G GETMOR
DODRG ;Go to DRG file and retrieve table entry to use if defined
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=3141001 ;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
I ICDOR["4"&(ICDDATE<3071001) D DRG232^ICDTLB3
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 ;
D:ICDP24'=""!($D(ICDS24)) CKMST^ICDDRGX S ICDDRG=ICDRG
;ICD*18*24 check for higher numbered DRG (such as new DRG 561) before checking for 489 in CKHIV^ICDDRGX
I ICDDATE<3071001 I ICDRG=489!(ICDRG=490)!(ICDRG=543&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=543 S ICDRG=561
I ICDDATE'<3071001 I ICDRG=976!(ICDRG=977)!(ICDRG=24&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=24 S ICDRG=99
D:$G(ICDP25)=1!(($G(ICDP25)>1)&($D(ICDS25(1)))) CKHIV^ICDDRGX S ICDDRG=ICDRG
; this will effectively make DRG 103 into a pre-MDC (ICD*18*1)
I $D(ICDOP(" 33.6"))!$D(ICDOP(" 37.5"))!(ICDDATE>3030930.9&($D(ICDOP(" 37.51"))!$D(ICDOP(" 37.66")))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG
I (ICDDATE>3050930.9)&($D(ICDOP(" 37.64")))&($D(ICDOP(" 37.65"))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG
I (ICDDATE>3060930.9)&($D(ICDOP(" 37.63")))&($D(ICDOP(" 37.64"))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG
I $D(ICDOP(" 39.65")) S ICDRG=$S(ICDDATE>3070930.9:3,1:541),ICDNMDC(1)=""
I (ICDDATE>3070930.9)&($D(ICDOP(" 46.97"))) S ICDRG=5,ICDNMDC(1)=""
; this will create DRGs 512/513 as pre-MDC
I $D(ICDOP(" 52.80"))!$D(ICDOP(" 52.82")) S ICDRG=$S(ICDDATE>3070930.9:10,1:513),ICDNMDC(1)=""
I (ICDDATE>3070930.9) D
. I ICDRG=10 I $D(ICDOP(" 55.69")) S ICDRG=8
E I ICDRG=513 I $D(ICDOP(" 55.69")) S ICDRG=512
; this will create DRG 481 as pre-MDC - loops thru 41.00 thru .09
N X S X=0 F S X=$O(ICDOP(X)) Q:X="" I X["41.0" S ICDRG=$S(ICDDATE>3070930.9&ICDDATE<3101001:9,ICDDATE>3100930.9:14,1:481),ICDNMDC(1)=""
I $D(ICDNMDC(1)) I ICDNMDC(1)="" D CKNMDC^ICDDRGX S ICDDRG=ICDRG K ICDNMDC
I $D(ICDOP(" 37.52"))&(ICDDATE>3070930.9)&(ICDDATE<3081001) D
.S ICDRG=215
.S ICDDRG=215 Q
I ICDDATE>3070930.9 D
. I ICDRG=983 D CHKMDC4^ICDDRGX
. D DODRG S ICDDRG=ICDRG ;check for MCC/CC
E I ICDRG=468 D CHKMDC4^ICDDRGX D DODRG S ICDDRG=ICDRG
S:ICDRTC="" ICDRTC=0
S ICDTMP=$$DRG^ICDGTDRG(ICDDRG,ICDDATE) I '$P(ICDTMP,U,14) S ICDDRG=$S(ICDDATE>3070930.9:999,1:470)
G KILL^ICDDRG
MI ;
; if PTCA and not a bypass
I ICDOR["1"!($D(ICDOP(" 37.90"))) I ICDOR'["b"&(ICDOR'["6") D Q
. I ICDDATE>3070930.9 D CMS516^ICDTBL2 Q
. E D DRG516^ICDTLB6B
I ICDPD["A" D EN1^ICDDRG5 I ICDCC3 S ICDRG=$O(ICDODRG(0)) D DODRG Q
I ICDPD["AI"!(ICDSD["AI") D Q
. I ICDDATE>3070930.9 D
. . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):285,ICDPD["V"!(ICDSD["V"):280,1:282)
. E D
. . I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=526 Q
. . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):123,ICDPD["s"!ICDPD["V"!(ICDSD["s")!(ICDSD["V"):121,1:122)
I $D(ICDOP(" 37.26"))&($D(ICDOP(" 39.61"))) S ICDRG=$S(ICDDATE>3070930.9:230,1:108) Q
;I $D(ICDOP(" 37.26")) S ICDRG=112 Q
I ICDDATE<3071001 I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=527 Q
I ICDDATE<3071001 I $D(ICDOP(" 36.06")) I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=517 Q
;I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=$S(ICDDATE>3070930.9:251,1:518) Q
I ICDOR["H" D Q
. I ICDDATE>3070930.9 S ICDRG=$S(ICDPD["X"!(ICDSD["X"):286,1:287) Q
. E S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q
I ICDDATE>3070930.9 K ICDPDRG(286),ICDPDRG(287)
E K ICDPDRG(124)
I ICDOR["p" S ICDRG=$O(ICDODRG(0)) D DODRG Q
I ICDOR["F" S ICDRG=$O(ICDODRG(0)) D DODRG Q
E D Q
. I ICDDATE>3070930.9 K ICDPDRG(280),ICDPDRG(281),ICDPDRG(282) S ICDRG=$O(ICDPDRG(0)) D DODRG Q
. E K ICDPDRG(121) S ICDRG=$O(ICDPDRG(0)) D DODRG Q
;
CKBURN ; MDC22 - Burns (extensive, full thickness, or non-extensive)
D
. I ICDPD["*"!(ICDSD["*") D Q
. . I ICDDATE>3070930.9,$D(ICDOP(" 96.72")) S ICDRG=$S(ICDOR["k":927,1:933) Q
. . E S ICDRG=$S(ICDOR["k":504,1:505) Q
. I ICDPD["b"!(ICDSD["b") D FTBURN Q
. I ICDDATE>3070930.9 S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):935,1:935)
. E S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):510,1:511)
Q
;
AGAIN G:'$D(ICDODRG) ENTER
K ICDODRG(HICDRG) I $O(ICDODRG(HICDRG))'>0 K ICDODRG G GROUP
S ICDRG=$O(ICDODRG(HICDRG)) G GROUP
;
;
LOOK8 G:'$D(ICDJ) GETMOR
S ICDJ=$O(ICDJ(0)) G:ICDJ'>0 GETMOR
K ICDJ(ICDJ),ICDODRG D END^ICDDRG8 G GETMOR:'$D(ICDODRG),CONT
Q
;
NBCOMP ; check for complication related to NB
I ICDSD'["J"!'$D(ICDSDRG) Q
N ICDSDXCK
S ICDSDXCK=$O(ICDSDRG(0))
I ICDDATE>3070930.9 D
. I ICDSDXCK<ICDRG,ICDSDXCK>788,ICDSDXCK<796 D
.. S ICDRG=$S($D(ICDPDRG(795)):795,$D(ICDPDRG(791)):791,1:$O(ICDSDRG(0)))
E D
. I ICDSDXCK<ICDRG,ICDSDXCK>384,ICDSDXCK<392 D
.. S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))
Q
;
FTBURN ; full thickness burn check
I ICDSD["j"!(ICDOR["k") D
. I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=$S(ICDDATE>3070930.9:928,1:506)
. E S ICDRG=$S(ICDDATE>3070930.9:929,1:507)
E D
. I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=$S(ICDDATE>3070930.9:934,1:508)
. E S ICDRG=$S(ICDDATE>3070930.9:934,1:509)
Q
;
NEONATF ;NEONATE - Continuation of xecute line
I ICDDATE>3070930.9 S ICDRG=$S($D(ICDPDRG(795)):795,$D(ICDPDRG(791)):791,1:$O(ICDSDRG(0))) Q
S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDDRG0 9876 printed Dec 13, 2024@01:50:07 Page 2
ICDDRG0 ;ALB/GRR/EG/ADL - DRG GROUPER PROCESSING BEGINS ; 11/13/07 4:06pm
+1 ;;18.0;DRG Grouper;**1,2,7,10,14,17,20,24,27,30,31,32,33,37,45,50,53,56,65,72,77,78**;Oct 20, 2000;Build 15
+2 ;GROUPING PROCESS BEGINS
+3 ;
GROUP ;
+1 IF $DATA(ICDSEX(1))&($DATA(ICDSEX(2)))
SET ICDRTC=4
SET ICDDRG=$SELECT(ICDDATE>3070930.9:999,1:470)
GOTO KILL^ICDDRG
+2 IF ICDMDC'=14
IF ICDMDC'=17
IF ICDMDC'=18
IF ICDMDC'=19
IF ICDMDC'=20
IF ICDMDC'=23
IF ICDMDC'=15
if ICDOPCT<2
Begin DoDot:1
+3 IF $DATA(ICDF)
QUIT
+4 IF ICDPD["M"
IF ICDOR'["y"
SET ICDOPCT=0
QUIT
+5 IF ICDDATE>3070930.9
Begin DoDot:2
+6 IF ICDOR["O"
IF ICDNOR=ICDONR
IF ICDNOR>0
IF '$DATA(ICDPDRG(769))
IF ICDORNI'["p"
SET ICDRG=$SELECT($DATA(ICDORNI("O")):983,ICDORNI["y":986,ICDORNI["z":989,1:983)
QUIT
+7 IF ICDOPNR
SET ICDRG=$SELECT(ICDORNI["y":986,1:983)
SET ICDOPNR=0
QUIT
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 IF ICDOR["O"
IF ICDNOR=ICDONR
IF ICDNOR>0
IF '$DATA(ICDPDRG(377))
IF ICDORNI'["p"
SET ICDRG=$SELECT($DATA(ICDORNI("O")):468,ICDORNI["y":476,ICDORNI["z":477,1:468)
QUIT
+10 IF ICDOPNR
SET ICDRG=$SELECT(ICDORNI["y":476,1:468)
SET ICDOPNR=0
QUIT
End DoDot:2
End DoDot:1
IF ((ICDDATE'>3070930.9)&("468^476^477"[ICDRG))!((ICDDATE>3070930.9)&("983^986^989"[ICDRG))
GOTO END
+11 ;
+12 ;if number of non-extensive ORs eqs # OR, 477
+13 ;
+14 IF ICDMDC'=14
IF ICDMDC'=17
IF ICDMDC'=18
IF ICDMDC'=19
IF ICDMDC'=20
IF ICDMDC'=23
IF ICDMDC'=15
IF ICDORNI'["y"&(ICDORNI'="")&(ICDORNI["z")
Begin DoDot:1
+15 IF $DATA(ICDF)
QUIT
+16 NEW K
SET K=$$ORNI(ICDORNI)
IF K=ICDOPCT
SET ICDRG=$SELECT(ICDDATE>3070930.9:989,1:477)
QUIT
End DoDot:1
IF ((ICDDATE'>3070930.9)&(ICDRG=477))!((ICDDATE>3070930.9)&(ICDRG=989))
GOTO END
+17 ;
+18 ;if number of non-extensive ORs+prostatics eqs # OR, 476
+19 ;
+20 IF ICDMDC'=14
IF ICDMDC'=17
IF ICDMDC'=18
IF ICDMDC'=19
IF ICDMDC'=20
IF ICDMDC'=23
IF ICDMDC'=15
IF ICDORNI["y"&(ICDORNI'="")
Begin DoDot:1
+21 NEW K
SET K=$$ORNI(ICDORNI)
IF K=ICDOPCT&(ICDNOR=ICDONR)
SET ICDRG=$SELECT(ICDDATE>3070930.9:986,1:476)
QUIT
End DoDot:1
IF ((ICDDATE'>3070930.9)&(ICDRG=476))!((ICDDATE>3070930.9)&(ICDRG=986))
GOTO END
+22 IF ICDMDC'=14
IF ICDMDC'=17
IF ICDMDC'=18
IF ICDMDC'=19
IF ICDMDC'=20
IF ICDMDC'=23
IF ICDMDC'=15
IF ICDNOR=ICDONR&(ICDOPCT>0)
SET ICDRG=$SELECT(ICDDATE>3070930.9:983,1:468)
GOTO END
+23 IF ICDMDC=5
IF ICDOR'["O"
SET ICDRTC=$SELECT(ICDEXP="":5,1:"")
if ICDRTC'=""
SET ICDRG=$SELECT(ICDDATE>3070930.9:999,1:470)
if ICDRTC=""
DO MI
GOTO END
+24 ;I ICDMDC=18,ICDOR["O"!(ICDORNI["O") S ICDRG=415 G END ;;disabled by ICD*18*24 and new DRGs 578/579 - see ICDTLB6C
+25 IF ICDMDC=19
IF ICDOCNT>0
IF ICDOR["O"
SET (ICDRG,HICDRG)=$SELECT(ICDDATE>3070930.9:876,1:424)
DO CKDRG
+26 IF ICDMDC=23
IF ICDOR["O"!(ICDORNI["O")
SET ICDRG=$SELECT(ICDDATE>3070930.9:941,1:461)
GOTO END
+27 IF ICDMDC=14
DO ^ICDDRG14
IF ICDRG]""
GOTO END
+28 IF ICDMDC=20
SET ICDRTC=$SELECT(ICDDMS="":7,1:"")
IF ICDDMS'=0
Begin DoDot:1
+29 IF ICDDATE>3070930.9
SET ICDRG=$SELECT(ICDDMS="":999,1:894)
QUIT
+30 SET ICDRG=$SELECT(ICDDMS="":470,1:433)
End DoDot:1
GOTO END
+31 IF ICDMDC=22
SET ICDRTC=$SELECT(ICDTRS="":6,1:"")
if ICDRTC'=""
SET ICDRG=$SELECT(ICDDATE>3070930.9:999,1:470)
if ICDRTC=""
DO CKBURN
GOTO END
+32 IF ICDMDC=15
SET ICDRTC=$SELECT(ICDEXP="":5,ICDTRS="":6,1:"")
IF ICDTRS'=0
Begin DoDot:1
+33 IF ICDDATE>3070930.9
SET ICDRG=$SELECT(ICDRTC'="":999,1:789)
QUIT
+34 SET ICDRG=$SELECT(ICDRTC'="":470,1:385)
End DoDot:1
GOTO END
NEONATE 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
+1 NEW X,X1,X2,%
+2 SET X1=$SELECT($GET(DGADM):$GET(DGADM),1:DT)
SET X2=$GET(DOB)
IF X1
IF X2
DO ^%DTC
IF X<29
DO NBCOMP
QUIT
+3 IF ICDDATE'>3070930.9
IF ICDRG<385!(ICDRG>391)
QUIT
+4 IF ICDDATE>3070930.9
IF ICDRG<789!(ICDRG>795)
QUIT
+5 ; I "^11917^11918^11921^"[("^"_ICDDX(1)_"^") S ICDRG=395 Q
+6 IF ICDDATE'>3070930.9
IF $ORDER(ICDRG(391))
SET ICDRG=$ORDER(ICDRG(391))
QUIT
+7 IF ICDDATE>3070930.9
IF $ORDER(ICDRG(795))
SET ICDRG=$ORDER(ICDRG(795))
QUIT
+8 IF 'ICDRG
SET ICDRG=$SELECT(ICDDATE>3070930.9:999,1:470)
SET ICDRTC=8
End DoDot:1
DO DODRG
if ICDRG=""
GOTO GETMOR
GOTO END
+9 IF AGE=""
IF ICDMDC=3
SET ICDRTC=3
SET ICDRG=$SELECT(ICDDATE>3070930.9:999,1:470)
GOTO END
+10 if ICDMDC=1
DO ^ICDDRG1
if ICDMDC=2
DO ^ICDDRG2
if ICDMDC=3
DO ^ICDDRG3
if ICDMDC=5
DO ^ICDDRG5
if ICDMDC=6
DO ^ICDDRG6
if ICDMDC=7
DO ^ICDDRG7
if ICDMDC=8
DO ^ICDDRG8
if ICDMDC=9
DO ^ICDDRG9
if ICDMDC=10
DO ^ICDDRG10
if ICDMDC=11
DO ^ICDDRG11
if ICDMDC=12
DO ^ICDDRG12
if ICDMDC=13
DO ^ICDDRG13
+11 if ICDMDC=17
DO ^ICDDRG17
CONT if ICDMDC=15
GOTO GETMOR
SET (ICDRG,HICDRG)=$ORDER(ICDODRG(0))
if ICDRG'>0
GOTO ENTER
+1 DO DODRG
+2 if ICDRG'>0
if ICDMDC=8
GOTO LOOK8
GOTO AGAIN
GOTO END
ENTER IF 'ICDNOR
IF ICDORNR'=0
IF ICDMDC'=20
IF ICDMDC'=15
SET ICDRG=$SELECT(ICDDATE>3070930.9:983,1:468)
GOTO END
GETMOR SET (ICDRG,HICDRG)=$ORDER(ICDPDRG(0))
if ICDRG'>0
SET (ICDRG,HICDRG)=$SELECT(ICDDATE>3070930.9:998,1:469)
CKDRG DO DODRG
+1 IF ICDRG=""
KILL ICDPDRG(HICDRG)
GOTO GETMOR
DODRG ;Go to DRG file and retrieve table entry to use if defined
+1 NEW ICDMCV,ICDMCV1,ICDMCV2
+2 NEW DRGFY,ICDREF
SET (DRGFY,ICDREF)=""
+3 IF ICDRG
SET DRGFY=$ORDER(^ICD(ICDRG,2,"B",$PIECE(+$GET(ICDDATE),".")_.01),-1)
+4 ;default to current fiscal year
IF 'DRGFY
SET DRGFY=3141001
+5 SET ICDREF=$ORDER(^ICD(+ICDRG,2,"B",+DRGFY,ICDREF))
+6 IF ICDREF'=""
Begin DoDot:1
+7 SET ICDREF=$PIECE($GET(^ICD(+ICDRG,2,ICDREF,0)),U,3)
+8 SET ICDREF="DRG"_ICDRG_"^"_ICDREF
DO @ICDREF
KILL ICDREF
End DoDot:1
+9 IF ICDOR["4"&(ICDDATE<3071001)
DO DRG232^ICDTLB3
+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 if ICDP24'=""!($DATA(ICDS24))
DO CKMST^ICDDRGX
SET ICDDRG=ICDRG
+2 ;ICD*18*24 check for higher numbered DRG (such as new DRG 561) before checking for 489 in CKHIV^ICDDRGX
+3 IF ICDDATE<3071001
IF ICDRG=489!(ICDRG=490)!(ICDRG=543&($GET(ICDOR)=""))
SET ICDRG=$PIECE($GET(ICDPDRG),U,2)
IF ICDRG=543
SET ICDRG=561
+4 IF ICDDATE'<3071001
IF ICDRG=976!(ICDRG=977)!(ICDRG=24&($GET(ICDOR)=""))
SET ICDRG=$PIECE($GET(ICDPDRG),U,2)
IF ICDRG=24
SET ICDRG=99
+5 if $GET(ICDP25)=1!(($GET(ICDP25)>1)&($DATA(ICDS25(1))))
DO CKHIV^ICDDRGX
SET ICDDRG=ICDRG
+6 ; this will effectively make DRG 103 into a pre-MDC (ICD*18*1)
+7 IF $DATA(ICDOP(" 33.6"))!$DATA(ICDOP(" 37.5"))!(ICDDATE>3030930.9&($DATA(ICDOP(" 37.51"))!$DATA(ICDOP(" 37.66"))))
SET ICDRG=$SELECT(ICDDATE>3070930.9:2,1:103)
SET ICDNMDC(1)=""
DO DODRG
+8 IF (ICDDATE>3050930.9)&($DATA(ICDOP(" 37.64")))&($DATA(ICDOP(" 37.65")))
SET ICDRG=$SELECT(ICDDATE>3070930.9:2,1:103)
SET ICDNMDC(1)=""
DO DODRG
+9 IF (ICDDATE>3060930.9)&($DATA(ICDOP(" 37.63")))&($DATA(ICDOP(" 37.64")))
SET ICDRG=$SELECT(ICDDATE>3070930.9:2,1:103)
SET ICDNMDC(1)=""
DO DODRG
+10 IF $DATA(ICDOP(" 39.65"))
SET ICDRG=$SELECT(ICDDATE>3070930.9:3,1:541)
SET ICDNMDC(1)=""
+11 IF (ICDDATE>3070930.9)&($DATA(ICDOP(" 46.97")))
SET ICDRG=5
SET ICDNMDC(1)=""
+12 ; this will create DRGs 512/513 as pre-MDC
+13 IF $DATA(ICDOP(" 52.80"))!$DATA(ICDOP(" 52.82"))
SET ICDRG=$SELECT(ICDDATE>3070930.9:10,1:513)
SET ICDNMDC(1)=""
+14 IF (ICDDATE>3070930.9)
Begin DoDot:1
+15 IF ICDRG=10
IF $DATA(ICDOP(" 55.69"))
SET ICDRG=8
End DoDot:1
+16 IF '$TEST
IF ICDRG=513
IF $DATA(ICDOP(" 55.69"))
SET ICDRG=512
+17 ; this will create DRG 481 as pre-MDC - loops thru 41.00 thru .09
+18 NEW X
SET X=0
FOR
SET X=$ORDER(ICDOP(X))
if X=""
QUIT
IF X["41.0"
SET ICDRG=$SELECT(ICDDATE>3070930.9&ICDDATE<3101001:9,ICDDATE>3100930.9:14,1:481)
SET ICDNMDC(1)=""
+19 IF $DATA(ICDNMDC(1))
IF ICDNMDC(1)=""
DO CKNMDC^ICDDRGX
SET ICDDRG=ICDRG
KILL ICDNMDC
+20 IF $DATA(ICDOP(" 37.52"))&(ICDDATE>3070930.9)&(ICDDATE<3081001)
Begin DoDot:1
+21 SET ICDRG=215
+22 SET ICDDRG=215
QUIT
End DoDot:1
+23 IF ICDDATE>3070930.9
Begin DoDot:1
+24 IF ICDRG=983
DO CHKMDC4^ICDDRGX
+25 ;check for MCC/CC
DO DODRG
SET ICDDRG=ICDRG
End DoDot:1
+26 IF '$TEST
IF ICDRG=468
DO CHKMDC4^ICDDRGX
DO DODRG
SET ICDDRG=ICDRG
+27 if ICDRTC=""
SET ICDRTC=0
+28 SET ICDTMP=$$DRG^ICDGTDRG(ICDDRG,ICDDATE)
IF '$PIECE(ICDTMP,U,14)
SET ICDDRG=$SELECT(ICDDATE>3070930.9:999,1:470)
+29 GOTO KILL^ICDDRG
MI ;
+1 ; if PTCA and not a bypass
+2 IF ICDOR["1"!($DATA(ICDOP(" 37.90")))
IF ICDOR'["b"&(ICDOR'["6")
Begin DoDot:1
+3 IF ICDDATE>3070930.9
DO CMS516^ICDTBL2
QUIT
+4 IF '$TEST
DO DRG516^ICDTLB6B
End DoDot:1
QUIT
+5 IF ICDPD["A"
DO EN1^ICDDRG5
IF ICDCC3
SET ICDRG=$ORDER(ICDODRG(0))
DO DODRG
QUIT
+6 IF ICDPD["AI"!(ICDSD["AI")
Begin DoDot:1
+7 IF ICDDATE>3070930.9
Begin DoDot:2
+8 SET ICDRG=$SELECT($SELECT($DATA(ICDEXP):ICDEXP,1:0):285,ICDPD["V"!(ICDSD["V"):280,1:282)
End DoDot:2
+9 IF '$TEST
Begin DoDot:2
+10 IF $DATA(ICDOP(" 36.07"))
IF $DATA(ICDOP(" 37.26"))!($DATA(ICDOP(" 37.27")))
SET ICDRG=526
QUIT
+11 SET ICDRG=$SELECT($SELECT($DATA(ICDEXP):ICDEXP,1:0):123,ICDPD["s"!ICDPD["V"!(ICDSD["s")!(ICDSD["V"):121,1:122)
End DoDot:2
End DoDot:1
QUIT
+12 IF $DATA(ICDOP(" 37.26"))&($DATA(ICDOP(" 39.61")))
SET ICDRG=$SELECT(ICDDATE>3070930.9:230,1:108)
QUIT
+13 ;I $D(ICDOP(" 37.26")) S ICDRG=112 Q
+14 IF ICDDATE<3071001
IF $DATA(ICDOP(" 36.07"))
IF $DATA(ICDOP(" 37.26"))!($DATA(ICDOP(" 37.27")))
SET ICDRG=527
QUIT
+15 IF ICDDATE<3071001
IF $DATA(ICDOP(" 36.06"))
IF $DATA(ICDOP(" 37.26"))!$DATA(ICDOP(" 37.27"))
SET ICDRG=517
QUIT
+16 ;I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=$S(ICDDATE>3070930.9:251,1:518) Q
+17 IF ICDOR["H"
Begin DoDot:1
+18 IF ICDDATE>3070930.9
SET ICDRG=$SELECT(ICDPD["X"!(ICDSD["X"):286,1:287)
QUIT
+19 IF '$TEST
SET ICDRG=$SELECT(ICDPD["X"!(ICDSD["X"):124,1:125)
QUIT
End DoDot:1
QUIT
+20 IF ICDDATE>3070930.9
KILL ICDPDRG(286),ICDPDRG(287)
+21 IF '$TEST
KILL ICDPDRG(124)
+22 IF ICDOR["p"
SET ICDRG=$ORDER(ICDODRG(0))
DO DODRG
QUIT
+23 IF ICDOR["F"
SET ICDRG=$ORDER(ICDODRG(0))
DO DODRG
QUIT
+24 IF '$TEST
Begin DoDot:1
+25 IF ICDDATE>3070930.9
KILL ICDPDRG(280),ICDPDRG(281),ICDPDRG(282)
SET ICDRG=$ORDER(ICDPDRG(0))
DO DODRG
QUIT
+26 IF '$TEST
KILL ICDPDRG(121)
SET ICDRG=$ORDER(ICDPDRG(0))
DO DODRG
QUIT
End DoDot:1
QUIT
+27 ;
CKBURN ; MDC22 - Burns (extensive, full thickness, or non-extensive)
+1 Begin DoDot:1
+2 IF ICDPD["*"!(ICDSD["*")
Begin DoDot:2
+3 IF ICDDATE>3070930.9
IF $DATA(ICDOP(" 96.72"))
SET ICDRG=$SELECT(ICDOR["k":927,1:933)
QUIT
+4 IF '$TEST
SET ICDRG=$SELECT(ICDOR["k":504,1:505)
QUIT
End DoDot:2
QUIT
+5 IF ICDPD["b"!(ICDSD["b")
DO FTBURN
QUIT
+6 IF ICDDATE>3070930.9
SET ICDRG=$SELECT(ICDCC!(ICDPD["T")!(ICDSD["T"):935,1:935)
+7 IF '$TEST
SET ICDRG=$SELECT(ICDCC!(ICDPD["T")!(ICDSD["T"):510,1:511)
End DoDot:1
+8 QUIT
+9 ;
AGAIN if '$DATA(ICDODRG)
GOTO ENTER
+1 KILL ICDODRG(HICDRG)
IF $ORDER(ICDODRG(HICDRG))'>0
KILL ICDODRG
GOTO GROUP
+2 SET ICDRG=$ORDER(ICDODRG(HICDRG))
GOTO GROUP
+3 ;
+4 ;
LOOK8 if '$DATA(ICDJ)
GOTO GETMOR
+1 SET ICDJ=$ORDER(ICDJ(0))
if ICDJ'>0
GOTO GETMOR
+2 KILL ICDJ(ICDJ),ICDODRG
DO END^ICDDRG8
if '$DATA(ICDODRG)
GOTO GETMOR
GOTO CONT
+3 QUIT
+4 ;
NBCOMP ; check for complication related to NB
+1 IF ICDSD'["J"!'$DATA(ICDSDRG)
QUIT
+2 NEW ICDSDXCK
+3 SET ICDSDXCK=$ORDER(ICDSDRG(0))
+4 IF ICDDATE>3070930.9
Begin DoDot:1
+5 IF ICDSDXCK<ICDRG
IF ICDSDXCK>788
IF ICDSDXCK<796
Begin DoDot:2
+6 SET ICDRG=$SELECT($DATA(ICDPDRG(795)):795,$DATA(ICDPDRG(791)):791,1:$ORDER(ICDSDRG(0)))
End DoDot:2
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 IF ICDSDXCK<ICDRG
IF ICDSDXCK>384
IF ICDSDXCK<392
Begin DoDot:2
+9 SET ICDRG=$SELECT($DATA(ICDPDRG(391)):391,$DATA(ICDPDRG(387)):387,1:$ORDER(ICDSDRG(0)))
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
FTBURN ; full thickness burn check
+1 IF ICDSD["j"!(ICDOR["k")
Begin DoDot:1
+2 IF ICDCC!(ICDPD["T")!(ICDSD["T")
SET ICDRG=$SELECT(ICDDATE>3070930.9:928,1:506)
+3 IF '$TEST
SET ICDRG=$SELECT(ICDDATE>3070930.9:929,1:507)
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 IF ICDCC!(ICDPD["T")!(ICDSD["T")
SET ICDRG=$SELECT(ICDDATE>3070930.9:934,1:508)
+6 IF '$TEST
SET ICDRG=$SELECT(ICDDATE>3070930.9:934,1:509)
End DoDot:1
+7 QUIT
+8 ;
NEONATF ;NEONATE - Continuation of xecute line
+1 IF ICDDATE>3070930.9
SET ICDRG=$SELECT($DATA(ICDPDRG(795)):795,$DATA(ICDPDRG(791)):791,1:$ORDER(ICDSDRG(0)))
QUIT
+2 SET ICDRG=$SELECT($DATA(ICDPDRG(391)):391,$DATA(ICDPDRG(387)):387,1:$ORDER(ICDSDRG(0)))
+3 QUIT
