source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTBL7.m@ 808

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

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1ICDTBL7 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 11/13/07 3:47pm
2 ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7
3DRG700 S ICDRG=$S(ICDMCC=2:698,ICDMCC=1:699,1:700) Q
4DRG707 ;
5DRG708 S ICDRG=$S(ICDMCC>0:707,1:708) Q
6DRG709 ;
7DRG710 S ICDRG=$S(ICDMCC>0:709,1:710) Q
8DRG711 ;
9DRG712 S ICDRG=$S(ICDMCC>0:711,1:712) Q
10DRG713 ;
11DRG714 S ICDRG=$S(ICDMCC>0:713,1:714) Q
12DRG715 ;
13DRG716 I ICDPD["M" S ICDRG=$S(ICDMCC>0:715,1:716) Q
14DRG717 ;
15DRG718 I ICDPD["M" S ICDRG=$S(ICDMCC>0:715,1:716) Q
16 S ICDRG=$S(ICDMCC>0:717,1:718) Q
17DRG722 ;
18DRG723 ;
19DRG724 S ICDRG=$S(ICDMCC=2:722,ICDMCC=1:723,1:724) Q
20DRG725 ;
21DRG726 S ICDRG=$S(ICDMCC=2:725,1:726) Q
22DRG727 ;DRGs 727-728,757-759
23 S ICDRG=999
24 S ICDRG=$S(SEX="M":728,1:759) I SEX="" S ICDRG=999,ICDRTC=4 Q
25 I ICDRG=728 S ICDRG=$S(ICDMCC=2:727,1:728) Q
26 I ICDRG=759 S ICDRG=$S(ICDMCC=2:757,ICDMCC=1:758,1:759)
27 Q
28DRG728 D DRG727 Q
29DRG729 ;
30DRG730 S ICDRG=$S(ICDMCC>0:729,1:730) Q
31DRG734 ;
32DRG735 S ICDRG=$S(ICDMCC>0:734,1:735) Q
33DRG736 ;DRGs 736-743
34 S ICDRG=999
35 S ICDRG=$S(ICDPD["M":$S(ICDPD["o":738,ICDMCC=2:739,1:741),1:743)
36 I ICDRG=738 S ICDRG=$S(ICDMCC=2:736,ICDMCC=1:737,1:738) Q
37 I ICDRG=741 S ICDRG=$S(ICDMCC=1:740,1:741) Q
38 I ICDRG=743 S ICDRG=$S(ICDMCC>0:742,1:743)
39 Q
40DRG737 D DRG736 Q
41DRG738 D DRG736 Q
42DRG739 D DRG736 Q
43DRG740 D DRG736 Q
44DRG741 D DRG736 Q
45DRG742 D DRG736 Q
46DRG743 D DRG736 Q
47DRG744 ;
48DRG745 S ICDRG=$S(ICDMCC>0:744,1:745) Q
49DRG746 ;
50DRG747 S ICDRG=$S(ICDMCC>0:746,1:747) Q
51DRG748 S ICDRG=748 Q
52DRG749 ;
53DRG750 S ICDRG=$S(ICDMCC>0:749,1:750) Q
54DRG754 ;
55DRG755 ;
56DRG756 S ICDRG=$S(ICDMCC=2:754,ICDMCC=1:755,1:756) Q
57DRG757 D DRG727 Q
58DRG758 D DRG727 Q
59DRG759 D DRG727 Q
60DRG760 ;
61DRG761 S ICDRG=$S(ICDMCC>0:760,1:761) Q
62DRG765 ;
63DRG766 I ICDPD["D" S ICDRG=$S(ICDMCC>0:765,1:766) Q
64 S ICDRG=""
65DRG767 I ICDPD["D",ICDOR["s" S ICDRG=767 Q
66DRG768 I ICDPD["D" S ICDRG=768 Q
67 Q
68DRG769 S ICDRG=769 Q
69DRG770 S ICDRG=770 Q
70DRG774 ;
71 I ICDPD["v" S DRG=774 Q
72 I ICDPD'["v" Q
73 I ICDPD["v",ICDOR'["O" S DRG=774
74 D ONLY
75 N I,J S I="",J=0 F S I=$O(ICDOP(I)) Q:I']"" D
76 . I '$D(A(I)) S J=1
77 I J=0 S ICDRG=774 Q
78 Q
79DRG775 ;S ICDRG=775 Q
80 I ICDPD'["v" S DRG=775 Q
81 I ICDPD["v" Q
82 I ICDPD'["v",ICDOR'["O" S DRG=775
83 D ONLY
84 N I,J S I="",J=0 F S I=$O(ICDOP(I)) Q:I']"" D
85 . I '$D(A(I)) S J=1
86 I J=0 S ICDRG=775 Q
87 Q
88DRG776 S ICDRG=776 Q
89DRG777 S ICDRG=777 Q
90DRG778 S ICDRG=778 Q
91DRG779 S ICDRG=779
92 I $D(ICDOP(" 69.01")) S ICDRG=770 Q
93 I $D(ICDOP(" 69.02")) S ICDRG=770 Q
94 I $D(ICDOP(" 69.09")) S ICDRG=770 Q
95 I $D(ICDOP(" 69.51")) S ICDRG=770 Q
96 I $D(ICDOP(" 69.52")) S ICDRG=770 Q
97 I $D(ICDOP(" 74.91")) S ICDRG=770 Q
98 Q
99DRG780 S ICDRG=780 Q
100DRG781 I ICDPD["u"!(ICDSD["u") S ICDRG=781 Q
101DRG782 S ICDRG=782 Q
102DRG789 S ICDRG=789 Q
103DRG790 S ICDRG=790 Q
104DRG791 S ICDRG=791 Q
105DRG792 S ICDRG=792 Q
106DRG793 S ICDRG=793 Q
107DRG794 S ICDRG=794 Q
108DRG795 S ICDRG=795 Q
109DRG799 S ICDRG=$S(ICDMCC=2:799,ICDMCC=1:800,1:801) Q
110 Q
111ONLY ;this is a list of op for 774 and 775 to usee
112 N A
113 S A(" 48.71")=""
114 S A(" 49.59")=""
115 S A(" 67.51")=""
116 S A(" 67.59")=""
117 S A(" 67.61")=""
118 S A(" 67.69")=""
119 S A(" 70.13")=""
120 S A(" 70.14")=""
121 S A(" 70.24")=""
122 S A(" 70.31")=""
123 S A(" 70.33")=""
124 S A(" 70.71")=""
125 S A(" 70.79")=""
126 S A(" 71.01")=""
127 S A(" 71.09")=""
128 S A(" 71.11")=""
129 S A(" 77.19")=""
130 S A(" 71.3")=""
131 S A(" 71.71")=""
132 S A(" 71.79")=""
133 S A(" 73.99")=""
134 S A(" 75.50")=""
135 S A(" 75.51")=""
136 S A(" 75.61")=""
137 Q
Note: See TracBrowser for help on using the repository browser.