source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB1A.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1ICDTLB1A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 8/19/04 3:19pm ; 6/15/05 6:35pm
2 ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000
3DRG1 D DRG528 D:ICDRG'=528 DRG543^ICDTLB6A D:ICDRG'=543 DRG529
4 S ICDRG=$S(AGE<18:3,ICDRG=528:528,ICDRG=543:543,ICDRG=529:529,ICDRG=530:530,ICDCC:1,1:2) I AGE="" S ICDRTC=3,ICDRG=470
5 Q
6DRG2 D DRG1
7 Q
8DRG3 D DRG1
9 Q
10DRG7 S ICDRG=$S(ICDCC:7,1:8) Q
11DRG8 S ICDRG=$S(ICDCC:7,1:8) Q
12DRG10 S ICDRG=$S(ICDCC:10,1:11) Q
13DRG11 S ICDRG=$S(ICDCC:10,1:11) Q
14DRG16 S ICDRG=$S(ICDCC:16,1:17) Q
15DRG17 S ICDRG=$S(ICDCC:16,1:17) Q
16DRG18 S ICDRG=$S(ICDCC:18,1:19) Q
17DRG19 S ICDRG=$S(ICDCC:18,1:19) Q
18DRG24 S ICDRG=$S(AGE<18:26,ICDCC:24,1:25) I AGE="" S ICDRTC=3,ICDRG=470
19 Q
20DRG25 S ICDRG=$S(AGE<18:26,ICDCC:24,1:25) I AGE="" S ICDRTC=3,ICDRG=470
21 Q
22DRG26 S ICDRG=$S(AGE<18:26,ICDCC:24,1:25) I AGE="" S ICDRTC=3,ICDRG=470
23 Q
24DRG27 S ICDRG=$S(ICDPD[1!(ICDSD[1):27,AGE="":470,AGE<18:30,ICDCC:28,1:29),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
25DRG28 D DRG27 Q
26DRG29 D DRG27 Q
27DRG30 D DRG27 Q
28DRG31 S ICDRG=$S(AGE<18:33,ICDCC:31,1:32) I AGE="" S ICDRG=470,ICDRTC=3
29 Q
30DRG32 S ICDRG=$S(AGE<18:33,ICDCC:31,1:32) I AGE="" S ICDRG=470,ICDRTC=3
31 Q
32DRG33 S ICDRG=$S(AGE<18:33,ICDCC:31,1:32) I AGE="" S ICDRG=470,ICDRTC=3
33 Q
34DRG34 S ICDRG=$S(ICDCC:34,1:35) Q
35DRG35 S ICDRG=$S(ICDCC:34,1:35) Q
36DRG39 D VER^ICDDRG2 Q
37DRG40 S ICDRG=$S(AGE>17:40,1:41) I AGE="" S ICDRG=470,ICDRTC=3
38 Q
39DRG41 S ICDRG=$S(AGE>17:40,1:41) I AGE="" S ICDRG=470,ICDRTC=3
40 Q
41DRG46 S ICDRG=$S(AGE<18:48,ICDCC:46,1:47) I AGE="" S ICDRG=470,ICDRTC=3
42 Q
43DRG47 S ICDRG=$S(AGE<18:48,ICDCC:46,1:47) I AGE="" S ICDRG=470,ICDRTC=3
44 Q
45DRG48 S ICDRG=$S(AGE<18:48,ICDCC:46,1:47) I AGE="" S ICDRG=470,ICDRTC=3
46 Q
47DRG53 S ICDRG=$S(AGE>17:53,1:54) I AGE="" S ICDRG=470,ICDRTC=3
48 Q
49DRG54 S ICDRG=$S(AGE>17:53,1:54) I AGE="" S ICDRG=470,ICDRTC=3
50 Q
51DRG57 S ICDRG=$S((ICDOPCT>0)&($P(ICDY(0),U,1)="28.3"):$S(AGE>17:59,1:60),ICDOPCT>0:$S(AGE>17:57,1:58),AGE>17:59,1:60) I AGE="" S ICDRG=470,ICDRTC=3
52 Q
53DRG58 S ICDRG=$S(ICDOPCT>1:$S(AGE>17:57,1:58),AGE>17:59,1:60) I AGE="" S ICDRG=470,ICDRTC=3
54 Q
55DRG59 D EN1^ICDDRG3 I AGE="" S ICDRG=470,ICDRTC=3
56 Q
57DRG60 D EN1^ICDDRG3 I AGE="" S ICDRG=470,ICDRTC=3
58 Q
59DRG61 S ICDRG=$S(AGE>17:61,1:62) I AGE="" S ICDRG=470,ICDRTC=3
60 Q
61DRG62 S ICDRG=$S(AGE>17:61,1:62) I AGE="" S ICDRG=470,ICDRTC=3
62 Q
63DRG68 S ICDRG=$S(AGE<18:70,ICDCC:68,1:69) I AGE="" S ICDRG=470,ICDRTC=3
64 Q
65DRG69 S ICDRG=$S(AGE<18:70,ICDCC:68,1:69) I AGE="" S ICDRG=470,ICDRTC=3
66 Q
67DRG70 S ICDRG=$S(AGE<18:70,ICDCC:68,1:69) I AGE="" S ICDRG=470,ICDRTC=3
68 Q
69DRG73 S ICDRG=$S(AGE>17:73,1:74) I AGE="" S ICDRG=470,ICDRTC=3
70 Q
71DRG74 S ICDRG=$S(AGE>17:73,1:74) I AGE="" S ICDRG=470,ICDRTC=3
72 Q
73DRG75 S ICDRG=$S($D(ICDODRG(474)):474,1:ICDRG) Q
74DRG76 S ICDRG=$S($D(ICDODRG(474)):474,ICDCC:76,1:77) Q
75DRG77 S ICDRG=$S($D(ICDODRG(474)):474,ICDCC:76,1:77) Q
76DRG78 S ICDRG=$S(ICDPD["X"&(ICDOR["H"):124,ICDSD["X"&(ICDOR["H"):124,1:78) Q
77DRG79 S ICDRG=$S(AGE<18:81,ICDCC:79,1:80) I AGE="" S ICDRG=470,ICDRTC=3
78 Q
79DRG80 S ICDRG=$S(AGE<18:81,ICDCC:79,1:80) I AGE="" S ICDRG=470,ICDRTC=3
80 Q
81DRG81 S ICDRG=$S(AGE<18:81,ICDCC:79,1:80) I AGE="" S ICDRG=470,ICDRTC=3
82 Q
83DRG83 S ICDRG=$S(ICDCC:83,1:84) Q
84DRG84 S ICDRG=$S(ICDCC:83,1:84) Q
85DRG85 S ICDRG=$S(ICDCC:85,1:86) Q
86DRG86 S ICDRG=$S(ICDCC:85,1:86) Q
87DRG89 S ICDRG=$S(AGE<18:91,ICDCC:89,1:90) I AGE="" S ICDRG=470,ICDRTC=3
88 Q
89DRG90 S ICDRG=$S(AGE<18:91,ICDCC:89,1:90) I AGE="" S ICDRG=470,ICDRTC=3
90 Q
91DRG91 S ICDRG=$S(AGE<18:91,ICDCC:89,1:90) I AGE="" S ICDRG=470,ICDRTC=3
92 Q
93DRG92 S ICDRG=$S(ICDCC!($D(ICDSDRG(92))):92,1:93) Q
94DRG93 S ICDRG=$S(ICDCC:92,1:93) Q
95DRG94 S ICDRG=$S(ICDCC:94,1:95) Q
96DRG528 S ICDRG=$S((ICDPD["K")&(ICDOR["K"):528,1:ICDRG) Q
97DRG529 S ICDRG=$S((ICDOR["S")&(ICDCC):529,(ICDOR["S")&('ICDCC):530,1:ICDRG) Q
98DRG530 D DRG529 Q
Note: See TracBrowser for help on using the repository browser.