source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U38.m@ 623

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

initial load of WorldVistAEHR

File size: 6.9 KB
Line 
1EC725U38 ;ALB/GTS/JAP/GT - EC National Procedure Update; 1/30/2006
2 ;;2.0; EVENT CAPTURE ;**80**;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 ;;FOOT EXAM EA 10MIN^NU157
61 ;;AUD REHAB STATUS, 1ST HR^SP541^92626
62 ;;AUD REHAB STATUS, ADD 15 MIN^SP542^92627
63 ;;AUD REHAB TRMT, POSTT LING HL^SP543^92633
64 ;;L8699 PROSTHETIC IMPLANT, NOS^SP544^L8699
65 ;;QUIT
66NAMECHG ;* change national procedure names
67 ;
68 ; ECXX is in format:
69 ; NATIONAL NUMBER^NEW NAME
70 ;
71 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,STR
72 D MES^XPDUTL(" ")
73 D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
74 D MES^XPDUTL(" ")
75 F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT" D
76 .I $D(^EC(725,"D",$P(ECXX,U,1))) D
77 ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
78 ..I $D(^EC(725,ECDA,0)) D
79 ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
80 ...D MES^XPDUTL(" ")
81 ...D MES^XPDUTL(" Entry #"_ECDA_" for "_$P(ECXX,U,1))
82 ...D BMES^XPDUTL(" ... field (#.01) updated to "_$P(ECXX,U,2)_".")
83 .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
84 ..D MES^XPDUTL(" ")
85 ..S STR="Can't find entry for "_$P(ECXX,U,1)
86 ..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
87 Q
88 ;
89CHNG ;name changes -national code #^new procedure name
90 ;;NU022^PHONE-BRIEF W/OTHER PROV
91 ;;NU023^PHONE INTRM W/OTHER PROV
92 ;;NU024^PHONE LENGTHY W/OTHER PROV
93 ;;NU025^INTERDISC GP,2-5PT,15M
94 ;;NU026^INTERDISC GP,6-10PT,15M
95 ;;NU027^INTERDISC GP,11-20PT,15M
96 ;;NU028^INTERDISC GP,>20PT,15M
97 ;;NU033^IP NUTR ED GP,2-5PT,30M
98 ;;NU034^IP NUTR ED GP,6-10PT,30M
99 ;;NU035^IP NUTR EDGP,11-20PT,30M
100 ;;NU036^IP NUTR ED GP,>20PT,30M
101 ;;NU044^MNT NUTR GP,2-5 PT,30M
102 ;;NU045^MNT NUTR GP,6-10 PT,30M
103 ;;NU046^MNT NUTR GP,11-20 PT,30M
104 ;;NU047^MNT NUTR GP,>20PT,30M
105 ;;NU052^MNT GP 2ND REF,2-5PT,30M
106 ;;NU053^MNT GP 2ND REF,6-10PT,30M
107 ;;NU054^MNT GP 2ND REF,11-20PT,30M
108 ;;NU055^MNT GP 2ND REF>20PT,30M
109 ;;NU060^DSMT GP,2-5PT,30M
110 ;;NU061^DSMT GP,6-10PT,30M
111 ;;NU062^DSMT GP,11-20PT,30M
112 ;;NU063^DSMT GP,>20PT,30M
113 ;;NU069^WT MGT, 2-5PT, 1st 30M
114 ;;NU070^WT MGT, 6-10PT, 1st 30M
115 ;;NU071^WT MGT, 11-20PT, 1st 30M
116 ;;NU072^WT MGT, >20PT, 1st 30M
117 ;;NU077^NUTR ED, 2-5 PT 1st 30M
118 ;;NU078^NUTR ED, 6-10 PT 1st 30M
119 ;;NU079^NUTR ED, 11-20 PT 1st 30M
120 ;;NU080^NUTR ED, >20 PT 1st 30M
121 ;;NU085^DIAB MGMT GP,2-5 PT,1st 30M
122 ;;NU086^DIAB MGMT GP,6-10 PT, 1st 30M
123 ;;NU087^DIAB MGMT GP,11-20 PT, 1st 30M
124 ;;NU088^DIAB MGMT GP,>20 PT, 1st 30M
125 ;;NU093^PT ED GP, 2-5PT, 1st 30M
126 ;;NU094^PT ED GP, 6-10PT, 1st 30M
127 ;;NU095^PT ED GP, 11-20PT, 1st 30M
128 ;;NU096^PT ED GP, >20PT, 1st 30M
129 ;;NU101^SMOK CESS, 2-5 PT, 1st 30M
130 ;;NU102^SMOK CESS, 6-10 PT, 1st 30M
131 ;;NU103^SMOK CESS, 11-20 PT, 1st 30M
132 ;;NU104^SMOK CESS, >20 PT, 1st 30M
133 ;;NU109^NUTR GP, 2-5 PT, EA AD'L 30M
134 ;;NU110^NUTR GP, 6-10 PT, EA AD'L 30M
135 ;;NU111^NUTR GP, 11-20 PT, EA AD'L 30M
136 ;;NU112^NUTR GP, >20 PT, EA AD'L 30M
137 ;;NU117^WT MGT, 2-5 PT, EA AD'L 30M
138 ;;NU118^WT MGT, 6-10 PT, EA AD'L 30M
139 ;;NU119^WT MGT, 11-20 PT, EA AD'L 30M
140 ;;NU120^WT MGT, >20 PT, EA AD'L 30M
141 ;;NU125^DIAB MGT,2-5PT, EA AD'L 30M
142 ;;NU126^DIAB MGT,6-10PT, EA AD'L 30M
143 ;;NU127^DIAB MGT,11-20PT, EA AD'L 30M
144 ;;NU128^DIAB MGT,>20PT, EA AD'L 30M
145 ;;NU133^PT ED GP, 2-5 PT, EA AD'L 30M
146 ;;NU134^PT ED GP, 6-10 PT, EA AD'L 30M
147 ;;NU135^PT ED GP, 11-20 PT, EA AD'L 30M
148 ;;NU136^PT ED GP, >20 PT, EA AD'L 30M
149 ;;NU141^SMOK CESS, 2-5PT, EA AD'L 30M
150 ;;NU142^SMOK CESS, 6-10, EA AD'L 30M
151 ;;NU143^SMOK CESS, 11-20, EA AD'L 30M
152 ;;NU144^SMOK CESS, >20PT, EA AD'L 30M
153 ;;SP001^CERUMEN MANAGEMENT
154 ;;SP004^ACOUSTIC DEVICE EVAL/SELECTION
155 ;;SP013^FOCUSED ARTIC/PHONOLOGY EVAL
156 ;;SP015^FOCUSED DYSARTH/MOTOR SP EVAL
157 ;;SP018^FOCUSED RECEPT/EXPRESS LANG EVAL
158 ;;SP021^FOCUSED FLUENCY EVAL
159 ;;SP022^FOCUSED VOICE EVAL
160 ;;SP023^AUDITORY PROCESSING ASSESSMENT
161 ;;SP024^OTHER NONINVASIVE INSTRUM EXAM
162 ;;SP028^NONSPOKEN LANGUAGE TREATMENT
163 ;;SP029^RECEPT/EXPRESS LANG TREATMENT
164 ;;SP030^VOICE TREATMENT
165 ;;SP031^ARTIC/PHONOLOGY TREATMENT
166 ;;SP032^MOTOR SPEECH TREATMENT
167 ;;SP033^APHASIA TREATMENT
168 ;;SP034^FLUENCY TREATMENT
169 ;;SP036^AUDITORY PROCESSING TREATMENT
170 ;;SP038^INITIAL ACOUSTIC DEV FIT/ORIENT
171 ;;SP051^COCHLEAR IMPLANT REHAB
172 ;;SP055^LARYNGEAL FUNCTION STUDY
173 ;;SP057^SWALLOWING TREATMENT
174 ;;SP097^AUDITORY EVOKED POT, LIMITED
175 ;;SP103^HEARING AID ASSESSMENT, MON
176 ;;SP104^HEARING AID ASSESSMENT, BIN
177 ;;SP105^HEARING AID CHECK, MON
178 ;;SP106^HEARING AID CHECK, BIN
179 ;;SP112^VOICE PROSTHESIS EVAL/FITTING
180 ;;SP113^VOICE PROSTHESIS TREATMENT
181 ;;SP228^SPEECH/LANG EVAL
182 ;;SP229^SPEECH/LANG TREATMENT
183 ;;SP230^CLINICAL SWALLOWING EVAL
184 ;;SP245^FOCUSED NASALITY EVAL
185 ;;SP246^FOCUSED ALARYNGEAL SPEECH EVAL
186 ;;SP247^FOCUSED PROSODY EVAL
187 ;;SP248^ALARYNGEAL SPEECH TREATMENT
188 ;;SP249^NASALITY TREATMENT
189 ;;SP315^AUDITORY EVOKED POT, DIAGNOSTIC
190 ;;SP478^EVAL NON SPEECH GEN AAC DEVICE
191 ;;SP481^THERAPEUTIC SERV NON SP GEN DEV
192 ;;SP488^REMOVE FOREIGN BODY
193 ;;SP491^DIAG ANALYSIS COCHLEAR IMPLANT
194 ;;SP494^SUBSEQUENT PROGRAMMING
195 ;;SP521^A9280 ALERTING DEVICE, NOC
196 ;;QUIT
Note: See TracBrowser for help on using the repository browser.