source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTBL6.m

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

initial load of FOIAVistA 6/30/08 version

File size: 2.2 KB
Line 
1ICDTBL6 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 10/16/07 9:40am
2 ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7
3DRG600 ;
4DRG601 S ICDRG=$S(ICDMCC>0:600,1:601) Q
5DRG602 ;
6DRG603 S ICDRG=$S(ICDMCC=2:602,1:603) Q
7DRG604 ;
8DRG605 S ICDRG=$S(ICDMCC=2:604,1:605) Q
9DRG606 ;
10DRG607 S ICDRG=$S(ICDMCC=2:606,1:607) Q
11DRG614 ;
12DRG615 S ICDRG=$S(ICDMCC>0:614,1:615) Q
13DRG616 ;
14DRG617 ;
15DRG618 S ICDRG=$S(ICDMCC=2:616,ICDMCC=1:617,1:618) Q
16DRG619 ;
17DRG620 ;
18DRG621 S ICDRG=$S(ICDMCC=2:619,ICDMCC=1:620,1:621) Q
19DRG622 ;
20DRG623 ;
21DRG624 S ICDRG=$S(ICDMCC=2:622,ICDMCC=1:623,1:624) Q
22DRG625 ;
23DRG626 ;
24DRG627 S ICDRG=$S(ICDMCC=2:625,ICDMCC=1:626,1:627) Q
25DRG628 ;
26DRG629 ;
27DRG630 S ICDRG=$S(ICDMCC=2:628,ICDMCC=1:629,1:630) Q
28DRG637 ;
29DRG638 ;
30DRG639 S ICDRG=$S(ICDMCC=2:637,ICDMCC=1:638,1:639) Q
31DRG640 ;
32DRG641 S ICDRG=$S(ICDMCC=2:640,1:641) Q
33DRG642 S ICDRG=642 Q
34DRG643 ;
35DRG644 ;
36DRG645 S ICDRG=$S(ICDMCC=2:643,ICDMCC=1:644,1:645) Q
37DRG652 S ICDRG=652 Q
38DRG653 ;
39DRG654 ;
40DRG655 S ICDRG=$S(ICDMCC=2:653,ICDMCC=1:654,1:655) Q
41DRG656 ;DRGs 656-661
42 S ICDRG=999
43 S ICDRG=$S(ICDPD["M"&(ICDMCC=2):656,ICDPD["M"&(ICDMCC=1):657,ICDPD["M":658,1:ICDRG)
44 I "656^657^658"[ICDRG Q
45 S ICDRG=$S(ICDRG'["M"&(ICDMCC=2):659,ICDPD'["M"&(ICDMCC=1):660,1:661)
46 Q
47DRG657 D DRG656 Q
48DRG658 D DRG656 Q
49DRG659 D DRG656 Q
50DRG660 D DRG656 Q
51DRG661 D DRG656 Q
52DRG662 ;
53DRG663 ;
54DRG664 S ICDRG=$S(ICDMCC=2:662,ICDMCC=1:663,1:664) Q
55DRG665 ;
56DRG666 ;
57DRG667 S ICDRG=$S(ICDMCC=2:665,ICDMCC=1:666,1:667) Q
58DRG668 ;
59DRG669 ;
60DRG670 S ICDRG=$S(ICDMCC=2:668,ICDMCC=1:669,1:670) Q
61DRG671 ;
62DRG672 S ICDRG=$S(ICDMCC>0:671,1:672) Q
63DRG673 ;
64DRG674 ;
65DRG675 S ICDRG=$S(ICDMCC=2:673,ICDMCC=1:674,1:675) Q
66DRG682 ;
67DRG683 ;
68DRG684 S ICDRG=$S(ICDMCC=2:682,ICDMCC=1:683,1:684) Q
69DRG685 S ICDRG=685 Q
70DRG686 ;
71DRG687 ;
72DRG688 S ICDRG=$S(ICDMCC=2:686,ICDMCC=1:687,1:688) Q
73DRG689 ;
74DRG690 S ICDRG=$S(ICDMCC=2:689,1:690) Q
75DRG691 ;DRGs 691-694
76 S ICDRG=999
77 S ICDRG=$S('$D(ICDPDRG(691)):"",$D(ICDOP(" 98.51"))&(ICDMCC>0):691,$D(ICDOP(" 98.51")):692,1:ICDRG)
78 I "691^692"[ICDRG Q
79 S ICDRG=$S('$D(ICDPDRG(691)):"",ICDMCC=2:693,1:694)
80 Q
81DRG692 D DRG691 Q
82DRG693 D DRG691 Q
83DRG694 D DRG691 Q
84DRG695 ;
85DRG696 S ICDRG=$S(ICDMCC=2:695,1:696) Q
86DRG697 S ICDRG=697 Q
87DRG698 ;
88DRG699 S ICDRG=$S(ICDMCC=2:698,ICDMCC=1:699,1:700) Q
89 Q
Note: See TracBrowser for help on using the repository browser.