source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U47.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1EC725U47 ;ALB/GTS/JAP/GT - EC National Procedure Update; 06/05/2007
2 ;;2.0; EVENT CAPTURE ;**93**;8 May 96;Build 1
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 ;;CH001^10/01/07
38 ;;CH002^10/01/07
39 ;;CH003^10/01/07
40 ;;CH004^10/01/07
41 ;;CH005^10/01/07
42 ;;CH006^10/01/07
43 ;;CH007^10/01/07
44 ;;CH008^10/01/07
45 ;;CH009^10/01/07
46 ;;CH010^10/01/07
47 ;;CH011^10/01/07
48 ;;CH012^10/01/07
49 ;;CH013^10/01/07
50 ;;CH014^10/01/07
51 ;;CH015^10/01/07
52 ;;CH017^10/01/07
53 ;;CH018^10/01/07
54 ;;CH019^10/01/07
55 ;;CH020^10/01/07
56 ;;CH021^10/01/07
57 ;;CH022^10/01/07
58 ;;CH023^10/01/07
59 ;;CH024^10/01/07
60 ;;CH025^10/01/07
61 ;;CH026^10/01/07
62 ;;CH027^10/01/07
63 ;;CH028^10/01/07
64 ;;CH029^10/01/07
65 ;;CH030^10/01/07
66 ;;CH031^10/01/07
67 ;;CH032^10/01/07
68 ;;CH033^10/01/07
69 ;;CH034^10/01/07
70 ;;CH035^10/01/07
71 ;;CH036^10/01/07
72 ;;CH037^10/01/07
73 ;;CH038^10/01/07
74 ;;CH039^10/01/07
75 ;;CH040^10/01/07
76 ;;CH041^10/01/07
77 ;;CH042^10/01/07
78 ;;CH043^10/01/07
79 ;;CH044^10/01/07
80 ;;CH045^10/01/07
81 ;;CH046^10/01/07
82 ;;CH047^10/01/07
83 ;;CH048^10/01/07
84 ;;CH049^10/01/07
85 ;;CH050^10/01/07
86 ;;CH051^10/01/07
87 ;;CH052^10/01/07
88 ;;CH053^10/01/07
89 ;;CH054^10/01/07
90 ;;CH055^10/01/07
91 ;;CH056^10/01/07
92 ;;CH057^10/01/07
93 ;;CH058^10/01/07
94 ;;CH059^10/01/07
95 ;;CH060^10/01/07
96 ;;CH061^10/01/07
97 ;;CH062^10/01/07
98 ;;CH063^10/01/07
99 ;;CH064^10/01/07
100 ;;CH065^10/01/07
101 ;;CH066^10/01/07
102 ;;CH067^10/01/07
103 ;;CH068^10/01/07
104 ;;CH069^10/01/07
105 ;;CH070^10/01/07
106 ;;CH071^10/01/07
107 ;;CH073^10/01/07
108 ;;CH074^10/01/07
109 ;;CH075^10/01/07
110 ;;CH076^10/01/07
111 ;;CH077^10/01/07
112 ;;CH078^10/01/07
113 ;;CH079^10/01/07
114 ;;CH080^10/01/07
115 ;;CH081^10/01/07
116 ;;CH082^10/01/07
117 ;;CH083^10/01/07
118 ;;CH084^10/01/07
119 ;;CH088^10/01/07
120 ;;CH089^10/01/07
121 ;;CH090^10/01/07
122 ;;CH091^10/01/07
123 ;;CH092^10/01/07
124 ;;CH093^10/01/07
125 ;;CH094^10/01/07
126 ;;CH095^10/01/07
127 ;;QUIT
128 ;
129REACT ;* reactivate national procedures
130 ;
131 ; ECXX is in format:
132 ; NATIONAL NUMBER^DATE (FUTURE)^FIRST NATIONAL NUMBER SEQUENCE^
133 ; LAST NATIONAL NUMBER SEQUENCE
134 ;
135 N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
136 N ECSEQ,CODE,CODX,ECDES
137 D MES^XPDUTL(" ")
138 D BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")
139 D MES^XPDUTL(" ")
140 F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
141 .S ECDES=$P(ECXX,U,5)
142 .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
143 .I ECBEG="" D UPREACT Q
144 .F ECSEQ=ECBEG:1:ECEND D
145 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
146 ..S CODE=CODX_ECADD
147 ..D UPREACT
148 Q
149UPREACT ;Update codes as reactive
150 ;
151 S ECDA=+$O(^EC(725,"D",CODE,0))
152 I $D(^EC(725,ECDA,0)) D
153 .S DA=ECDA,DR="2///@",DIE="^EC(725," D ^DIE
154 .D BMES^XPDUTL(" "_CODE_" "_ECDES_" reactivated.")
155 Q
156 ;
157ACT ;national procedures to be reactivated - national number^date
158 ;;QUIT
159 ;
160CPTCHG ;* change cpt codes
161 ;
162 ; ECXX is in format:
163 ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
164 ; NUMBER SEQUENCE
165 ;
166 N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,STR,CPTIEN
167 D MES^XPDUTL(" ")
168 D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
169 D MES^XPDUTL(" ")
170 F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" D
171 .S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CPTIEN=$P(ECXX,U,2)
172 .S CPTIEN=$S(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))
173 .I CPTIEN'="@",+CPTIEN<1 D Q
174 ..S STR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
175 ..D MES^XPDUTL(" ")
176 ..D BMES^XPDUTL(" "_STR)
177 .I ECBEG="" S CPT($P(ECXX,U))=CPTIEN_U_$P(ECXX,U,2) Q
178 .F ECSEQ=ECBEG:1:ECEND D
179 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
180 ..S CPT($P(ECXX,U)_ECADD)=CPTIEN_U_$P(ECXX,U,2)
181 S ECXX=""
182 F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
183 .S ECX=$O(^EC(725,"D",ECXX,0))
184 .Q:+ECX=0
185 .I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
186 ..D MES^XPDUTL(" ")
187 ..D BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT cde not updated.")
188 .S CPT=$P(CPT(ECXX),U),DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
189 .D MES^XPDUTL(" ")
190 .S STR=" Entry #"_ECX_" for "_ECXX
191 .D BMES^XPDUTL(STR_" updated to use CPT code "_$P(CPT(ECXX),U,2))
192 Q
193 ;
194CPT ;cpt codes to be changed - national #^new CPT code
195 ;;QUIT
Note: See TracBrowser for help on using the repository browser.