source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SD6USTOP.m@ 913

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1SD6USTOP ;ALB/CAW,GTS,ESD,JAM - Stop Code/DSS Identifier Update 7/19/05
2 ;;5.3;Scheduling;**457**;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 10/1/05]")
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 DA=SDDA,DR="2///@",DIE="^DIC(40.7,"
127 ..D ^DIE,MESA
128 K DR,DA,DIE
129 Q
130 ;
131RESTR ;** Change Restriction Data
132 ;
133 ; SDXX is in format:
134 ; STOP CODE NAME^STOP CODE NUMBER^RESTRICTION TYPE^RESTRICTION DATE
135 ;
136 N SDX,SDXX,SDDA
137 S SDVAR=3
138 D MES^XPDUTL("")
139 D BMES^XPDUTL(">>> Changing Restriction Data in CLINIC STOP File (#40.7)...")
140 F SDX=1:1 K DD,DO,DA S SDXX=$P($T(REST+SDX),";;",2) Q:SDXX="QUIT" D
141 .S SDDA=+$O(^DIC(40.7,"C",$P(SDXX,U,2),0))
142 .I $D(^DIC(40.7,SDDA,0)) D
143 ..S DA=SDDA,DR="5////"_$P(SDXX,U,3)_";6///"_$P(SDXX,U,4),DIE="^DIC(40.7,"
144 ..D ^DIE,MESR
145 K DIE,DR,DA,X
146 Q
147 ;
148MESS ;** Add message
149 N ECXADMSG
150 I +$G(SDVAR) D HDR(SDVAR)
151 D MES^XPDUTL(" ")
152 S ECXADMSG="Added: "_$P(SDXX,"^",2)_" "_$P(SDXX,"^")
153 I $P(SDXX,"^",5)'="" S ECXADMSG=ECXADMSG_" [CDR#: "_$P(SDXX,"^",5)_"]"
154 D MES^XPDUTL(ECXADMSG)
155 I $P(SDXX,"^",3)'="" S ECXADMSG=" Restricted Type: "_$P(SDXX,"^",3)_" Restricted Date: "_$P(SDXX,"^",4)
156 D MES^XPDUTL(ECXADMSG)
157 K SDVAR
158 Q
159 ;
160MESSEX ;** Display message if stop code already exists
161 N ECXADMSG
162 I +$G(SDVAR) D HDR(SDVAR)
163 D MES^XPDUTL(" ")
164 S ECXADMSG=" "_$P(SDXX,"^",2)_" "_$P(SDXX,"^")_" already exists."
165 D MES^XPDUTL(ECXADMSG)
166 K SDVAR
167 Q
168 ;
169MESI(SDEXDT) ;** Inactivate message
170 ;
171 ; Parameter:
172 ; SDEXDT - Date inactivation affective (External Format)
173 ;
174 N SDINMSG
175 I +$G(SDVAR) D HDR(SDVAR)
176 I $G(SDEXDT)="" S SDEXDT="UNKNOWN"
177 D MES^XPDUTL(" ")
178 S SDINMSG="Inactivated: "_+SDXX_" "_$P($G(^DIC(40.7,SDDA,0)),"^")_" as of "_SDEXDT
179 D MES^XPDUTL(SDINMSG)
180 K SDVAR
181 Q
182 ;
183MESA ;** Reactivate message
184 ;
185 N SDACMSG
186 I +$G(SDVAR) D HDR(SDVAR)
187 D MES^XPDUTL(" ")
188 S SDACMSG="Reactivated: "_+SDXX_" "_$P($G(^DIC(40.7,SDDA,0)),"^")
189 D MES^XPDUTL(SDACMSG)
190 K SDVAR
191 Q
192 ;
193MESC ;** Change message
194 N SDCMSG,SDCMSG1
195 I +$G(SDVAR) D HDR(SDVAR)
196 D MES^XPDUTL(" ")
197 S SDCMSG="Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)
198 S SDCMSG1=" to: "_$P(SDXX,U,2)_" "_$P(SDXX,U,4)
199 D MES^XPDUTL(SDCMSG)
200 D MES^XPDUTL(SDCMSG1)
201 K SDVAR
202 Q
203 ;
204MESN ;** Change number
205 N SDNMSG,SDNMSG1
206 I +$G(SDVAR) D HDR(SDVAR)
207 D MES^XPDUTL(" ")
208 S SDNMSG=" Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)
209 S SDNMSG1=" : "_$P(SDXX,U,3)_" Date: "_$P(SDXX,U,5)
210 D MES^XPDUTL(SDNMSG)
211 D MES^XPDUTL(SDNMSG1)
212 K SDVAR
213 Q
214MESR ;** Restricting Stop Code
215 N SDNMSG,SDNMSG1
216 I +$G(SDVAR) D HDR(SDVAR)
217 D MES^XPDUTL(" ")
218 S SDNMSG="Changed: "_$P(SDXX,U,2)_" "_$P(SDXX,U)_" "_$P(SDXX,U,5)_" "_$P(SDXX,U,6)
219 S SDNMSG1=" to: "_$P(SDXX,U,3)_" "_$P(SDXX,U,4)
220 D MES^XPDUTL(SDNMSG)
221 D MES^XPDUTL(SDNMSG1)
222 K SDVAR
223 Q
224 ;
225HDR(SDVAR) ;- Header
226 Q:'$G(SDVAR)
227 N SDHDR
228 S SDHDR=$P($T(@("HDR"_SDVAR)),";;",2)
229 D BMES^XPDUTL(SDHDR)
230 Q
231 ;
232 ;
233HDR1 ;; Stop Code Name
234 ;
235HDR2 ;; CDR Stop Code Name
236 ;
237HDR3 ;; Stop Code Name Rest. Type Date
238 ;
239NEW ;DSS IDs to add- ex ;;STOP CODE NAME^NUMBER^RESTRICTION TYPE^RESTRICTION DATE^CDR
240 ;;COMMUNITY ADHC FOLLOWUP^191^P^
241 ;;TELEPHONE/BLIND REHAB PROGRAM^229^P^
242 ;;VICTORS^437^P^
243 ;;LOW VISION CARE^439^P^
244 ;;STORE & FORWARD TELEHLTH^694^S^
245 ;;STORE & FWD TELEHLTH SAME STA^695^S^
246 ;;STORE & FWD TELEHLTH DIFF STA^696^S^
247 ;;QUIT
248 ;
249OLD ;DSS IDs to be inactivated- ex. ;;AMIS NUMBER^^INACTIVE DATE
250 ;;161^TRANSITIONAL PHARMACY (Benefit)^10/1/2005
251 ;;655^COMMUNITY NON-VA CARE^10/1/2005
252 ;;657^ASSISTED LIVING VENDOR WORK^10/1/2005
253 ;;660^CHIROPRACTIC CARE OUTSIDE VA^10/1/2005
254 ;;QUIT
255 ;
256CHNG ;DSS ID name changes- example ;;STOP CODE NAME^NUMBER^^NEW NAME
257 ;;COLORECTAL CA SCREEN DIG EXAM^142^^ENTEROSTOMAL WOUND/SKIN CARE
258 ;;PERSIAN GULF READJUST COUNSEL^143^^SLEEP STUDY
259 ;;CCS EVALUATION^371^^CCHT EVALUATION
260 ;;HCHV/HMI^529^^HCHV/HCMI
261 ;;STATE DOMICILIARY HOME DAYS^652^^STATE RES REHAB TX PGRM (RRTP)
262 ;;CARE OF CCS PROGRAM PATIENT^685^^CARE OF CCHT PROGRAM PATIENTS
263 ;;TELEMEDICINE^690^^GENERAL TELEHEALTH REAL TIME
264 ;;TELMD CNSLT SM STA 2ND ONLY^692^^GEN TELEHLTH RT SAME STA
265 ;;TELMD CNSLT NOT SM STA 2NDONLY^693^^GEN TELEHLTH RT DIFF STA
266 ;;INFLUENZA IMMUNIZATION^710^^FLU/PNEUMOCOCCAL VACCINATION
267 ;;DOMICILIARY OUTREACH SERVICES^725^^RRTP OUTREACH SERVICES
268 ;;DOM AFTERCARE - COMMUNITY^726^^RRTP AFTERCARE - COMMUNITY
269 ;;DOMICILIARY AFTERCARE - VA^727^^RRTP AFTERCARE - VA
270 ;;DOMICILIARY ADM SCREENING SVCS^728^^RRTP ADMISSION SCREENING SRVCS
271 ;;TELEPHONE/DOMICILIARY^729^^TELEPHONE - RRTP
272 ;;DOM GENERAL CARE^730^^RRTP - GENERAL CARE
273 ;;QUIT
274 ;
275CDR ;CDR account change- ex. ;;STOP CODE NAME^NUMBER^CDR # (old)^CDR# (new)
276 ;;QUIT
277 ;
278ACT ;DSS IDs to be reactivated- example ;;NUMBER^
279 ;;142^
280 ;;143^
281 ;;QUIT
282REST ;Change restriction - ;;STOP CODE NAME^NUMBER^REST TYPE^RES DATE^OLD
283 ;;ENTEROSTOMAL WOUND/SKIN CARE^142^P^10/1/2005^E
284 ;;SLEEP STUDY^143^S^10/1/2005^E
285 ;;QUIT
Note: See TracBrowser for help on using the repository browser.