source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U48.m@ 1336

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

initial load of WorldVistAEHR
File size: 8.2 KB
RevLine 
[613]1EC725U48 ;ALB/GTS/JAP/GT - EC National Procedure Update; 02/27/2008
2 ;;2.0; EVENT CAPTURE ;**96**;8 May 96;Build 5
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 ;;97001 REFER/CONS/SCREEN^RC001^97001
61 ;;97001 RECORD REVIEW^RC002^97001
62 ;;97001 ASMNT INIT 30M^RC003^97001
63 ;;97002 ASMNT UPREVDISC 30M^RC004^97002
64 ;;97001 ASMNT PROG NOTE^RC005^97001
65 ;;97001 ASMNT PROG NOTE 15M^RC006^97001
66 ;;97001 DISCH/COMM REF 15M^RC007^97001
67 ;;97001 DISCH/COMM REF 30M^RC008^97001
68 ;;98961 TEAMEETCAREPLAN 15M^RC009^98961
69 ;;98961 TEAMEETCAREPLAN 30M^RC010^98961
70 ;;98962 IDT GRP 2-4 30M^RC011^98962
71 ;;98962 IDT GRP 5-10 30M^RC012^98962
72 ;;97530 REC CREATARTIND 15M^RC013^97530
73 ;;99499 REC CREATARTGRP 2-4^RC014^99499
74 ;;99499 REC CREATARTGRP 5-20^RC015^99499
75 ;;99499 REC CREATARTGRP >20^RC016^99499
76 ;;97532 RECTHER EMOT IND 15M^RC017^97532
77 ;;97530 RECTHER COG IND 15M^RC018^97530
78 ;;97112 RECTHER PHY IND 15M^RC019^97112
79 ;;97532 RECTHER SOC IND 15M^RC020^97532
80 ;;97150 RECTHER SOC GRP 2-4^RC021^97150
81 ;;97150 RECTHER SOC GRP 5-20^RC022^97150
82 ;;97150 RECTHER SOC GRP>20^RC023^97150
83 ;;97150 RECTHER COG GRP 2-4^RC024^97150
84 ;;97150 RECTHER COG GRP 5-20^RC025^97150
85 ;;97150 RECTHER COG GRP >20^RC026^97150
86 ;;97150 RECTHER PHY GRP 2-4^RC027^97150
87 ;;97150 RECTHER PHY GRP 5-20^RC028^97150
88 ;;97150 RECTHER PHY GRP >20^RC029^97150
89 ;;97150 RECTHER EMOT GRP 2-4^RC030^97150
90 ;;97150 RECTHER EMOTGRP 5-20^RC031^97150
91 ;;97150 RECTHER EMOTGRP >20^RC032^97150
92 ;;97530 ARTTHER SOC IND 15M^RC033^97530
93 ;;97532 ARTTHER COG IND 15M^RC034^97532
94 ;;97533 ARTTHER EMOTIND 15M^RC035^97533
95 ;;97150 ARTTHER SOC GRP 2-4^RC036^97150
96 ;;97150 ARTTHER SOC GRP 5-20^RC037^97150
97 ;;97150 ARTTHER SOC GRP >20^RC038^97150
98 ;;97150 ARTTHER COG GRP 2-4^RC039^97150
99 ;;97150 ARTTHER COG GRP 5-20^RC040^97150
100 ;;97150 ARTTHER COG GRP >20^RC041^97150
101 ;;97150 ARTTHER EMOTGRP 2-4^RC042^97150
102 ;;97150 ARTTHER EMOTGRP 5-20^RC043^97150
103 ;;97150 ARTTHER EMOTGRP >20^RC044^97150
104 ;;97530 DANCETHER IND15M^RC045^97530
105 ;;97530 DANCETHER GRP 2-4^RC046^97150
106 ;;97530 DANCETHER GRP 5-20^RC047^97150
107 ;;97530 DANCETHER GRP >20^RC048^97150
108 ;;97150 DRAMA THER IND^RC049^97530
109 ;;97530 DRAMA THER GRP 2-4^RC050^97150
110 ;;97530 DRAMA THER GRP 5-20^RC051^97150
111 ;;97530 DRAMA THER GRP >20^RC052^97150
112 ;;92506 MUSTHER SOC IND 15M^RC053^92506
113 ;;92507 MUSTHER COG IND 15M^RC054^92507
114 ;;97112 MUSTHER PHYIND 15M^RC055^97112
115 ;;91533 MUSTHER EMOTIND 15M^RC056^97533
116 ;;97150 MUSTHER SOCGRP 2-4^RC057^97150
117 ;;97150 MUSTHER SOCGRP 5-20^RC058^97150
118 ;;97150 MUSTHER SOCGRP >20^RC059^97150
119 ;;97150 MUSTHER COGGRP 2-4^RC060^97150
120 ;;97150 MUSTHER COGGRP 5-20^RC061^97150
121 ;;97150 MUSTHER COGGRP >20^RC062^97150
122 ;;97150 MUSTHER PHYGRP 2-4^RC063^97150
123 ;;97150 MUSTHER PHYGRP 5-20^RC064^97150
124 ;;97150 MUSTHER PHYGRP >20^RC065^97150
125 ;;97150 MUSTHER EMOTGRP 2-4^RC066^97150
126 ;;97150 MUSTHER EMOTGRP 5-20^RC067^97150
127 ;;97150 MUSTHER EMOTGRP >20^RC068^97150
128 ;;97110 AQUATIC ACT IND 30M^RC069^97110
129 ;;S9454 AQUATIC ACT GRP 2-4^RC070^S9454
130 ;;S9454 AQUATIC ACT GRP 5-20^RC071^S9454
131 ;;S9454 AQUATIC ACT GRP >20^RC072^S9454
132 ;;97113 AQUATICTHER IND 30M^RC073^97113
133 ;;97150 AQUATICTHER GRP 2-4^RC074^97150
134 ;;97150 AQUATICTHER GRP5-20^RC075^97150
135 ;;97150 AQUATICTHER GRP >20^RC076^97150
136 ;;97537 COMMIINTEGRT IND^RC077^97537
137 ;;97537 COMMINTEGRTGRP 2-4^RC078^97537
138 ;;97537 COMM INTEGRTGRP 5-20^RC079^97537
139 ;;97537 COMM INTEGRTGRP >20^RC080^97537
140 ;;S9446 LEIS EDUC IND 15M^RC081^S9446
141 ;;S9446 LEIS EDUCGRP2-4 15M^RC082^S9446
142 ;;S9446 LEIS EDUCGRP 5-20 15M^RC083^S9446
143 ;;S9446 LEIS EDUCGRP>20 15M^RC084^S9446
144 ;;98966 TELEPHONE SHORT^RC085^98966
145 ;;98967 TELEPHONE MED^RC086^98967
146 ;;98968 TELEPHONE LONG^RC087^98968
147 ;;T2001 PAT ESCORT GRP 2-4^RC088^T2001
148 ;;T2001 PAT ESCORT GRP 5-20^RC089^T2001
149 ;;T2001 PAT ESCORT GRP >20^RC090^T2001
150 ;;CNH PHONE OVERSIGHT^HH142^
151 ;;CNH FAX REVIEW ONLY^HH143^
152 ;;NU162/MNT F/U EA 15M^NU162^97803
153 ;;NU163/MNT SUBSEQ EA 15M^NU163^G0270
154 ;;NU164/NUT CNSG IND,1ST15M^NU164^S9470
155 ;;NU165/CASE MGT,W/PT EA15M^NU165^T1017
156 ;;NU166/NUT SCREENING 10M^NU166^T1023
157 ;;NU167/OTHER OPT VISIT^NU167^99211
158 ;;NU168/PT EDUC 1ST 15M^NU168^S9445
159 ;;NU169/INSLN PMP ED 1ST15M^NU169^S9145
160 ;;NU170/GLUC FINGER STICK^NU170^82962
161 ;;NU171/PHONE 5-10 MIN^NU171^98966
162 ;;NU172/PHONE 11-20 MIN^NU172^98967
163 ;;NU173/PHONE 21-30 MIN^NU173^98968
164 ;;NU174/DSMT ACCRED IND 30M^NU174^G0108
165 ;;NU175/DSMT NONACD 1ST15M^NU175^S9465
166 ;;NU176/DSMT NONACD FU1ST15^NU176^S9140
167 ;;NU177/CBGM^NU177^95250
168 ;;NU178/SELF-MGT ED IND,30M^NU178^98960
169 ;;NU179/SELF MGT GP2-4,30M^NU179^98961
170 ;;NU180/SELF MGT GP5-8,30M^NU180^98962
171 ;;NU181/COLL RVW ELEC DATA^NU181^99091
172 ;;NU182/MNT INIT EA 15M^NU182^97802
173 ;;NON-PHYS TM CNF, PT PRSNT^SP551^99366
174 ;;NON-PHYS TM CNF, PT NOT PRSNT^SP552^99368
175 ;;98969 ONLINE SERVICE^SP553^98969
176 ;;QUIT
177NAMECHG ;* change national procedure names
178 ;
179 ; ECXX is in format:
180 ; NATIONAL NUMBER^NEW NAME
181 ;
182 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,STR
183 D MES^XPDUTL(" ")
184 D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
185 D MES^XPDUTL(" ")
186 F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT" D
187 .I $D(^EC(725,"D",$P(ECXX,U,1))) D
188 ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
189 ..I $D(^EC(725,ECDA,0)) D
190 ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
191 ...D MES^XPDUTL(" ")
192 ...D MES^XPDUTL(" Entry #"_ECDA_" for "_$P(ECXX,U,1))
193 ...D BMES^XPDUTL(" ... field (#.01) updated to "_$P(ECXX,U,2)_".")
194 .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
195 ..D MES^XPDUTL(" ")
196 ..S STR="Can't find entry for "_$P(ECXX,U,1)
197 ..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
198 Q
199 ;
200CHNG ;name changes -national code #^new procedure name
201 ;;NU019^NU019/PHONE 5-10M NO PT
202 ;;NU020^NU020/PHONE 11-20M NO PT
203 ;;NU021^NU021/PHONE 21-30M NO PT
204 ;;NU022^NU022/PHONE 5-10M PROV
205 ;;NU023^NU023/PHONE 11-20M PROV
206 ;;NU024^NU024/PHONE 21-30M PROV
207 ;;SP350^STANDARDIZED COGNITIVE TESTING
208 ;;SW010^PHONE CONTACT 5-10 MIN
209 ;;SW012^PHONE D/C NONMH F/U 15MIN
210 ;;SW044^PHONE CONTACT 11-20 MIN
211 ;;SW045^PHONE CONTACT 21-30 MIN
212 ;;SW054^PHONE D/C NONMH F/U 45MIN
213 ;;SW089^PHONE D/C MH F/U 15 MIN
214 ;;SP196^98966 TELEPHONE SERVICE, 5-10 MIN
215 ;;SP197^98967 TELEPHONE SERVICE, 11-20 MIN
216 ;;SP198^98968 TELEPHONE SERVICE, 21-30 MIN
217 ;;QUIT
Note: See TracBrowser for help on using the repository browser.