source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMP4I.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1PXRMP4I ; SLC/PKR - PXRM*2.0*4 init routine. ;07/24/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 Q
4 ;
5 ;==========================================
6CFTINC(IEN) ;Return true if the computed finding should be included
7 ;in the build.
8 N NAME
9 S NAME=$P(^PXRMD(811.4,IEN,0),U,1)
10 I NAME="VA-APPOINTMENTS FOR A PATIENT" Q 1
11 I NAME="VA-DATE OF BIRTH" Q 1
12 I NAME="VA-DATE OF DEATH" Q 1
13 I NAME="VA-HOSPITAL DISCHARGE DATE" Q 1
14 I NAME="VA-PATIENT TYPE" Q 1
15 I NAME="VA-PATIENTS WITH APPOINTMENTS" Q 1
16 I NAME="VA-PROGRESS NOTE" Q 1
17 I NAME="VA-PTF HOSPITAL DISCHARGE DATE" Q 1
18 I NAME="VA-REMINDER DEFINITION" Q 1
19 I NAME="VA-TREATING FACILITY LIST" Q 1
20 Q 0
21 ;
22 ;==========================================
23DELDD ;Delete the old data dictionaries.
24 N DIU,TEXT
25 D EN^DDIOL("Removing old data dictionaries.")
26 S DIU(0)=""
27 F DIU=800,801.41,801.5,801.55,802.4,810.1,810.2,810.3,810.4,810.5,810.7,810.8,810.9,811.5,811.9 D
28 . S TEXT=" Deleting data dictionary for file # "_DIU
29 . D EN^DDIOL(TEXT)
30 . D EN^DIU2
31 Q
32 ;
33 ;==========================================
34DELEI ;If the Exchange File entry already exists delete it.
35 N ARRAY,IC,IND,LIST,LUVALUE,NUM
36 D EXARRAY^PXRMP4IW(1,.ARRAY)
37 S IC=0
38 F S IC=$O(ARRAY(IC)) Q:'IC D
39 . S LUVALUE(1)=ARRAY(IC,1)
40 . D FIND^DIC(811.8,"","","U",.LUVALUE,"","","","","LIST")
41 . I '$D(LIST) Q
42 . S NUM=$P(LIST("DILIST",0),U,1)
43 . I NUM'=0 D
44 .. F IND=1:1:NUM D
45 ... N DA,DIK
46 ... S DIK="^PXD(811.8,"
47 ... S DA=LIST("DILIST",2,IND)
48 ... D ^DIK
49 Q
50 ;
51 ;==========================================
52DELLT ;Delete list templates
53 N IEN,IND,LIST,TEMP0
54 D LTL^PXRMP4IW(.LIST)
55 S IND=0
56 F S IND=$O(LIST(IND)) Q:IND="" D
57 . S IEN=$O(^SD(409.61,"B",LIST(IND),"")) Q:IEN=""
58 . S TEMP0=$G(^SD(409.61,IEN,0))
59 . K ^SD(409.61,IEN)
60 . S ^SD(409.61,IEN,0)=TEMP0
61 Q
62 ;
63 ;==========================================
64EXFINC(Y) ;Return a 1 if the Exchange file entry is in the list to
65 ;include in the build. This is used in the build to determine which
66 ;entries to include.
67 N EXARRAY,FOUND,IEN,IC,LUVALUE
68 D EXARRAY^PXRMP4IW(1,.EXARRAY)
69 S FOUND=0
70 S IC=0
71 F S IC=+$O(EXARRAY(IC)) Q:(IC=0)!(FOUND) D
72 . M LUVALUE=EXARRAY(IC)
73 . S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
74 . I IEN=Y S FOUND=1 Q
75 Q FOUND
76 ;
77 ;==========================================
78OVLCHECK ;Check existing reminder definitions for baseline age range
79 ;overlaps.
80 D BMES^XPDUTL("Checking reminder definitions for baseline age range overlap")
81 N DA,TEST
82 S DA=0
83 F S DA=+$O(^PXD(811.9,DA)) Q:DA=0 D
84 . S TEST=$$OVLAP^PXRMAGE
85 . I TEST W !,"Reminder ",$P(^PXD(811.9,DA,0),U,1),"; IEN= ",DA,!
86 Q
87 ;
88 ;==========================================
89PRE ;
90 D SLLC
91 D DELDD
92 D DELEI
93 D DELLT
94 D RELTEMP^PXRMP4I1
95 D REOPTS^PXRMP4I1
96 D REPROTS^PXRMP4I1
97 N PXRMINST S PXRMINST=1
98 D RENAME^PXRMP4I1(811.4,"VA-DISCHARGE DATE","VA-LAST SERVICE SEPARATION DATE")
99 Q
100 ;
101 ;==========================================
102POST ;
103 D FORMAT^PXRMDISC
104 D OVLCHECK
105 D RLLC
106 D RTAXEXP
107 D RRSVC
108 D SPLT
109 D SAUTOP
110 D SLABENOD^PXRMP4I1
111 D SMEXINS
112 D POST^PXRMGECL
113 D MHVWEB^PXRMP4IW
114 D GECDIA^PXRMP4I1
115 D SNEXTIP^PXRMP4I1
116 Q
117 ;
118 ;==========================================
119RLLC ;Restore the Location List classes to the new location and delete
120 ;the old location.
121 N CLASS,IEN,TEMP
122 D BMES^XPDUTL("Restoring Location List Classes")
123 S IEN=0
124 F S IEN=+$O(^XTMP("PXRMLLCS",IEN)) Q:IEN=0 D
125 . S CLASS=^XTMP("PXRMLLCS",IEN)
126 . S $P(^PXRMD(810.9,IEN,100),U,1)=CLASS
127 S IEN=0
128 F S IEN=+$O(^PXRMD(810.9,IEN)) Q:IEN=0 D
129 . S CLASS=$P(^PXRMD(810.9,IEN,100),U,1)
130 . I CLASS="" D
131 .. S TEMP=$P(^PXRMD(810.9,IEN,0),U,2)
132 .. I TEMP'="" S $P(^PXRMD(810.9,IEN,100),U,1)=TEMP
133 .. S CLASS=TEMP
134 . I CLASS'="" D
135 .. S TEMP=^PXRMD(810.9,IEN,0)
136 .. S ^PXRMD(810.9,IEN,0)=$P(TEMP,U,1)
137 Q
138 ;
139 ;==========================================
140RRSVC ;Reformat reminder report template service categories.
141 N IEN,IND,SVCL
142 D BMES^XPDUTL("Reformatting reminder report service categories")
143 S IEN=0
144 F S IEN=+$O(^PXRMPT(810.1,IEN)) Q:IEN=0 D
145 . S SVCL="",IND=0
146 . F S IND=+$O(^PXRMPT(810.1,IEN,8,IND)) Q:IND=0 D
147 .. I SVCL="" S SVCL=^PXRMPT(810.1,IEN,8,IND,0)
148 .. E S SVCL=SVCL_","_^PXRMPT(810.1,IEN,8,IND,0)
149 . I SVCL="" Q
150 . K ^PXRMPT(810.1,IEN,8)
151 . S ^PXRMPT(810.1,IEN,8)=SVCL
152 Q
153 ;
154 ;==========================================
155RSPC ;Restore the Sponsor classes to the new location.
156 N CLASS,IEN
157 D BMES^XPDUTL("Restoring Sponsor Classes")
158 S IEN=0
159 F S IEN=+$O(^XTMP("PXRMSPCS",IEN)) Q:IEN=0 D
160 . S CLASS=^XTMP("PXRMSPCS",IEN)
161 . S $P(^PXRMD(811.6,IEN,100),U,1)=CLASS
162 Q
163 ;
164 ;==========================================
165RTAXEXP ;Rebuild all taxonomy expansions.
166 N ALOW,AHIGH,FILENUM,HIGH,LOW,IEN,IND,TEMP,TEXT,X,X1,X2
167 S (X1,X2)="TAX"
168 D BMES^XPDUTL("Rebuilding taxonomy expansions and setting adjacent values.")
169 S IEN=$O(^PXD(811.2,"B","VA-WH BILATERAL MASTECTOMY",""))
170 S TEXT=" Working on taxonomy "_IEN
171 D BMES^XPDUTL(TEXT)
172 D DELEXTL^PXRMBXTL(IEN)
173 D EXPAND^PXRMBXTL(IEN,"")
174 F FILENUM=80,80.1,81 D
175 . S IND=0
176 . F S IND=+$O(^PXD(811.2,IEN,FILENUM,IND)) Q:IND=0 D
177 .. S TEMP=^PXD(811.2,IEN,FILENUM,IND,0)
178 .. S LOW=$P(TEMP,U,1),HIGH=$P(TEMP,U,2)
179 .. S ALOW=$S(FILENUM=80:$$PREV^ICDAPIU(LOW),FILENUM=80.1:$$PREV^ICDAPIU(LOW),FILENUM=81:$$PREV^ICPTAPIU(LOW))
180 .. S AHIGH=$S(FILENUM=80:$$NEXT^ICDAPIU(HIGH),FILENUM=80.1:$$NEXT^ICDAPIU(HIGH),FILENUM=81:$$NEXT^ICPTAPIU(HIGH))
181 .. S $P(^PXD(811.2,IEN,FILENUM,IND,0),U,3,4)=ALOW_U_AHIGH
182 D BMES^XPDUTL(" DONE")
183 Q
184 ;
185 ;==========================================
186SAUTOP ;Make sure the class field is "N" for national Extract Summary and
187 ;Reminder Patient List entries. For these entries set the field
188 ;AUTOMATICALLY PURGE to true. Set INCLUDE PCMM INSTITUTION to true
189 ;for all VA-*IHD QUERI and VA-*MH QUERI lists.
190 D BMES^XPDUTL("Setting AUTOMATICALLY PURGE for national Extract Summaries and Patient Lists")
191 N IEN,NAME
192 S IEN=0 F S IEN=$O(^PXRMXT(810.3,IEN)) Q:IEN'>0 D
193 . S NAME=$P($G(^PXRMXT(810.3,IEN,0)),U)
194 . I NAME'["VA-",NAME'["LREPI" Q
195 . S $P(^PXRMXT(810.3,IEN,100),U)="N"
196 . S ^PXRMXT(810.3,IEN,50)=1
197 ;
198 S IEN=0 F S IEN=$O(^PXRMXP(810.5,IEN)) Q:IEN'>0 D
199 . S NAME=$P($G(^PXRMXP(810.5,IEN,0)),U)
200 . I NAME["QUERI" S $P(^PXRMXP(810.5,IEN,0),U,10)=1
201 . I NAME'["VA-",NAME'["LREPI" Q
202 . S $P(^PXRMXP(810.5,IEN,100),U)="N"
203 . S ^PXRMXP(810.5,IEN,50)=1
204 Q
205 ;
206 ;==========================================
207SLLC ;Save the Location List classes.
208 N CDATE,CLASS,IEN,PDATE
209 D BMES^XPDUTL("Saving Location List Classes")
210 S CDATE=$$NOW^XLFDT
211 S PDATE=$$FMADD^XLFDT(CDATE,30)
212 S ^XTMP("PXRMLLCS",0)=PDATE_U_CDATE_U_"LOCATION LIST CLASSES"
213 S IEN=0
214 F S IEN=+$O(^PXRMD(810.9,IEN)) Q:IEN=0 D
215 . S CLASS=$P(^PXRMD(810.9,IEN,0),U,2)
216 . I CLASS'="" S ^XTMP("PXRMLLCS",IEN)=CLASS
217 Q
218 ;
219 ;==========================================
220SMEXINS ;Silent mode install.
221 N EXARRAY,IC,IEN,LUVALUE,PXRMINST,TEXT
222 S PXRMINST=1
223 D EXARRAY^PXRMP4IW(1,.EXARRAY)
224 S IC=0
225 F S IC=$O(EXARRAY(IC)) Q:'IC D
226 .M LUVALUE=EXARRAY(IC)
227 .S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
228 .I IEN'=0 D
229 .. N TEXT
230 .. I LUVALUE(1)["PARAMETER" S TEXT="Installing entry "_LUVALUE(1)
231 .. E S TEXT="Installing reminder "_LUVALUE(1)
232 .. D BMES^XPDUTL(TEXT)
233 .. D INSTALL^PXRMEXSI(IEN,1)
234 Q
235 ;
236 ;==========================================
237SPLT ;Set the Patient List Type field. In the original version the list
238 ;was private only if the creator was stored. In the new version the
239 ;TYPE field will be used to mark a list as public or private and
240 ;the creator will be stored for all lists.
241 N CREATOR,IEN,TYPE
242 D BMES^XPDUTL("Setting Patient List TYPE field")
243 S IEN=0
244 F S IEN=+$O(^PXRMXP(810.5,IEN)) Q:IEN=0 D
245 . S CREATOR=$P(^PXRMXP(810.5,IEN,0),U,7)
246 . S TYPE=$S(CREATOR="":"PUB",1:"PVT")
247 . S $P(^PXRMXP(810.5,IEN,0),U,8)=TYPE
248 Q
249 ;
250 ;==========================================
251SRSVC ;Save reminder report template service categories.
252 N CDATE,IEN,IND,PDATE,SVCL
253 D BMES^XPDUTL("Saving reminder report service categories")
254 S CDATE=$$NOW^XLFDT
255 S PDATE=$$FMADD^XLFDT(CDATE,30)
256 S ^XTMP("PXRMRSVC",0)=PDATE_U_CDATE_U_"SERVICE CATEGORIES"
257 S IEN=0
258 F S IEN=+$O(^PXRMPT(810.1,IEN)) Q:IEN=0 D
259 . S SVCL="",IND=0
260 . F S IND=+$O(^PXRMPT(810.1,IEN,8,IND)) Q:IND=0 D
261 .. I SVCL="" S SVCL=^PXRMPT(810.1,IEN,8,IND,0)
262 .. E S SVCL=SVCL_","_^PXRMPT(810.1,IEN,8,IND,0)
263 . I SVCL'="" S ^XTMP("PXRMRSVC",IEN)=SVCL
264 Q
265 ;
266 ;==========================================
267SSPC ;Save the Sponsor classes.
268 N CDATE,CLASS,IEN,PDATE
269 D BMES^XPDUTL("Saving Sponsor Classes")
270 S CDATE=$$NOW^XLFDT
271 S PDATE=$$FMADD^XLFDT(CDATE,30)
272 S ^XTMP("PXRMSPCS",0)=PDATE_U_CDATE_U_"SPONSOR CLASSES"
273 S IEN=0
274 F S IEN=+$O(^PXRMD(811.6,IEN)) Q:IEN=0 D
275 . S CLASS=$P(^PXRMD(811.6,IEN,0),U,2)
276 . S ^XTMP("PXRMSPCS",IEN)=CLASS
277 Q
278 ;
Note: See TracBrowser for help on using the repository browser.