source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SD10STOP.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1SD10STOP ;ALB/CAW,GTS,ESD,JAM - Stop Code/DSS Identifier Update 07/06/06
2 ;;5.3;Scheduling;**489**;AUG 13, 1993
3 ;
4 ;** This patch is used as a Post-Init in a KIDS build to modify the
5 ;** the DSS Identifier file [^DIC(40.7,]
6 ;
7EN ;** Add/inactivate/change/reactivate DSS IDs (stop codes)
8 ;** The following code executes if file modifications exist
9 ;
10 N SDVAR
11 D:$P($T(NEW+1),";;",2)'="QUIT" ADD
12 D:$P($T(OLD+1),";;",2)'="QUIT" INACT
13 D:$P($T(CHNG+1),";;",2)'="QUIT" CHANGE
14 D:$P($T(CDR+1),";;",2)'="QUIT" CDRNUM
15 D:$P($T(ACT+1),";;",2)'="QUIT" REACT
16 D:$P($T(REST+1),";;",2)'="QUIT" RESTR
17 Q
18 ;
19 ;
20ADD ;** Add DSS IDs
21 ;
22 ; SDXX is in format:
23 ; STOP CODE NAME^AMIS #^RESTRICTION TYPE^REST. DATE^CDR #
24 ;
25 N SDX,SDXX
26 S SDVAR=1
27 D MES^XPDUTL("")
28 D BMES^XPDUTL(">>> Adding new Clinic Stops (DSS IDs) to CLINIC STOP File (#40.7)...")
29 ;
30 ;** NOTE: The following line is for DSS IDs that are not yet active
31 D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 05/1/06]")
32 S DIC(0)="L",DLAYGO=40.7,DIC="^DIC(40.7,"
33 F SDX=1:1 K DD,DO,DA S SDXX=$P($T(NEW+SDX),";;",2) Q:SDXX="QUIT" DO
34 .S DIC("DR")="1////"_$P(SDXX,"^",2)_$S('+$P(SDXX,U,5):"",1:";4////"_$P(SDXX,"^",5))
35 .S DIC("DR")=DIC("DR")_";5////"_$P(SDXX,"^",3)_";6///"_$P(SDXX,"^",4)
36 .S X=$P(SDXX,"^",1)
37 .I '$D(^DIC(40.7,"C",$P(SDXX,"^",2))) D FILE^DICN,MESS Q
38 .I $D(^DIC(40.7,"C",$P(SDXX,"^",2))) D EDIT(SDXX),MESSEX
39 K DIC,DLAYGO,X
40 Q
41 ;
42EDIT(SDXX) ;- Edit fields w/new values if stop code record already exists
43 ;
44 Q:$G(SDXX)=""
45 N DA,DIE,DLAYGO,DR
46 S DA=+$O(^DIC(40.7,"C",+$P(SDXX,"^",2),0))
47 Q:'DA
48 S DIE="^DIC(40.7,",DR=".01////"_$P(SDXX,"^")_";1////"_$P(SDXX,"^",2)_";2////@"_$S('+$P(SDXX,U,5):"",1:";4////"_$P(SDXX,"^",5))_";5////"_$P(SDXX,"^",3)_";6///"_$P(SDXX,"^",4)
49 D ^DIE
50 Q
51INACT ;** Inactivate DSS IDs
52 ;
53 ; SDXX is in format:
54 ; AMIS #^^INACTIVATION DATE (in FileMan format)
55 ;
56 N SDX,SDDA,SDXX,SDINDT,SDEXDT
57 S SDVAR=1
58 D MES^XPDUTL("")
59 D BMES^XPDUTL(">>> Inactivating Clinic Stops (DSS IDs) in CLINIC STOP File (#40.7)...")
60 D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used AFTER the indicated inactivation date]")
61 F SDX=1:1 K DD,DO,DA S SDXX=$P($T(OLD+SDX),";;",2) Q:SDXX="QUIT" DO
62 . I +$P(SDXX,"^",3) D
63 .. S X=$P(SDXX,"^",3)
64 .. ;
65 .. ;- Validate date passed in
66 .. S %DT="FTX"
67 .. D ^%DT
68 .. Q:Y<0
69 .. S SDINDT=Y
70 .. D DD^%DT
71 .. S SDEXDT=Y
72 .. S SDDA=+$O(^DIC(40.7,"C",+SDXX,0))
73 .. I $D(^DIC(40.7,SDDA,0)) D
74 ... S DA=SDDA,DR="2////^S X=SDINDT",DIE="^DIC(40.7,"
75 ... D ^DIE,MESI(SDEXDT)
76 K %,%H,%I,DR,DA,DIC,DIE,DLAYGO,X,%DT,Y
77 Q
78 ;
79CHANGE ;** Change DSS ID names
80 ;
81 ; SDXX is in format:
82 ; STOP CODE NAME^AMIS #^^NEW STOP CODE NAME
83 ;
84 N SDX,SDXX,SDDA
85 S SDVAR=1
86 D MES^XPDUTL("")
87 D BMES^XPDUTL(">>> Changing Clinic Stop (DSS ID) names in CLINIC STOP File (#40.7)...")
88 F SDX=1:1 K DD,DO,DA S SDXX=$P($T(CHNG+SDX),";;",2) Q:SDXX="QUIT" DO
89 .S SDDA=+$O(^DIC(40.7,"C",$P(SDXX,U,2),0))
90 .I $D(^DIC(40.7,SDDA,0)) DO
91 ..S DA=SDDA,DR=".01///"_$P(SDXX,U,4),DIE="^DIC(40.7,"
92 ..D ^DIE,MESC
93 K DIE,DR,DA
94 Q
95 ;
96CDRNUM ;** Change CDR numbers
97 ;
98 ; SDXX is in format:
99 ; STOP CODE NAME (AMIS #) ^ AMIS # ^ OLD CDR # ^ NEW CDR #
100 ;
101 N SDX,SDXX,SDDA
102 S SDVAR=2
103 D MES^XPDUTL("")
104 D BMES^XPDUTL(">>> Changing CDR numbers in CLINIC STOP File (#40.7)...")
105 F SDX=1:1 K DD,DO,DA S SDXX=$P($T(CDR+SDX),";;",2) Q:SDXX="QUIT" DO
106 .S SDDA=+$O(^DIC(40.7,"C",$P(SDXX,U,2),0))
107 .I $D(^DIC(40.7,SDDA,0)) DO
108 ..S DA=SDDA,DR="4///"_$P(SDXX,U,4),DIE="^DIC(40.7,"
109 ..D ^DIE,MESN
110 K DIE,DR,DA,X
111 Q
112 ;
113REACT ;** Reactivate DSS IDs
114 ;
115 ; SDXX is in format:
116 ; AMIS #^
117 ;
118 N SDX,SDDA,SDXX
119 ;S SDDA=+$O(^DIC(40.7,"C",510,0)) I $P($G(^DIC(40.7,SDDA,0)),"^",3)="" Q
120 S SDVAR=1
121 D MES^XPDUTL("")
122 D BMES^XPDUTL(">>> Reactivating Clinic Stops (DSS IDs) in CLINIC STOP File (#40.7)...")
123 F SDX=1:1 K DD,DO,DA S SDXX=$P($T(ACT+SDX),";;",2) Q:SDXX="QUIT" DO
124 .S SDDA=+$O(^DIC(40.7,"C",+SDXX,0))
125 .I $P($G(^DIC(40.7,SDDA,0)),"^",3)'="" DO
126 .. S $P(^DIC(40.7,SDDA,0),"^",3)=""
127 ..D MESA
128 Q
129 ;
130RESTR ;** Change Restriction Data
131 ;
132 ; SDXX is in format:
133 ; STOP CODE NAME^STOP CODE NUMBER^RESTRICTION TYPE^RESTRICTION DATE
134 ;
135 N SDX,SDXX,SDDA
136 S SDVAR=3
137 D MES^XPDUTL("")
138 D BMES^XPDUTL(">>> Changing Restriction Data in CLINIC STOP File (#40.7)...")
139 F SDX=1:1 K DD,DO,DA S SDXX=$P($T(REST+SDX),";;",2) Q:SDXX="QUIT" D
140 .S SDDA=+$O(^DIC(40.7,"C",$P(SDXX,U,2),0))
141 .I $D(^DIC(40.7,SDDA,0)) D
142 ..S DA=SDDA,DR="5////"_$P(SDXX,U,3)_";6///"_$P(SDXX,U,4),DIE="^DIC(40.7,"
143 ..D ^DIE,MESR
144 K DIE,DR,DA,X
145 Q
146 ;
147MESS ;** Add message
148 N ECXADMSG
149 I +$G(SDVAR) D HDR(SDVAR)
150 D MES^XPDUTL(" ")
151 S ECXADMSG="Added: "_$P(SDXX,"^",2)_" "_$P(SDXX,"^")
152 I $P(SDXX,"^",5)'="" S ECXADMSG=ECXADMSG_" [CDR#: "_$P(SDXX,"^",5)_"]"
153 D MES^XPDUTL(ECXADMSG)
154 I $P(SDXX,"^",3)'="" S ECXADMSG=" Restricted Type: "_$P(SDXX,"^",3)_" Restricted Date: "_$P(SDXX,"^",4)
155 D MES^XPDUTL(ECXADMSG)
156 K SDVAR
157 Q
158 ;
159MESSEX ;** Display message if stop code already exists
160 N ECXADMSG
161 I +$G(SDVAR) D HDR(SDVAR)
162 D MES^XPDUTL(" ")
163 S ECXADMSG=" "_$P(SDXX,"^",2)_" "_$P(SDXX,"^")_" already exists."
164 D MES^XPDUTL(ECXADMSG)
165 K SDVAR
166 Q
167 ;
168MESI(SDEXDT) ;** Inactivate message
169 ;
170 ; Parameter:
171 ; SDEXDT - Date inactivation affective (External Format)
172 ;
173 N SDINMSG
174 I +$G(SDVAR) D HDR(SDVAR)
175 I $G(SDEXDT)="" S SDEXDT="UNKNOWN"
176 D MES^XPDUTL(" ")
177 S SDINMSG="Inactivated: "_+SDXX_" "_$P($G(^DIC(40.7,SDDA,0)),"^")_" as of "_SDEXDT
178 D MES^XPDUTL(SDINMSG)
179 K SDVAR
180 Q
181 ;
182MESA ;** Reactivate message
183 ;
184 N SDACMSG
185 I +$G(SDVAR) D HDR(SDVAR)
186 D MES^XPDUTL(" ")
187 S SDACMSG="Reactivated: "_+SDXX_" "_$P($G(^DIC(40.7,SDDA,0)),"^")
188 D MES^XPDUTL(SDACMSG)
189 K SDVAR
190 Q
191 ;
192MESC ;** Change message
193 N SDCMSG,SDCMSG1
194 I +$G(SDVAR) D HDR(SDVAR)
195 D MES^XPDUTL(" ")
196 S SDCMSG="Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)
197 S SDCMSG1=" to: "_$P(SDXX,U,2)_" "_$P(SDXX,U,4)
198 D MES^XPDUTL(SDCMSG)
199 D MES^XPDUTL(SDCMSG1)
200 K SDVAR
201 Q
202 ;
203MESN ;** Change number
204 N SDNMSG,SDNMSG1
205 I +$G(SDVAR) D HDR(SDVAR)
206 D MES^XPDUTL(" ")
207 S SDNMSG=" Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)
208 S SDNMSG1=" : "_$P(SDXX,U,3)_" Date: "_$P(SDXX,U,5)
209 D MES^XPDUTL(SDNMSG)
210 D MES^XPDUTL(SDNMSG1)
211 K SDVAR
212 Q
213MESR ;** Restricting Stop Code
214 N SDNMSG,SDNMSG1
215 I +$G(SDVAR) D HDR(SDVAR)
216 D MES^XPDUTL(" ")
217 S SDNMSG="Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)_" "_$P(SDXX,U,5)_" "_$P(SDXX,U,6)
218 S SDNMSG1=" to: "_$P(SDXX,U,3)_" "_$P(SDXX,U,4)
219 D MES^XPDUTL(SDNMSG)
220 D MES^XPDUTL(SDNMSG1)
221 K SDVAR
222 Q
223 ;
224HDR(SDVAR) ;- Header
225 Q:'$G(SDVAR)
226 N SDHDR
227 S SDHDR=$P($T(@("HDR"_SDVAR)),";;",2)
228 D BMES^XPDUTL(SDHDR)
229 Q
230 ;
231 ;
232HDR1 ;; Stop Code Name
233 ;
234HDR2 ;; CDR Stop Code Name
235 ;
236HDR3 ;; Stop Code Name Rest. Type Date
237 ;
238NEW ;DSS IDs to add- ex ;;STOP CODE NAME^NUMBER^RESTRICTION TYPE^RESTRICTION DATE^CDR
239 ;;COMPLEMENTARY & ALTERNATIVE RX^159^P^10/1/2006
240 ;;TELEPHONE CASE MANAGEMENT^182^P^10/1/2006
241 ;;PRRC INDIVIDUAL^582^P^10/1/2006
242 ;;PRRC GROUP^583^P^10/1/2006
243 ;;PRRC TELEPHONE^584^P^10/1/2006
244 ;;CHART CONSULT^697^S^10/1/2006
245 ;;QUIT
246 ;
247OLD ;DSS IDs to be inactivated- ex. ;;AMIS NUMBER^^INACTIVE DATE
248 ;;QUIT
249 ;
250CHNG ;DSS ID name changes- example ;;STOP CODE NAME^NUMBER^^NEW NAME
251 ;;HOME TREATMENT SERVICES^118^^HOME TREATMENT/SERVICES
252 ;;ADVNCD ILLNESS COOR CARE(AICC)^351^^HOSPICE & PALLIATIVE CARE
253 ;;UROLOGY^414^^UROLOGY CLINIC
254 ;;CYSTO ROOM UNIT FOR OUTPATIENT^430^^CYSTO ROOM IN UROLOGY CL
255 ;;CHIROPRACTIC CARE IN MED CTR^436^^CHIROPRACTIC CARE
256 ;;ACTIVE DUTY SEX TRAUMA^524^^ACTIVE DUTY SEXUAL TRAUMA
257 ;;MH PRIMARY CARE TEAM - IND^531^^MENTAL HLTH PRIM CARE IND
258 ;;MH MEDICAL CARE ONLY-GROUP^565^^MH INTERVENTION BIOMED GRP
259 ;;READJUSTMENT COUNSELING-INDIV^571^^RVOEC INDIVIDUAL
260 ;;READJUSTMENT COUNSELING-GROUP^572^^RVOEC GROUP
261 ;;MH INCENTIVE THERAPY - GROUP^573^^MH INCENTIVE THERAPY F TO F
262 ;;NON-ACTIVE DUTY SEX TRAUMA^589^^NON-ACTIVE DUTY SEXUAL TRAUMA
263 ;;CHRON ASSISTED HEMODIAL TREAT^602^^ASSISTED HEMODIALYSIS
264 ;;LIM SELF CARE HEMODIAL TREAT^603^^LIMITED SELF CARE HEMODIALYSIS
265 ;;HOME/SELF HEMODIAL TRAIN TREAT^604^^HOME/SELF HEMODIALYSIS TRNING
266 ;;CHRON ASSISTED PERIT DIALYSIS^606^^CAPD CONTIN AMBUL PERITN DIAL
267 ;;LIM SELF CARE PERIT DIALYSIS^607^^LIMITED SELF CARE CAPD
268 ;;HOME/SELF PERIT DIALYSIS TRAIN^608^^HOME/SELF CAPD TRNING
269 ;;PAP TEST^704^^FEMALE SPEC CANCER SCREEN
270 ;;QUIT
271 ;
272CDR ;CDR account change- ex. ;;STOP CODE NAME^NUMBER^CDR # (old)^CDR# (new)
273 ;;QUIT
274 ;
275ACT ;DSS IDs to be reactivated- example ;;NUMBER^
276 ;;571^
277 ;;572^
278 ;;QUIT
279REST ;Change restriction - ;;STOP CODE NAME^NUMBER^REST TYPE^RES DATE^OLD
280 ;;RVOEC INDIVIDUAL^571^P^10/1/2006^
281 ;;RVOEC GROUP^572^P^10/1/2006^
282 ;;SEND-OUT PROCEDURES RAD^643^S^10/1/2006^
283 ;;PRE-EMP PHYS MILITRY PERSONNEL^691^S^10/1/2006^
284 ;;FEMALE SPEC CANCER SCREEN^704^P^10/1/2006^
285 ;;QUIT
Note: See TracBrowser for help on using the repository browser.