source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U34.m@ 812

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1EC725U34 ;ALB/GTS/JAP/GT - EC National Procedure Update; 6/29/2005
2 ;;2.0; EVENT CAPTURE ;**77**;8 May 96
3 ;
4 ;this routine is used as a post-init in a KIDS build
5 ;to modify the EC National Procedure file #725
6 ;
7ADDPROC ;* add national procedures
8 ;
9 ; ECXX is in format:
10 ; NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
11 ; LAST NATIONAL NUMBER SEQUENCE
12 ;
13 N ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
14 N ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
15 D MES^XPDUTL(" ")
16 D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
17 D MES^XPDUTL(" ")
18 S ECDINUM=$O(^EC(725,9999),-1),COUNT=$P(^EC(725,0),U,4)
19 F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
20 .S NAME=$P(ECXX,U,1),CODE=$P(ECXX,U,2),CPTN=$P(ECXX,U,3),CODX=CODE
21 .S CPT=""
22 .I CPTN'="" S CPT=$$FIND1^DIC(81,"","X",CPTN) I +CPT<1 D Q
23 ..S STR=" CPT code "_CPTN_" not a valid code in CPT File."
24 ..D MES^XPDUTL(" ")
25 ..D BMES^XPDUTL(" ["_CODE_"] "_STR)
26 .S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),NAMX=NAME
27 .I ECBEG="" S X=NAME D FILPROC Q
28 .F ECSEQ=ECBEG:1:ECEND D
29 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
30 ..;S NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
31 ..I $E(CODX,1,3)'="RCM" S NAME=NAMX_ECSEQ,X=NAME,CODE=CODX_ECADD
32 ..E S NAME=NAMX_$E(ECADD,2,99),X=NAME,CODE=CODX_$E(ECADD,2,99)
33 ..D FILPROC
34 S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
35 Q
36 ;
37FILPROC ;File national procedures
38 I '$D(^EC(725,"D",CODE)) D
39 .S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
40 .S DIC("DR")="1////^S X=CODE;4////^S X=CPT"
41 .D FILE^DICN
42 .I +Y>0 D
43 ..S COUNT=COUNT+1
44 ..D MES^XPDUTL(" ")
45 ..S STR=" Entry #"_+Y_" for "_$P(Y,U,2)
46 ..S STR=STR_$S(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
47 ..D BMES^XPDUTL(STR_" ...successfully added.")
48 .I Y=-1 D
49 ..D MES^XPDUTL(" ")
50 ..D BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
51 I $D(^EC(725,"DL",CODE)) D
52 .S LIEN=$O(^EC(725,"DL",CODE,""))
53 .D MES^XPDUTL(" ")
54 .D BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
55 .D BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
56 .D BMES^XPDUTL(" Please inactivate this local procedure.")
57 .K Y
58 Q
59NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
60 ;;HH RN SPVSN CTRCT ADLT DY CARE^HH133^99499
61 ;;HH DRIVE TIME (15MIN) MD^HH134
62 ;;HH DRIVE TIME (15MIN) RN^HH135
63 ;;HH DRIVE TIME (15MIN) NP^HH136
64 ;;HH DRIVE TIME (15MIN) SW^HH137
65 ;;HH DRIVE TIME (15MIN) DIET^HH138
66 ;;HH DRIVE TIME (15MIN) OT^HH139
67 ;;HH DRIVE TIME (15MIN) PT^HH140
68 ;;HH DRIVE TIME (15MIN) OTHER^HH141
69 ;;PT ED GP,10-13 PT,1ST 30M^NU096^S9446
70 ;;PT ED GP,14-17 PT,1ST 30M^NU097^S9446
71 ;;PT ED GP,18-20 PT,1ST 30M^NU098^S9446
72 ;;PT ED GP,21-25 PT,1ST 30M^NU099^S9446
73 ;;PT ED GP,>25 PT,1ST 30M^NU100^S9446
74 ;;SMOK CESS,2-3PT,1ST 30M^NU101^S9453
75 ;;SMOK CESS,4-6PT,1ST 30M^NU102^S9453
76 ;;SMOK CESS,7-9PT,1ST 30M^NU103^S9453
77 ;;SMOK CESS,10-13PT,1ST 30M^NU104^S9453
78 ;;SMOK CESS,14-17PT,1ST 30M^NU105^S9453
79 ;;SMOK CESS,18-20PT,1ST 30M^NU106^S9453
80 ;;SMOK CESS,21-25PT,1ST 30M^NU107^S9453
81 ;;SMOK CESS,>25PT,1ST 30M^NU108^S9453
82 ;;NUTR GP,2-3PT,EA AD'L 30M^NU109
83 ;;NUTR GP,4-6PT,EA AD'L 30M^NU110
84 ;;NUTR GP,7-9PT,EA AD'L 30M^NU111
85 ;;NUTR GP,10-13PT,EA AD'L 30M^NU112
86 ;;NUTR GP,14-17PT,EA AD'L 30M^NU113
87 ;;NUTR GP,18-20PT,EA AD'L 30M^NU114
88 ;;NUTR GP,21-25PT,EA AD'L 30M^NU115
89 ;;NUTR GP,>25PT,EA AD'L 30M^NU116
90 ;;WT MGT,2-3PT,EA AD'L 30M^NU117
91 ;;WT MGT,4-6PT,EA AD'L 30M^NU118
92 ;;WT MGT,7-9PT,EA AD'L 30M^NU119
93 ;;WT MGT,10-13PT,EA AD'L 30M^NU120
94 ;;WT MGT,14-17PT,EA AD'L 30M^NU121
95 ;;WT MGT18-20PT,EA AD'L 30M^NU122
96 ;;WT MGT,21-25PT,EA AD'L 30M^NU123
97 ;;WT MGT,>25PT,EA AD'L 30M^NU124
98 ;;DIAB MGT,2-3PT,EA AD'L30M^NU125
99 ;;DIAB MGT,4-6PT,EA AD'L30M^NU126
100 ;;DIAB MGT,7-9PT,EA AD'L30M^NU127
101 ;;DIAB MGT,10-13PT,EA AD'L30M^NU128
102 ;;DIAB MGT,14-17PT,EA AD'L30M^NU129
103 ;;DIAB MGT,18-20PT,EA AD'L30M^NU130
104 ;;DIAB MGT,21-25PT,EA AD'L30M^NU131
105 ;;DIAB MGT,>25PT,EA AD'L 30M^NU132
106 ;;PT ED GP,2-3PT,EA AD'L 30M^NU133
107 ;;PT ED GP,4-6PT,EA AD'L 30M^NU134
108 ;;PT ED GP,7-9PT,EA AD'L 30M^NU135
109 ;;PT ED GP,10-13PT,EA AD'L30M^NU136
110 ;;PT ED GP,14-17PT,EA AD'L30M^NU137
111 ;;PT ED GP,18-20PT,EA AD'L30M^NU138
112 ;;PT ED GP,21-25PT,EA AD'L30M^NU139
113 ;;PT ED GP,>25PT,EA AD'L 30M^NU140
114 ;;SMOK CESS,2-3PT,EA AD'L30M^NU141
115 ;;SMOK CESS,4-6PT,EA AD'L30M^NU142
116 ;;SMOK CESS,7-9PT,EA AD'L30M^NU143
117 ;;SMOK CESS,10-13PT,EA AD'L30M^NU144
118 ;;SMOK CESS,14-17PT,EA AD'L30M^NU145
119 ;;SMOK CESS,18-20PT,EA AD'L30M^NU146
120 ;;SMOK CESS,21-25PT,EA AD'L30M^NU147
121 ;;SMOK CESS,>25PT,EA AD'L30M^NU148
122 ;;PT EDUC IND, EA AD'L 15M^NU149
123 ;;DIAB MGT IND, EA AD'L15M^NU150
124 ;;NUTR CNSLG IND, EA AD'L15M^NU151
125 ;;DIAB MGT F/U, EA AD'L15M^NU152
126 ;;INSLN PMP INSTR,EA AD'L15M^NU153
127 ;;MED RECORD REVIEW,OPT,5M^NU154
128 ;;NON-NUTR INPT ED,EA 15M^NU155
129 ;;NUTR HBPC DRIVE TIME,EA 15M^NU156
130 ;;QUIT
131NAMECHG ;* change national procedure names
132 ;
133 ; ECXX is in format:
134 ; NATIONAL NUMBER^NEW NAME
135 ;
136 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,STR
137 D MES^XPDUTL(" ")
138 D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
139 D MES^XPDUTL(" ")
140 F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT" D
141 .I $D(^EC(725,"D",$P(ECXX,U,1))) D
142 ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
143 ..I $D(^EC(725,ECDA,0)) D
144 ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
145 ...D MES^XPDUTL(" ")
146 ...D MES^XPDUTL(" Entry #"_ECDA_" for "_$P(ECXX,U,1))
147 ...D BMES^XPDUTL(" ... field (#.01) updated to "_$P(ECXX,U,2)_".")
148 .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
149 ..D MES^XPDUTL(" ")
150 ..S STR="Can't find entry for "_$P(ECXX,U,1)
151 ..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
152 Q
153 ;
154CHNG ;name changes -national code #^new procedure name
155 ;;MH066^MH CWT/TWE <4 HR NFF
156 ;;MH067^MH CWT/TWE 4 to <8 HR NFF
157 ;;MH068^MH CWT/TWE 8 HRS/MORE NFF
158 ;;MH069^MH CWT/SE <4 HR NFF
159 ;;MH070^MH CWT/SE 4 to <8 HR NFF
160 ;;MH071^MH CWT/SE 8 HRS/MORE NFF
161 ;;PM504^PM CWT/TWE <4 HR NFF
162 ;;PM505^PM CWT/TWE 4 to <8 HR NFF
163 ;;PM506^PM CWT/TWE 8 HRS/MORE NFF
164 ;;PM507^PM CWT/SE <4 HR NFF
165 ;;PM508^PM CWT/SE 4 to <8 HR NFF
166 ;;PM509^PM CWT/SE 8 HRS/MORE NFF
167 ;;NU006^MED RECORD REVIEW,INPT,5M
168 ;;NU013^MENU ANLYS/MEAL PLN DEV,5M
169 ;;NU016^INTERDISC.CARE PLN MTG,3M
170 ;;NU019^PHONE-BRIEF-ON PT BEHALF
171 ;;NU020^PHONE-INTERM-ON PT BEHALF
172 ;;NU021^PHONE-LENGTH-ON PT BEHALF
173 ;;NU025^INTERDISC GP,2-3PT,EA15M
174 ;;NU026^INTERDISC GP,4-6PT,EA15M
175 ;;NU027^INTERDISC GP,7-9PT,EA15M
176 ;;NU028^INTERDISC GP,10-13PT,EA15M
177 ;;NU029^INTERDISC GP,14-17PT,EA15M
178 ;;NU030^INTERDISC GP,18-20PT,EA15M
179 ;;NU031^INTERDISC GP,21-25PT,EA15M
180 ;;NU032^INTERDISC GP,>25PT,EA15M
181 ;;NU033^IP NUTR ED GP,2-3PT,EA,30M
182 ;;NU034^IP NUTR ED GP,4-6PT,EA,30M
183 ;;NU035^IP NUTR ED GP,7-9PT,EA,30M
184 ;;NU036^IP NUTR ED GP,10-13PT,EA30M
185 ;;NU037^IP NUTR ED GP,14-17PT,EA30M
186 ;;NU038^IP NUTR ED GP,18-20PT,EA30M
187 ;;NU039^IP NUTR ED GP,21-25PT,EA30M
188 ;;NU040^IP NUTR ED GP,>25PT,EA30M
189 ;;NU042^INTERDISC IND VISIT,15M
190 ;;NU043^DISCUSS W/OTHR HC PROV,5M
191 ;;NU044^MNT NUTR GP,2-3 PT,EA30M
192 ;;NU045^MNT NUTR GP,4-6 PT,EA30M
193 ;;NU046^MNT NUTR GP,7-9 PT,EA30M
194 ;;NU047^MNT NUTR GP,10-13PT,EA30M
195 ;;NU048^MNT NUTR GP,14-17PT,EA30M
196 ;;NU049^MNT NUTR GP,18-20PT,EA30M
197 ;;NU050^MNT NUTR GP,21-25PT,EA30M
198 ;;NU051^MNT NUTR GP,>25PT,EA30M
199 ;;NU052^MNT GP 2ND REF,2-3PT,EA30M
200 ;;NU053^MNT GP 2ND REF,4-6PT,EA30M
201 ;;NU054^MNT GP 2ND REF,7-9PT,EA30M
202 ;;NU055^MNT GP 2ND REF,10-13PT,EA30M
203 ;;NU056^MNT GP 2ND REF,14-17PT,EA30M
204 ;;NU057^MNT GP 2ND REF,18-20PT,EA30M
205 ;;NU058^MNT GP 2ND REF,21-25PT,EA30M
206 ;;NU059^MNT GP 2ND REF,>25PT,EA30M
207 ;;NU060^DSMT GP,2-3PT,EA 30M
208 ;;NU061^DSMT GP,4-6PT,EA 30M
209 ;;NU062^DSMT GP,7-9PT,EA 30M
210 ;;NU063^DSMT GP,10-13PT,EA 30M
211 ;;NU064^DSMT GP,14-17PT,EA 30M
212 ;;NU065^DSMT GP,18-20PT,EA 30M
213 ;;NU066^DSMT GP,21-25PT,EA 30M
214 ;;NU067^DSMT GP,>25PT,EA 30M
215 ;;NU069^WT MGT,2-3PT,1ST 30M
216 ;;NU070^WT MGT,4-6PT,1ST 30M
217 ;;NU071^WT MGT,7-9PT,1ST 30M
218 ;;NU072^WT MGT,10-13PT,1ST 30M
219 ;;NU073^WT MGT,14-17PT,1ST 30M
220 ;;NU074^WT MGT,18-20PT,1ST 30M
221 ;;NU075^WT MGT,21-25PT,1ST 30M
222 ;;NU076^WT MGT,>25MT,1ST 30M
223 ;;NU077^NUTR ED,2-3PT,1ST 30M
224 ;;NU078^NUTR ED,4-6PT,1ST 30M
225 ;;NU079^NUTR ED,7-9PT,1ST 30M
226 ;;NU080^NUTR ED,10-13PT,1ST 30M
227 ;;NU081^NUTR ED,14-17PT,1ST 30M
228 ;;NU082^NUTR ED,18-20PT,1ST 30M
229 ;;NU083^NUTR ED,21-25PT,1ST 30M
230 ;;NU084^NUTR ED,>25PT,1ST 30M
231 ;;NU085^DIAB MGT,2-3PT,1ST 30M
232 ;;NU086^DIAB MGT,4-6PT,1ST 30M
233 ;;NU087^DIAB MGT,7-9PT,1ST 30M
234 ;;NU088^DIAB MGT,10-13PT,1ST 30M
235 ;;NU089^DIAB MGT,14-17PT,1ST 30M
236 ;;NU090^DIAB MGT,18-20PT,1ST 30M
237 ;;NU091^DIAB MGT,21-25PT,1ST 30M
238 ;;NU092^DIAB MGT,>25PT,1ST 30M
239 ;;NU093^PT ED GP,2-3PT,1ST 30M
240 ;;NU094^PT ED GP,4-6 PT,1ST 30M
241 ;;NU095^PT ED GP,7-9 PT,1ST 30M
242 ;;QUIT
Note: See TracBrowser for help on using the repository browser.