source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD1831W.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: 4.2 KB
Line 
1ICD1831W ;;ALB/EG/JAT - FY 2008 UPDATE; 6/19/05 4:08pm ; 11/14/07 5:22pm
2 ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
3 ;
4 Q
5 ;
6PRO ;-update operation/procedure codes
7 ;
8 D BMES^XPDUTL(">>>Modifying op/pro codes - file 80.1")
9 N LINE,ICDPROC,ICDPROCS,PATT,TAG,TOT,ENTRY,MDC,MDCNM,IENS,IENS2,ICDIEN,VALUE,DRG,FDA,X,II,J,JJ,K,KK
10 ;MDC names
11 S J=0 F S J=$O(^ICM(J)) Q:'J S MDCNM(J)=$P(^ICM(J,0),U)
12 ;
13 ;PATTERN 1
14 K MDC S PATT=1,TOT=0,MDC(22)="927^928^929",MDC(24)="957^958^959"
15 D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
16 ;
17 ;PATTERN2
18 K MDC S PATT=2,TOT=0,MDC(5)="252^253^254",MDC(24)="957^958^959"
19 D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
20 ;
21 ;PATTERN3
22 K MDC S PATT=3,TOT=0,MDC(5)="252^253^254"
23 D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
24 ;
25 ;PATTERN4
26 K MDC S PATT=4,TOT=0,MDC(5)="264"
27 D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
28 ;
29 ;PATTERN5
30 K MDC S PATT=5,TOT=0,MDC(1)="040^041^042",MDC(24)="957^958^959"
31 D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
32 ;
33 ;PATTERN6
34 K MDC S PATT=6,TOT=0,MDC(1)="028^029^030",MDC(21)="907^908^909",MDC(24)="957^958^959"
35 D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
36 ;
37 ;PATTERN9
38 K MDC S PATT=9,TOT=0,MDC(24)="957^958^959"
39 D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
40 ;
41 ;PATTERN10
42 K MDC S PATT=10,TOT=0,MDC(22)="927^928^929"
43 D UPDATE(PATT,.MDC,.MDCNM,.TOT) S ^TMP($J,"ICD1831W",PATT)=TOT
44 ;
45 Q
46 ;
47UPDATE(PATT,MDC,MDCNM,TOT) ;
48 S TAG="PATT"_PATT
49 F LINE=1:1 S ICDPROCS=$T(@TAG+LINE^ICD1831W) S ICDPROCS=$P(ICDPROCS,";;",2) Q:ICDPROCS="END" D
50 .F J=1:1 S ICDPROC=$P(ICDPROCS,U,J) Q:ICDPROC="" D
51 ..S ENTRY=+$O(^ICD0("BA",ICDPROC_" ",0))
52 ..S K=$O(^ICD0(ENTRY,2,"B",3071001,0))
53 ..;quit if no fy08 data
54 ..Q:'K
55 ..S IENS=","_K_","_ENTRY_","
56 ..S JJ=0 F S JJ=$O(MDC(JJ)) Q:'JJ D
57 ...S VALUE=$G(MDCNM(JJ))
58 ...;quit if MDC already there
59 ...Q:($$FIND1^DIC(80.1711,IENS,"",VALUE))
60 ...;otherwise setup MDC subrecord
61 ...K ICDIEN
62 ...S FDA(801,80.1711,"+1"_IENS,.01)=VALUE
63 ...D UPDATE^DIE("E","FDA(801)","ICDIEN") K FDA(801)
64 ...;quit if not successful
65 ...S II=$O(ICDIEN(0))
66 ...Q:'II
67 ...S TOT=TOT+1
68 ...S IENS2=ICDIEN(II)_IENS
69 ...F KK=1:1 S DRG=+$P(MDC(JJ),U,KK) Q:'DRG S DRG="DRG"_DRG D
70 ....S FDA(801,80.17111,"+"_KK_","_IENS2,.01)=DRG
71 ....D UPDATE^DIE("E","FDA(801)") K FDA(801)
72 Q
73 ;
74PATT1 ;MDC22 & MDC24
75 ;;85.82^85.83^85.84^86.61^86.62^86.63^86.65^
76 ;;86.66^86.69^86.70^86.71^86.73^86.74^86.75^86.93^
77 ;;END
78 ;
79PATT2 ;MDC5 & MDC24
80 ;;38.32^38.33^38.38^38.42^38.43^38.48^
81 ;;38.62^38.63^38.66^38.68^38.7^38.82^38.86^38.88^39.29^39.31^39.41^
82 ;;39.42^39.49^39.56^39.57^39.58^39.59^39.91^39.99^
83 ;;04.92^38.00^38.10^38.30^38.40^38.60^38.80^39.30^
84 ;;END
85 ;
86PATT3 ;MDC5
87 ;;38.02^38.03^38.08^38.12^38.13^38.18^
88 ;;38.21^38.29^38.57^39.55^39.8^39.94^
89 ;;END
90 ;
91PATT4 ;MDC5
92 ;;05.24^
93 ;;END
94 ;
95PATT5 ;MDC1 & MDC24
96 ;;84.12^84.13^84.14^84.16^84.17^
97 ;;END
98 ;
99PATT6 ;MDC1 & MDC21 & MDC24
100 ;;81.01^81.02^81.03^81.04^81.05^81.06^81.07^81.08^
101 ;;81.31^81.21^81.33^81.34^81.35^81.36^81.37^81.38^
102 ;;END
103 ;
104PATT9 ;MDC24
105 ;;16.31^16.39^16.41^16.42^16.49^16.51^16.52^16.59^16.61^16.62^
106 ;;16.63^16.64^16.65^16.66^16.69.16.71^16.72^
107 ;;16.81^16.82^16.89^16.92^16.93^16.98^16.99^18.39^18.6^18.71^18.72^
108 ;;18.79^18.9^21.21^21.4^21.83^21.84^21.85^21.86^21.87^21.89^21.99^
109 ;;25.59^27.49^27.53^27.55^27.56^27.57^27.59^31.69^31.72^31.74^31.75^
110 ;;31.79^31.92^32.9^33.42^33.48^33.49^34.51^34.59^34.73^34.79^
111 ;;42.09^42.11^42.12^42.19^42.21^42.41^42.42^42.51^42.52^42.53^42.54^
112 ;;42.55^42.56^42.58^42.59^42.61^42.62^42.63^42.64^42.65^42.66^42.68^
113 ;;42.69^42.83^42.84^42.85^42.86^42.87^42.89^43.5^43.6^43.7^43.81^
114 ;;43.89^43.91^43.99^44.11^44.5^44.63^44.65^44.69^44.99^53.61^54.11^
115 ;;54.12^54.19^54.21^54.61^54.62^54.63^38.02^38.03^38.08^38.12^38.13^38.18^
116 ;;62.3^62.41^62.42^62.69^62.99^64.3^64.43^64.44^64.45^64.49^
117 ;;84.01^84.02^84.03^84.04^84.05^84.06^84.07^84.08^84.09^84.15^84.18^
118 ;;84.19^84.21^84.22^84.23^84.24^84.25^84.29^84.3^84.44^84.48^84.91^
119 ;;86.22^86.4^86.84^86.89^86.91^04.93^08.20^08.22^08.23^08.24^08.25^
120 ;;08.38^08.41^08.43^08.49^08.51^08.59^08.61^08.62^08.63^08.64^08.69^
121 ;;08.70^08.71^08.71^08.73^08.74^08.99^09.71^42.10^42.40^43.0^54.0^
122 ;;84.00^84.10^84.40^86.60^32.41^86.06^
123 ;;END
124 ;
125PATT10 ;MDC22
126 ;;86.72^
127 ;;END
Note: See TracBrowser for help on using the repository browser.