source: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG0.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 6.7 KB
Line 
1ICDDRG0 ;ALB/GRR/EG/ADL - DRG GROUPER PROCESSING BEGINS ; 5/16/05 9:05pm
2 ;;18.0;DRG Grouper;**1,2,7,10,14,17,20,24,27,30**;Oct 20, 2000;Build 5
3 ;GROUPING PROCESS BEGINS
4 ;
5GROUP ;
6 I $D(ICDSEX(1))&($D(ICDSEX(2))) S ICDRTC=4,ICDDRG=470 G KILL^ICDDRG
7 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15 D:ICDOPCT<2 I "468^476^477"[ICDRG G END
8 . ;I ICDPD["M",ICDOR'["a" S ICDPDRG(344)="",ICDOPCT=0
9 . I $D(ICDF) Q
10 . I ICDPD["M",ICDOR'["y" S ICDOPCT=0 Q
11 .I ICDORNI["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
12 .I ICDOPNR S ICDRG=$S(ICDORNI["y":476,1:468),ICDOPNR=0 Q
13 ;
14 ;if number of non-extensive ORs eqs # OR, 477
15 ;
16 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI'["y"&(ICDORNI'="")&(ICDORNI["z") D I ICDRG=477 G END
17 . I $D(ICDF) Q
18 . NEW K S K=$$ORNI(ICDORNI) I K=ICDOPCT S ICDRG=477 Q
19 ;
20 ;if number of non-extensive ORs+prostatics eqs # OR, 476
21 ;
22 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI["y"&(ICDORNI'="") D I ICDRG=476 G END
23 .N K S K=$$ORNI(ICDORNI) I K=ICDOPCT&(ICDNOR=ICDONR) S ICDRG=476 Q
24 I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDNOR=ICDONR&(ICDOPCT>0) S ICDRG=468 G END
25 I ICDMDC=5,ICDOR'["O" S ICDRTC=$S(ICDEXP="":5,1:"") S:ICDRTC'="" ICDRG=470 D:ICDRTC="" MI G END
26 ;I ICDMDC=18,ICDOR["O"!(ICDORNI["O") S ICDRG=415 G END ;;disabled by ICD*18*24 and new DRGs 578/579 - see ICDTLB6C
27 I ICDMDC=19,ICDOCNT>0,ICDOR["O" S (ICDRG,HICDRG)=424 D CKDRG
28 I ICDMDC=23,ICDOR["O"!(ICDORNI["O") S ICDRG=461 G END
29 I ICDMDC=14 D ^ICDDRG14 I ICDRG]"" G END
30 I ICDMDC=20 S ICDRTC=$S(ICDDMS="":7,1:"") I ICDDMS'=0 S ICDRG=$S(ICDDMS="":470,1:433) G END
31 I ICDMDC=22 S ICDRTC=$S(ICDTRS="":6,1:"") S:ICDRTC'="" ICDRG=470 D:ICDRTC="" CKBURN G END
32 I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I ICDTRS'=0 S ICDRG=$S(ICDRTC'="":470,1:385) G END
33NEONATE I 'ICDNOR!('$D(ICDODRG)) S ICDRG=$O(ICDPDRG(0)) X "I ICDMDC=15,$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))" D D DODRG G GETMOR:ICDRG="",END
34 . N X,X1,X2,%
35 . S X1=$S($G(DGADM):$G(DGADM),1:DT),X2=$G(DOB) I X1,X2 D ^%DTC I X<29 D NBCOMP Q
36 . I ICDRG<385!(ICDRG>391) Q
37 .; I "^11917^11918^11921^"[("^"_ICDDX(1)_"^") S ICDRG=395 Q
38 . I $O(ICDRG(391)) S ICDRG=$O(ICDRG(391)) Q
39 . I 'ICDRG S ICDRG=470,ICDRTC=8
40 I AGE="",ICDMDC=3 S ICDRTC=3,ICDRG=470 G END
41 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
42 D ^ICDDRG17:ICDMDC=17
43CONT G:ICDMDC=15 GETMOR S (ICDRG,HICDRG)=$O(ICDODRG(0)) G:ICDRG'>0 ENTER
44 D DODRG
45 G:ICDRG'>0 LOOK8:ICDMDC=8,AGAIN G END
46ENTER I 'ICDNOR,ICDORNR'=0,ICDMDC'=20,ICDMDC'=15 S ICDRG=468 G END
47GETMOR S (ICDRG,HICDRG)=$O(ICDPDRG(0)) S:ICDRG'>0 (ICDRG,HICDRG)=469 ;I ICDMDC=15,'$D(ICDODRG),$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG S (ICDRG,HICDRG)=$O(ICDSDRG(0))
48CKDRG D DODRG
49 I ICDRG="" K ICDPDRG(HICDRG) G GETMOR
50DODRG ;Go to DRG file and retrieve table entry to use if defined
51 N ICDMCV,ICDMCV1,ICDMCV2
52 N DRGFY,ICDREF S (DRGFY,ICDREF)=""
53 I ICDRG S DRGFY=$O(^ICD(ICDRG,2,"B",$P(+$G(ICDDATE),".")_.01),-1)
54 I 'DRGFY S DRGFY=3061001 ;default to current fiscal year
55 S ICDREF=$O(^ICD(+ICDRG,2,"B",+DRGFY,ICDREF))
56 I ICDREF'="" D
57 . S ICDREF=$P($G(^ICD(+ICDRG,2,ICDREF,0)),U,3)
58 . S ICDREF="DRG"_ICDRG_"^"_ICDREF D @ICDREF K ICDREF
59 I ICDOR["4" D DRG232^ICDTLB3
60 Q
61ORNI(X) ;
62 N I,K
63 S K=0 F I=1:1:$L(ICDORNI) I $E(ICDORNI,I,I)="z"!($E(ICDORNI,I,I)="y") S K=K+1
64 Q K
65END ;
66 D:ICDP24'=""!($D(ICDS24)) CKMST^ICDDRGX S ICDDRG=ICDRG
67 ;ICD*18*24 check for higher numbered DRG (such as new DRG 561) before checking for 489 in CKHIV^ICDDRGX
68 I ICDRG=489!(ICDRG=490)!(ICDRG=543&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=543 S ICDRG=561
69 D:$G(ICDP25)=1!(($G(ICDP25)>1)&($D(ICDS25(1)))) CKHIV^ICDDRGX S ICDDRG=ICDRG
70 ; this will effectively make DRG 103 into a pre-MDC (ICD*18*1)
71 I $D(ICDOP(" 33.6"))!$D(ICDOP(" 37.5"))!(ICDDATE>3030930.9&($D(ICDOP(" 37.51"))!$D(ICDOP(" 37.66")))) S ICDRG=103,ICDNMDC(1)=""
72 I (ICDDATE>3050930.9)&($D(ICDOP(" 37.64")))&($D(ICDOP(" 37.65"))) S ICDRG=103,ICDNMDC(1)=""
73 I (ICDDATE>3060930.9)&($D(ICDOP(" 37.63")))&($D(ICDOP(" 37.64"))) S ICDRG=103,ICDNMDC(1)=""
74 I $D(ICDOP(" 39.65")) S ICDRG=541,ICDNMDC(1)=""
75 ; this will create DRGs 512/513 as pre-MDC
76 I $D(ICDOP(" 52.80"))!$D(ICDOP(" 52.82")) S ICDRG=513,ICDNMDC(1)=""
77 I ICDRG=513 I $D(ICDOP(" 55.69")) S ICDRG=512
78 ; this will create DRG 481 as pre-MDC - loops thru 41.00 thru .09
79 N X S X=0 F S X=$O(ICDOP(X)) Q:X="" I X["41.0" S ICDRG=481,ICDNMDC(1)=""
80 I $D(ICDNMDC(1)) I ICDNMDC(1)="" D CKNMDC^ICDDRGX S ICDDRG=ICDRG K ICDNMDC
81 I ICDRG=468 D CHKMDC4^ICDDRGX D DODRG S ICDDRG=ICDRG
82 S:ICDRTC="" ICDRTC=0
83 S ICDTMP=$$DRG^ICDGTDRG(ICDDRG,ICDDATE) I '$P(ICDTMP,U,14) S ICDDRG=470
84 G KILL^ICDDRG
85MI ;
86 ; if PTCA and not a bypass
87 I ICDOR["1"!($D(ICDOP(" 37.90"))) I ICDOR'["b"&(ICDOR'["6") I ICDDATE>3050930.9 D DRG516^ICDTLB6B Q
88 I ICDPD["A" D EN1^ICDDRG5 I ICDCC3 S ICDRG=$O(ICDODRG(0)) D DODRG Q
89 I ICDPD["AI"!(ICDSD["AI") D Q
90 . I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=526 Q
91 . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):123,ICDPD["V"!(ICDSD["V"):121,1:122)
92 I $D(ICDOP(" 37.26"))&($D(ICDOP(" 39.61"))) S ICDRG=108 Q
93 ;I $D(ICDOP(" 37.26")) S ICDRG=112 Q
94 I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=527 Q
95 I $D(ICDOP(" 36.06")) I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=517 Q
96 I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=518 Q
97 I ICDOR["H" S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q
98 K ICDPDRG(124)
99 I ICDOR["p" S ICDRG=$O(ICDODRG(0)) D DODRG Q
100 I ICDOR["F" S ICDRG=$O(ICDODRG(0)) D DODRG Q
101 E K ICDPDRG(121) S ICDRG=$O(ICDPDRG(0)) D DODRG Q
102 ;
103CKBURN ; MDC22 - Burns (extensive, full thickness, or non-extensive)
104 D
105 . I ICDPD["*"!(ICDSD["*") S ICDRG=$S(ICDOR["k":504,1:505) Q
106 . I ICDPD["b"!(ICDSD["b") D FTBURN Q
107 . S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):510,1:511)
108 Q
109 ;
110AGAIN G:'$D(ICDODRG) ENTER
111 K ICDODRG(HICDRG) I $O(ICDODRG(HICDRG))'>0 K ICDODRG G GROUP
112 S ICDRG=$O(ICDODRG(HICDRG)) G GROUP
113 ;
114 ;
115LOOK8 G:'$D(ICDJ) GETMOR
116 S ICDJ=$O(ICDJ(0)) G:ICDJ'>0 GETMOR
117 K ICDJ(ICDJ),ICDODRG D END^ICDDRG8 G GETMOR:'$D(ICDODRG),CONT
118 Q
119 ;
120NBCOMP ; check for complication related to NB
121 I ICDSD'["J"!'$D(ICDSDRG) Q
122 N ICDSDXCK
123 S ICDSDXCK=$O(ICDSDRG(0))
124 I ICDSDXCK<ICDRG,ICDSDXCK>384,ICDSDXCK<392 D
125 . S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))
126 Q
127 ;
128FTBURN ; full thickness burn check
129 I ICDSD["j"!(ICDOR["k") D
130 . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=506
131 . E S ICDRG=507
132 E D
133 . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=508
134 . E S ICDRG=509
135 Q
Note: See TracBrowser for help on using the repository browser.