source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U39.m

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

initial load of WorldVistAEHR
File size: 6.3 KB
Line 
1EC725U39 ;ALB/GTS/JAP/GT - EC National Procedure Update; 1/31/2006
2 ;;2.0; EVENT CAPTURE ;**80**;8 May 96
3 ;
4 ;this routine is used as a post-init in KIDS build
5 ;to modify the the EC National Procedure file #725
6 ;
7INACT ;* inactivate national procedures
8 ;
9 ; ECXX is in format:
10 ; NATIONAL NUMBER^INACTIVATION DATE^FIRST NATIONAL NUMBER SEQUENCE^
11 ; LAST NATIONAL NUMBER SEQUENCE
12 ;
13 N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
14 N ECSEQ,CODE,CODX
15 D MES^XPDUTL(" ")
16 D BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
17 D MES^XPDUTL(" ")
18 F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT" D
19 .S ECEXDT=$P(ECXX,U,2),X=ECEXDT,%DT="X" D ^%DT S ECINDT=$P(Y,".",1)
20 .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
21 .I ECBEG="" D UPINACT Q
22 .F ECSEQ=ECBEG:1:ECEND D
23 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
24 ..S CODE=CODX_ECADD
25 ..D UPINACT
26 Q
27UPINACT ;Update codes as inactive
28 ;
29 S ECDA=+$O(^EC(725,"D",CODE,0))
30 I $D(^EC(725,ECDA,0)) D
31 .S DA=ECDA,DR="2////^S X=ECINDT",DIE="^EC(725," D ^DIE
32 .D MES^XPDUTL(" ")
33 .D BMES^XPDUTL(" "_CODE_" inactivated as of "_ECEXDT_".")
34 Q
35 ;
36OLD ;national procedures to be inactivated - national code #^inact. date
37 ;;NU029^1/01/2006
38 ;;NU030^1/01/2006
39 ;;NU031^1/01/2006
40 ;;NU032^1/01/2006
41 ;;NU037^1/01/2006
42 ;;NU038^1/01/2006
43 ;;NU039^1/01/2006
44 ;;NU040^1/01/2006
45 ;;NU048^1/01/2006
46 ;;NU049^1/01/2006
47 ;;NU050^1/01/2006
48 ;;NU051^1/01/2006
49 ;;NU056^1/01/2006
50 ;;NU057^1/01/2006
51 ;;NU058^1/01/2006
52 ;;NU059^1/01/2006
53 ;;NU064^1/01/2006
54 ;;NU065^1/01/2006
55 ;;NU066^1/01/2006
56 ;;NU067^1/01/2006
57 ;;NU073^1/01/2006
58 ;;NU074^1/01/2006
59 ;;NU075^1/01/2006
60 ;;NU076^1/01/2006
61 ;;NU081^1/01/2006
62 ;;NU082^1/01/2006
63 ;;NU083^1/01/2006
64 ;;NU084^1/01/2006
65 ;;NU089^1/01/2006
66 ;;NU090^1/01/2006
67 ;;NU091^1/01/2006
68 ;;NU092^1/01/2006
69 ;;NU097^1/01/2006
70 ;;NU098^1/01/2006
71 ;;NU099^1/01/2006
72 ;;NU100^1/01/2006
73 ;;NU105^1/01/2006
74 ;;NU106^1/01/2006
75 ;;NU107^1/01/2006
76 ;;NU108^1/01/2006
77 ;;NU113^1/01/2006
78 ;;NU114^1/01/2006
79 ;;NU115^1/01/2006
80 ;;NU116^1/01/2006
81 ;;NU121^1/01/2006
82 ;;NU122^1/01/2006
83 ;;NU123^1/01/2006
84 ;;NU124^1/01/2006
85 ;;NU129^1/01/2006
86 ;;NU130^1/01/2006
87 ;;NU131^1/01/2006
88 ;;NU132^1/01/2006
89 ;;NU137^1/01/2006
90 ;;NU138^1/01/2006
91 ;;NU139^1/01/2006
92 ;;NU140^1/01/2006
93 ;;NU145^1/01/2006
94 ;;NU146^1/01/2006
95 ;;NU147^1/01/2006
96 ;;NU148^1/01/2006
97 ;;SP266^1/01/2006
98 ;;SP267^1/01/2006
99 ;;SP268^1/01/2006
100 ;;SP269^1/01/2006
101 ;;SP271^1/01/2006
102 ;;SP272^1/01/2006
103 ;;SP273^1/01/2006
104 ;;SP274^1/01/2006
105 ;;SP275^1/01/2006
106 ;;SP276^1/01/2006
107 ;;SP279^1/01/2006
108 ;;SP280^1/01/2006
109 ;;SP281^1/01/2006
110 ;;SP282^1/01/2006
111 ;;SP283^1/01/2006
112 ;;SP284^1/01/2006
113 ;;SP285^1/01/2006
114 ;;SP286^1/01/2006
115 ;;SP287^1/01/2006
116 ;;SP288^1/01/2006
117 ;;SP291^1/01/2006
118 ;;SP292^1/01/2006
119 ;;SP293^1/01/2006
120 ;;SP294^1/01/2006
121 ;;SP295^1/01/2006
122 ;;SP296^1/01/2006
123 ;;SP297^1/01/2006
124 ;;SP298^1/01/2006
125 ;;SP299^1/01/2006
126 ;;SP300^1/01/2006
127 ;;SP301^1/01/2006
128 ;;SP302^1/01/2006
129 ;;SP303^1/01/2006
130 ;;SP304^1/01/2006
131 ;;SP305^1/01/2006
132 ;;SP306^1/01/2006
133 ;;SP307^1/01/2006
134 ;;SP308^1/01/2006
135 ;;SP309^1/01/2006
136 ;;SP310^1/01/2006
137 ;;SP311^1/01/2006
138 ;;SP312^1/01/2006
139 ;;SP316^1/01/2006
140 ;;SP319^1/01/2006
141 ;;SP320^1/01/2006
142 ;;SP321^1/01/2006
143 ;;SP322^1/01/2006
144 ;;SP323^1/01/2006
145 ;;SP324^1/01/2006
146 ;;SP325^1/01/2006
147 ;;SP326^1/01/2006
148 ;;SP327^1/01/2006
149 ;;SP328^1/01/2006
150 ;;SP329^1/01/2006
151 ;;SP330^1/01/2006
152 ;;SP331^1/01/2006
153 ;;SP332^1/01/2006
154 ;;SP333^1/01/2006
155 ;;SP334^1/01/2006
156 ;;SP335^1/01/2006
157 ;;SP336^1/01/2006
158 ;;SP337^1/01/2006
159 ;;SP338^1/01/2006
160 ;;SP339^1/01/2006
161 ;;SP340^1/01/2006
162 ;;SP341^1/01/2006
163 ;;SP342^1/01/2006
164 ;;SP343^1/01/2006
165 ;;SP344^1/01/2006
166 ;;SP345^1/01/2006
167 ;;SP346^1/01/2006
168 ;;SP347^1/01/2006
169 ;;SP440^1/01/2006
170 ;;SP441^1/01/2006
171 ;;SP479^1/01/2006
172 ;;SP480^1/01/2006
173 ;;SP482^1/01/2006
174 ;;SP483^1/01/2006
175 ;;SP489^1/01/2006
176 ;;SP490^1/01/2006
177 ;;SP492^1/01/2006
178 ;;SP493^1/01/2006
179 ;;SP495^1/01/2006
180 ;;SP496^1/01/2006
181 ;;QUIT
182 ;
183REACT ;* reactivate national procedures
184 ;
185 ; ECXX is in format:
186 ; NATIONAL NUMBER^DATE (FUTURE)^FIRST NATIONAL NUMBER SEQUENCE^
187 ; LAST NATIONAL NUMBER SEQUENCE
188 ;
189 N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
190 N ECSEQ,CODE,CODX,ECDES
191 D MES^XPDUTL(" ")
192 D BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")
193 D MES^XPDUTL(" ")
194 F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
195 .S ECDES=$P(ECXX,U,5)
196 .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
197 .I ECBEG="" D UPREACT Q
198 .F ECSEQ=ECBEG:1:ECEND D
199 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
200 ..S CODE=CODX_ECADD
201 ..D UPREACT
202 Q
203UPREACT ;Update codes as reactive
204 ;
205 S ECDA=+$O(^EC(725,"D",CODE,0))
206 I $D(^EC(725,ECDA,0)) D
207 .S DA=ECDA,DR="2///@",DIE="^EC(725," D ^DIE
208 .D BMES^XPDUTL(" "_CODE_" "_ECDES_" reactivated.")
209 Q
210 ;
211ACT ;national procedures to be reactivated - national number^date
212 ;;QUIT
213 ;
214CPTCHG ;* change cpt codes
215 ;
216 ; ECXX is in format:
217 ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
218 ; NUMBER SEQUENCE
219 ;
220 N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,STR,CPTIEN
221 D MES^XPDUTL(" ")
222 D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
223 D MES^XPDUTL(" ")
224 F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" D
225 .S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CPTIEN=$P(ECXX,U,2)
226 .S CPTIEN=$S(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))
227 .I CPTIEN'="@",+CPTIEN<1 D Q
228 ..S STR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
229 ..D MES^XPDUTL(" ")
230 ..D BMES^XPDUTL(" "_STR)
231 .I ECBEG="" S CPT($P(ECXX,U))=CPTIEN_U_$P(ECXX,U,2) Q
232 .F ECSEQ=ECBEG:1:ECEND D
233 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
234 ..S CPT($P(ECXX,U)_ECADD)=CPTIEN_U_$P(ECXX,U,2)
235 S ECXX=""
236 F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
237 .S ECX=$O(^EC(725,"D",ECXX,0))
238 .Q:+ECX=0
239 .I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
240 ..D MES^XPDUTL(" ")
241 ..D BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT cde not updated.")
242 .S CPT=$P(CPT(ECXX),U),DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
243 .D MES^XPDUTL(" ")
244 .S STR=" Entry #"_ECX_" for "_ECXX
245 .D BMES^XPDUTL(STR_" updated to use CPT code "_$P(CPT(ECXX),U,2))
246 Q
247 ;
248CPT ;cpt codes to be changed - national #^new CPT code
249 ;;SP038^97762
250 ;;SP107^97762
251 ;;SP108^97762
252 ;;SP350^92506
253 ;;SP449^97762
254 ;;SP450^97762
255 ;;SP451^97762
256 ;;SP467^97762
257 ;;QUIT
Note: See TracBrowser for help on using the repository browser.