source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U30.m@ 1141

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

initial load of WorldVistAEHR

File size: 6.8 KB
RevLine 
[613]1EC725U30 ;ALB/GTS/JAP/GT - EC National Procedure Update; 1/05/2005
2 ;;2.0; EVENT CAPTURE ;**71**;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 PRCH ADHC RATE1 VSTS/MO^HH130
61 ;;HH PRCH ADHC RATE2 VSTS/MO^HH131
62 ;;HH PRCH ADHC RATE3 VSTS/MO^HH132
63 ;;NUT SCREENING/REFERRAL,5M^NU001
64 ;;STATUS NORMAL^NU002
65 ;;STATUS MILD^NU003
66 ;;STATUS MODERATE^NU004
67 ;;STATUS SEVERE^NU005
68 ;;MEDICAL RECORD REVIEW,5M^NU006
69 ;;INP/NH NUT CARE-BASIC,10M^NU007
70 ;;INP/NH NUT CARE-INTRM,10M^NU008
71 ;;INP/NH NUT CARE-CMPLX,10M^NU009
72 ;;MEAL ROUNDS/PT OBS,5M^NU010
73 ;;FOOD PREF/ALLERGIES,5M^NU011
74 ;;CALORIE COUNT,5M^NU012
75 ;;MENU ANAL/MEAL PLN DEV,5M^NU013
76 ;;MDS CARE PLAN DOC.10M^NU014
77 ;;TEAM ROUNDS,5M(W/WO PT)^NU015
78 ;;INTERDISC.CARE PLN MTG,5M^NU016
79 ;;CASE MGMT,15M(W/WO PT)^NU017
80 ;;COMMUNITY REFERRAL,5M^NU018
81 ;;PHONE CALL-BRIEF W/PT^NU019
82 ;;PHONE CALL-INTERMED. W/PT^NU020
83 ;;PHONE CALL-LENGTHY W/PT^NU021
84 ;;PHONE CALL-BRIEF W/OTHER^NU022
85 ;;PHONE CALL-INTRM W/OTHER^NU023
86 ;;PHONE CALL-LENGTHY W/OTHR^NU024
87 ;;INTERDISC.GRP,1-3PTS,15M^NU025
88 ;;INTERDISC.GRP,4-6PTS,15M^NU026
89 ;;INTERDISC.GRP,7-9PTS,15M^NU027
90 ;;INTERDISC.GP,10-13PTS,15M^NU028
91 ;;INTERDISC.GP,14-17PTS,15M^NU029
92 ;;INTERDISC.GP,18-20PTS,15M^NU030
93 ;;INTERDISC.GP,21-25PTS,15M^NU031
94 ;;INTERDISC.GP,>25PTS,15M^NU032
95 ;;IP NUT.ED.GP,1-3PT,30M^NU033
96 ;;IP NUT.ED.GP,4-6PT,30M^NU034
97 ;;IP NUT.ED.GP,7-9PT,30M^NU035
98 ;;IP NUT.ED.GP,10-13PT,30M^NU036
99 ;;IP NUT.ED.GP,14-17PT,30M^NU037
100 ;;IP NUT.ED.GP,18-20PT,30M^NU038
101 ;;IP NUT.ED.GP,21-25PT,30M^NU039
102 ;;IP NUT.ED.GP,>25PT,30M^NU040
103 ;;CORRESPONDENCE, 5M^NU041
104 ;;HOME HEALTH-INITIAL-15M^NU042^97802
105 ;;HOME HEALTH-F/U-15M^NU043^97803
106 ;;MNT NUTRI GP,1-3 PTS,30M^NU044^97804
107 ;;MNT NUTRI GP,4-6 PTS,30M^NU045^97804
108 ;;MNT NUTRI GP,7-9 PTS,30M^NU046^97804
109 ;;MNT NUTRI GP,10-13PTS,30M^NU047^97804
110 ;;MNT NUTRI GP,14-17PTS,30M^NU048^97804
111 ;;MNT NUTRI GP,18-20PTS,30M^NU049^97804
112 ;;MNT NUTRI GP,21-25PTS,30M^NU050^97804
113 ;;MNT NUTRI GP,>25PTS,30M^NU051^97804
114 ;;MNT GP,2ND REF,1-3PTS,30M^NU052^G0271
115 ;;MNT GP,2ND REF,4-6PTS,30M^NU053^G0271
116 ;;MNT GP,2ND REF,7-9PTS,30M^NU054^G0271
117 ;;MNT GP2ND REF10-13PTS,30M^NU055^G0271
118 ;;MNT GP2ND REF14-17PTS,30M^NU056^G0271
119 ;;MNT GP2ND REF18-20PTS,30M^NU057^G0271
120 ;;MNT GP2ND REF21-25PTS,30M^NU058^G0271
121 ;;MNT GP2ND REF,>25PTS,30M^NU059^G0271
122 ;;DSMT GP,1-3PTS,30M^NU060^G0109
123 ;;DSMT GP,4-6PTS,30M^NU061^G0109
124 ;;DSMT GP,7-9PTS,30M^NU062^G0109
125 ;;DSMT GP,10-13PTS,30M^NU063^G0109
126 ;;DSMT GP,14-17PTS,30M^NU064^G0109
127 ;;DSMT GP,18-20PTS,30M^NU065^G0109
128 ;;DSMT GP,21-25PTS,30M^NU066^G0109
129 ;;DSMT GP,>25PTS,30M^NU067^G0109
130 ;;CASE MGMT,15M (WO PT)^NU068
131 ;;WEIGHT MGMT CLASS,1-3PTS^NU069^S9449
132 ;;WEIGHT MGMT CLASS,4-6PTS^NU070^S9449
133 ;;WEIGHT MGMT CLASS,7-9PTS^NU071^S9449
134 ;;WEIGHT MGMT CLASS,10-13PTS^NU072^S9449
135 ;;WEIGHT MGMT CLASS,14-17PTS^NU073^S9449
136 ;;WEIGHT MGMT CLASS,18-20PTS^NU074^S9449
137 ;;WEIGHT MGMT CLASS,21-25PTS^NU075^S9449
138 ;;WEIGHT MGMT CLASS,>25PTS^NU076^S9449
139 ;;OPT NUT.ED.GP,1-3PT,30M^NU077^S9452
140 ;;OPT NUT.ED.GP,4-6PT,30M^NU078^S9452
141 ;;OPT NUT.ED.GP,7-9 PT,30M^NU079^S9452
142 ;;OPT NUT.ED.GP,10-13PT,30M^NU080^S9452
143 ;;OPT NUT.ED.GP,14-17PT,30M^NU081^S9452
144 ;;OPT NUT.ED.GP,18-20PT,30M^NU082^S9452
145 ;;OPT NUT.ED.GP,21-25PT,30M^NU083^S9452
146 ;;OPT NUT.ED.GP,>25PT,30M^NU084^S9452
147 ;;DIAB MGMT GP,1-3 PTS^NU085^S9455
148 ;;DIAB MGMT GP,4-6 PTS^NU086^S9455
149 ;;DIAB MGMT GP,7-9 PTS^NU087^S9455
150 ;;DIAB MGMT GP,10-13 PTS^NU088^S9455
151 ;;DIAB MGMT GP,14-17 PTS^NU089^S9455
152 ;;DIAB MGMT GP,18-20 PTS^NU090^S9455
153 ;;DIAB MGMT GP,21-25 PTS^NU091^S9455
154 ;;DIAB MGMT GP,>25 PTS^NU092^S9455
155 ;;NU093RESERVE^NU093
156 ;;NU094RESERVE^NU094
157 ;;NU095RESERVE^NU095
158 ;;QUIT
159NAMECHG ;* change national procedure names
160 ;
161 ; ECXX is in format:
162 ; NATIONAL NUMBER^NEW NAME
163 ;
164 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,STR
165 D MES^XPDUTL(" ")
166 D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
167 D MES^XPDUTL(" ")
168 F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT" D
169 .I $D(^EC(725,"D",$P(ECXX,U,1))) D
170 ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
171 ..I $D(^EC(725,ECDA,0)) D
172 ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
173 ...D MES^XPDUTL(" ")
174 ...D MES^XPDUTL(" Entry #"_ECDA_" for "_$P(ECXX,U,1))
175 ...D BMES^XPDUTL(" ... field (#.01) updated to "_$P(ECXX,U,2)_".")
176 .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
177 ..D MES^XPDUTL(" ")
178 ..S STR="Can't find entry for "_$P(ECXX,U,1)
179 ..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
180 Q
181 ;
182CHNG ;name changes -national code #^new procedure name
183 ;;SP100^CENT AUD FNCT EVL INIT 60 M
184 ;;SP228^SPEECH/LANG EVAL LEV1
185 ;;SP229^SPEECH/LANG TRTMT LEV1
186 ;;SP317^CENT AUD FNCT EVL ADDL 15 M
187 ;;SP331^SPEECH/LANG EVAL LEV2
188 ;;SP332^SPEECH/LANG EVAL LEV3
189 ;;SP333^SPEECH/LANG TRTMT LEV2
190 ;;SP334^SPEECH/LANG TRTMT LEV3
191 ;;QUIT
Note: See TracBrowser for help on using the repository browser.