source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SD132PT.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1SD132PT ;ALB/MJK - Patch SD*5.3*132 Post-Init Routine ; 11/5/97
2 ;;5.3;Scheduling;**132**;Aug 13, 1993
3 ;
4EN ; --- main entry point
5 S U="^"
6 D BMES^XPDUTL("Post-Init Started...")
7 ;
8 ; -- main driver calls
9 D MAS,HL,LOG,ACG,AG,OVER
10 ;
11 D BMES^XPDUTL("Post-Init Finished.")
12 Q
13 ;
14MAS ; -- delete MAS PARAMETERS (#43) fields and related data
15 N SDARY
16 ;
17 D BMES^XPDUTL(" >>> Deleting MAS PARAMETERS (#43) fields...")
18 ;
19 ; -- get fields to delete
20 D BUILDR(43,.SDARY)
21 ;
22 IF '$O(SDARY(0)) G MASQ
23 ;
24 ; -- delete data
25 N SDFDA,SDFLD
26 S SDFLD=0
27 F S SDFLD=$O(SDARY(SDFLD)) Q:'SDFLD D
28 . S SDFDA(43,"1,",SDFLD)="@"
29 D FILE^DIE("S","SDFDA")
30 ;
31 ; -- delete dds
32 D DELDD(43)
33MASQ D MES^XPDUTL(" >>> Done.")
34 Q
35 ;
36HL ; -- delete HOSPITIAL LOCATION (#44) fields and related data
37 N SDARY
38 ;
39 D BMES^XPDUTL(" >>> Deleting HOSPITAL LOCATION (#44) fields...")
40 ;
41 ; -- get fields to delete
42 D BUILDR(44,.SDARY)
43 ;
44 IF '$O(SDARY(0)) G HLQ
45 ;
46 ; -- delete data
47 S SDIEN=0
48 F S SDIEN=$O(^SC(SDIEN)) Q:'SDIEN D
49 . N SDFDA,SDFLD
50 . S SDFLD=0
51 . F S SDFLD=$O(SDARY(SDFLD)) Q:'SDFLD D
52 . . S SDFDA(44,SDIEN_",",SDFLD)="@"
53 . D FILE^DIE("S","SDFDA")
54 ;
55 ; -- delete dds
56 D DELDD(44)
57HLQ D MES^XPDUTL(" >>> Done.")
58 Q
59 ;
60LOG ; -- delete APPOINTMENT STATUS UPDATE LOG (#409.65) fields and related data
61 N SDARY
62 ;
63 D BMES^XPDUTL(" >>> Deleting APPPOINT STATUS UPDATE LOG (409.65) fields...")
64 ;
65 ; -- get fields to delete
66 D BUILDR(409.65,.SDARY)
67 ;
68 IF '$O(SDARY(0)) G LOGQ
69 ;
70 ; -- delete data
71 S SDIEN=0
72 F S SDIEN=$O(^SDD(409.65,SDIEN)) Q:'SDIEN D
73 . N SDFDA,SDFLD
74 . S SDFLD=0
75 . F S SDFLD=$O(SDARY(SDFLD)) Q:'SDFLD D
76 . . S SDFDA(409.65,SDIEN_",",SDFLD)="@"
77 . D FILE^DIE("S","SDFDA")
78 ;
79 ; -- delete dds
80 D DELDD(409.65)
81LOGQ D MES^XPDUTL(" >>> Done.")
82 Q
83 ;
84ACG ; -- update new computer generated appt type related fields in
85 ; OUTPATIENT ENCOUNTER (#409.68) with data for ^SDV data
86 ;
87 D BMES^XPDUTL(" >>> Setting 'ACG' cross references...")
88 ;
89 ; -- scan ^SDV("ACG") for records
90 N SDATE,SDCS,SDCS0,SDOE,SDOE0,SDREASON,SDAPPT,SDCG,DR,DA,DIE
91 S SDATE=0
92 F S SDATE=$O(^SDV("ACG",SDATE)) Q:'SDATE D
93 . S SDCS=0 F S SDCS=$O(^SDV("ACG",SDATE,SDCS)) Q:'SDCS D
94 . . S SDCS0=$G(^SDV(SDATE,"CS",SDCS,0))
95 . . S SDCG=+$G(^SDV(SDATE,"CS",SDCS,1))
96 . . S SDAPPT=$P(SDCS0,U,5)
97 . . S SDREASON=$P(SDCS0,U,6)
98 . . S SDOE=+$P(SDCS0,U,8)
99 . . S SDOE0=$G(^SCE(SDOE,0))
100 . . IF SDAPPT=10,SDOE,$P(SDOE0,U,10)=10,$G(^SCE(SDOE,"CG"))="" D
101 . . . S DR=".1////10"
102 . . . IF SDCG S DR=DR_";201////1"
103 . . . IF SDREASON S DR=DR_";202////"_SDREASON
104 . . . S DIE="^SCE(",DA=SDOE D ^DIE
105 ;
106 D MES^XPDUTL(" >>> Done.")
107 Q
108 ;
109AG ; -- queue job to set 'AG' xref and related fields
110 N SDUZ,ZTRTN,ZTIO,ZTDESC,ZTDTH,ZTSAVE,ZTSK
111 S SDUZ=$G(DUZ)
112 D BMES^XPDUTL(" >>> Queuing task to set 'AG' cross reference.")
113 ; -- disable option
114 D OUT^XPDMENU("SDACS CGSCLIST","AG Cross Reference Being Set")
115 D MES^XPDUTL(" -> Option 'SDACS CGSCLIST' has been placed out of service.")
116 ;
117 ; -- queue task
118 S ZTIO=""
119 S ZTRTN="AGQUE^SD132PT"
120 S ZTDESC="Setting 'AG' Cross Reference"
121 S ZTDTH=$$NOW^XLFDT()
122 F X="SDUZ" S ZTSAVE(X)=""
123 D ^%ZTLOAD
124 D:$D(ZTSK) MES^XPDUTL(" -> Task: #"_ZTSK)
125 D MES^XPDUTL(" >>> Done.")
126 Q
127 ;
128AGQUE ; -- TaskMan entry point to queue 'AG' setting
129 ;
130 N SDATE,SDCS,SDCS0,SDOE,SDREASON,SDCG,DR,DA,DIE,SDSTOP,SDTOT,SDBEG,SDEND
131 ;
132 S SDTOT=0
133 S SDBEG=$$NOW^XLFDT()
134 ;
135 ; -- scan ^SDV("AG") for records
136 S SDATE=0
137 F S SDATE=$O(^SDV("AG",SDATE)) Q:'SDATE D S SDSTOP=$$S^%ZTLOAD Q:SDSTOP
138 . S SDCS=0 F S SDCS=$O(^SDV("AG",SDATE,SDCS)) Q:'SDCS D
139 . . S SDCS0=$G(^SDV(SDATE,"CS",SDCS,0))
140 . . S SDCG=+$G(^SDV(SDATE,"CS",SDCS,1))
141 . . S SDOE=+$P(SDCS0,U,8)
142 . . S SDREASON=$P(SDCS0,U,6)
143 . . IF SDOE,$G(^SCE(SDOE,0))]"",$G(^SCE(SDOE,"CG"))="",SDCG D
144 . . . S DR="201////1"
145 . . . IF SDREASON S DR=DR_";202////"_SDREASON
146 . . . S DIE="^SCE(",DA=SDOE D ^DIE
147 . . . S SDTOT=SDTOT+1
148 ;
149 S SDEND=$$NOW^XLFDT()
150 ; -- send bulletin and enable option
151 D BULL
152 Q
153 ;
154BULL ; -- send message indicating 'AG' xref is set and option enabled
155 N SDTEXT,SDCNT,XMSUB,XMN,XMTEXT,XMDUZ,XMY
156 S SDCNT=0
157 ;
158 D LINE("")
159 D LINE(" >>> Task Started: "_$$FMTE^XLFDT(SDBEG))
160 D LINE(" Finished: "_$$FMTE^XLFDT(SDEND))
161 D LINE("")
162 ;
163 ; -- build text
164 IF SDSTOP D
165 . D LINE(" >>> Task stopped by user. <<<")
166 ELSE D
167 . ; -- enable option
168 . D OUT^XPDMENU("SDACS CGSCLIST","")
169 . ;
170 . ; -- build text
171 . D LINE(" >>> Task Completed.")
172 . D LINE("")
173 . D LINE(" >>> Option 'SDACS CGSCLIST' is back in service.")
174 ;
175 D LINE("")
176 D LINE(" >>> "_SDTOT_" Records processed.")
177 ; -- set xm vars and send message
178 S XMSUB="Setting of 'AG' Cross Reference Task Information"
179 S XMN=0
180 S XMTEXT="SDTEXT("
181 S XMDUZ=.5
182 S XMY(SDUZ)=""
183 D ^XMD
184 Q
185 ;
186OVER ; -- post override flag information
187 N SDPKG,SDCNT
188 ;
189 D BMES^XPDUTL(" >>> Package Override Flag Information")
190 ;
191 S SDPKG="A",SDCNT=0
192 F S SDPKG=$O(^XTMP("SD*5.3*132 OVERRIDE FLAGS",SDPKG)) Q:SDPKG="" D
193 . D MES^XPDUTL(" -> Override flag set for '"_SDPKG_"'")
194 . S SDCNT=SDCNT+1
195 ;
196 IF 'SDCNT D MES^XPDUTL(" -> No package override flags set.")
197 D MES^XPDUTL(" >>> Done.")
198 Q
199 ;
200LINE(TEXT) ; -- add line of text
201 S SDCNT=SDCNT+1
202 S SDTEXT(SDCNT)=TEXT
203 Q
204 ;
205BUILDR(SDD,SDARY) ; -- build array of fields to delete
206 N SDI,SDX,SDENDFLG
207 S SDENDFLG="$$END$$"
208 ;
209 F SDI=1:1 S SDX=$P($T(FLDS+SDI),";;",2) Q:SDX=SDENDFLG D
210 . N SDFILE,SDFLD
211 . S SDFILE=+SDX
212 . S SDFLD=+$P(SDX,U,2)
213 . S SDNAME=$P(SDX,U,3)
214 . IF SDD=SDFILE,$$LABEL(SDFILE,SDFLD)=SDNAME D
215 . . S SDARY(SDFLD)=""
216 Q
217 ;
218DELDD(SDD) ; -- tool to delete fields dd
219 ; -- delete dd
220 N SDI,SDX,SDENDFLG,SDCNT
221 S SDENDFLG="$$END$$"
222 S SDCNT=0
223 ;
224 ; -- delete dds
225 F SDI=1:1 S SDX=$P($T(FLDS+SDI),";;",2) Q:SDX=SDENDFLG D
226 . N SDFILE,SDFLD,SDNAME
227 . S SDFILE=+SDX
228 . S SDFLD=+$P(SDX,U,2)
229 . S SDNAME=$P(SDX,U,3)
230 . ;
231 . ; -- make sure field is not reused before deleting
232 . IF SDD=SDFILE,$$LABEL(SDFILE,SDFLD)=SDNAME D
233 . . N DIK,DA
234 . . S DIK="^DD("_SDD_",",DA=SDFLD,DA(1)=SDD D ^DIK
235 . . D MSG(SDFLD,SDNAME)
236 . . S SDCNT=SDCNT+1
237 ;
238 IF 'SDCNT D MES^XPDUTL(" -> Fields already deleted.")
239 Q
240 ;
241LABEL(SDFILE,SDFLD) ; -- get label if not deleted
242 N SDY
243 D FIELD^DID(SDFILE,SDFLD,"N","LABEL","SDY")
244 Q $G(SDY("LABEL"))
245 ;
246MSG(SDFLD,SDNAME) ; -- tell user (use kids call??)
247 D MES^XPDUTL(" -> Field '"_SDFLD_" - "_SDNAME_"' deleted.")
248 Q
249 ;
250FLDS ; -- fields to be deleted [ file# ^ field# ^ field label ]
251 ;;43^201^SPEC SURVEY DISP LAST RUN
252 ;;43^202^OPC FILE LAST RUN
253 ;;43^203^OPC TRANSMISSION LAST RUN
254 ;;43^204^GENERATING OPC FILE NOW?
255 ;;43^206^AMB PROC INITIALIZATION DATE
256 ;;43^206.1^OPC VLR DATE
257 ;;43^206.2^OPC MT INCOME DATE
258 ;;43^207^OPC STOP CODE CONVERSION DATE
259 ;;43^208^OPC GENERATION START DATE
260 ;;43^209^OPC GENERATION END DATE
261 ;;43^214^GEN OPC W/APPT STATUS UPDATE
262 ;;43^221^STOP CODE MAIL GROUP
263 ;;43^218^OPC FY93 FORMAT DATE
264 ;;43^219^ASK PROVIDER ON DISPOSITION
265 ;;43^220^ASK DIAGNOSIS ON DISPOSITION
266 ;;43^222^OPC FY94 FORMAT DATE
267 ;;43^225^OPC FY95 FORMAT DATE
268 ;;44^25^PROCEDURE CHECK-OFF SHEET
269 ;;44^26^ASK PROVIDER AT CHECK OUT
270 ;;44^27^ASK DIAGNOSIS AT CHECK OUT
271 ;;44^28^ASK STOP CODES AT CHECK OUT
272 ;;409.65^.06^OPC LAST GENERATED
273 ;;409.65^.07^OPC LAST TRANSMITTED
274 ;;409.65^.08^OPC LAST GENERATED BY
275 ;;409.65^.09^OPC LAST TRANSMITTED BY
276 ;;$$END$$
Note: See TracBrowser for help on using the repository browser.