source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMV2I.m@ 792

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1PXRMV2I ; SLC/PKR - Version 2.0 init routine. ;11/05/2004
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 Q
4 ;
5 ;===============================================================
6CPCL ;Convert the internal patient cohort logic to the new form that
7 ;includes sex and age.
8 N CPCL,IEN
9 S IEN=0
10 F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
11 . S CPCL=$G(^PXD(811.9,IEN,30))
12 . I CPCL'="" D CPPCLS^PXRMLOGX(IEN,CPCL)
13 . E D BLDPCLS^PXRMLOGX(IEN,"","")
14 Q
15 ;
16 ;===============================================================
17CRXTYPE ;Convert the RXTYPE to the new form.
18 N FI,IND,RXTYPE
19 D BMES^XPDUTL("Converting definition RXTYPES to new form.")
20 S IEN=0
21 F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
22 . S FI=0
23 . F S FI=+$O(^PXD(811.9,IEN,20,FI)) Q:FI=0 D
24 .. S RXTYPE=$P(^PXD(811.9,IEN,20,FI,0),U,13)
25 .. I RXTYPE="B" S $P(^PXD(811.9,IEN,20,FI,0),U,13)="A"
26 D BMES^XPDUTL("Converting term RXTYPES to new form.")
27 S IEN=0
28 F S IEN=+$O(^PXRMD(811.5,IEN)) Q:IEN=0 D
29 . S FI=0
30 . F S FI=+$O(^PXRMD(811.5,IEN,20,FI)) Q:FI=0 D
31 .. S RXTYPE=$P(^PXRMD(811.5,IEN,20,FI,0),U,13)
32 .. I RXTYPE="B" S $P(^PXRMD(811.5,IEN,20,FI,0),U,13)="A"
33 Q
34 ;
35 ;===============================================================
36CSVPE ;Execute the CSV protocol event points.
37 D ICDPE^PXRMCSPE
38 D CPTPE^PXRMCSPE
39 Q
40 ;
41 ;===============================================================
42DELCF ;Delete erroneous computed finding entries.
43 N DA,DIK,NAME
44 S DIK="^PXRMD(811.4,"
45 F NAME="VA-WH MAMMOGRAM REV IN WH PKG","VA-WH PAP SMEAR REV IN WH PKG","VA-WH REVIEW OR RESULT","VA-WH ULTRASOUND","VA-WH ULTRASOUND REVIEW" D
46 . S DA=+$O(^PXRMD(811.4,"B",NAME,"")) Q:DA'>0
47 . D BMES^XPDUTL("Deleting Computed Finding: "_NAME)
48 . D ^DIK
49 Q
50 ;
51 ;===============================================================
52DELDD ;Delete the old data dictionaries.
53 N DIU,TEXT
54 D EN^DDIOL("Removing old data dictionaries.")
55 S DIU(0)=""
56 F DIU=800,801.3,801.41,801.42,801.43,801.45,801.5,801.9,801.95,802.4,810.1,810.2,810.3,810.4,810.5,810.6,810.7,810.8,810.9,811.2,811.3,811.4,811.5,811.6,811.7,811.8,811.9 D
57 . S TEXT=" Deleting data dictionary for file # "_DIU
58 . D EN^DDIOL(TEXT)
59 . D EN^DIU2
60 Q
61 ;
62 ;===============================================================
63EXTRACT ;
64 N DA,DIE,DR,NAME,PERIOD
65 S PERIOD="M1/2005",DIE="^PXRM(810.2,"
66 F NAME="VA-IHD QUERI","VA-MH QUERI" D
67 . S DA=$O(^PXRM(810.2,"B",NAME,"")) Q:DA'>0
68 . S DR="4///^S X=PERIOD" D ^DIE
69 Q
70 ;
71 ;===============================================================
72FFFIX ;Clean up the function finding file at test sites.
73 N DA,DIK,NAME
74 S DIK="^PXRMD(802.4,"
75 F NAME="FND","FI","DUR" D
76 . S DA=+$O(^PXRMD(802.4,"B",NAME,"")) Q:DA'>0
77 . D BMES^XPDUTL("Deleting Function Finding: "_NAME)
78 . D ^DIK
79 Q
80 ;
81 ;===============================================================
82FIXTERM ;
83 N IEN,TEMP0
84 S IEN=0 F S IEN=$O(^PXRMD(811.5,IEN)) Q:IEN'>0 D
85 . S TEMP0=$P($G(^PXRMD(811.5,IEN,0)),U,1,4)
86 . S $P(TEMP0,U,2)="",$P(TEMP0,U,3)=""
87 . S ^PXRMD(811.5,IEN,0)=TEMP0
88 Q
89 ;
90 ;===============================================================
91FOMRD ;Flag all definitions using the old-style MRD.
92 N CPCL,IEN,NAME,NL,XMSUB
93 K ^TMP("PXRMXMZ",$J)
94 S XMSUB="Old-style MRD obsolete"
95 S ^TMP("PXRMXMZ",$J,1,0)="The old-style MRD function is obsolete and will be removed in a subsequent"
96 S ^TMP("PXRMXMZ",$J,2,0)="patch. Please do not use it anymore; use a function finding instead."
97 S ^TMP("PXRMXMZ",$J,3,0)="The following reminder definitions use the old-style MRD function;"
98 S ^TMP("PXRMXMZ",$J,4,0)="please change them to use a function finding."
99 S NL=4
100 S IEN=0
101 F S IEN=+$O(^PXD(811.9,IEN)) Q:IEN=0 D
102 . S CPCL=$G(^PXD(811.9,IEN,30))
103 . I CPCL'["MRD" Q
104 . S NAME=$P(^PXD(811.9,IEN,0),U,1)
105 . S NL=NL+1
106 . S ^TMP("PXRMXMZ",$J,NL,0)=" "
107 . S NL=NL+1
108 . S ^TMP("PXRMXMZ",$J,NL,0)="Reminder: "_NAME_", ien - "_IEN
109 . S NL=NL+1
110 . S ^TMP("PXRMXMZ",$J,NL,0)="Custom cohort logic: "_CPCL
111 I NL=4 K ^TMP("PXRMXMZ",$J,3,0),^TMP("PXRMXMZ",$J,4,0)
112 D SEND^PXRMMSG(XMSUB)
113 Q
114 ;===============================================================
115 ;
116MAIL ;Add remote member to mail group IHD SEND
117 D ADDMBRS^XMXAPIG(DUZ,"IHD SEND","XXX@Q-IHD.MED.VA.GOV")
118 D ADDMBRS^XMXAPIG(DUZ,"IHD","S.HL MS SERVER")
119 D INIT^PXRMGECW
120 Q
121 ;
122 ;===============================================================
123PRE ;
124 D RENAMIR
125 D RENAMTRM
126 D DELCF
127 D FFFIX
128 D DELETE^PXRMV2IL
129 D DELEI^PXRMV2IE
130 D DELDD
131 Q
132 ;
133 ;===============================================================
134POST ;
135 D SVRSN
136 D DELEXB^PXRMV2IE
137 D CNAK^PXRMV2IE
138 D SMEXINS^PXRMV2IE
139 D FOMRD
140 D RTAXEXP
141 D MAIL
142 ;D XPARAMS
143 D CPCL
144 D CEFFDATE^PXRMV2ID
145 D CFDATE^PXRMV2ID
146 D CSVPE
147 D WEB
148 D COND^PXRMV2IC
149 D SFNFTC^PXRMV2IA
150 D DELGEC^PXRMV2IE
151 D EN^PXRMV2IR
152 D CRXTYPE^PXRMV2I
153 D FIXTERM
154 D EXTRACT
155 Q
156 ;
157 ;===============================================================
158RENAMIR ;If the VA-IRAQ &AFGHAN POST-DEPLOY SCREEN reminder exists rename it.
159 N DA,DIE,DR,PXRMINST,TEXT
160 S DA=$O(^PXD(811.9,"B","VA-IRAQ &AFGHAN POST-DEPLOY SCREEN",""))
161 I DA="" Q
162 S TEXT="Renaming reminder VA-IRAQ &AFGHAN POST-DEPLOY SCREEN to VA-IRAQ & AFGHAN POST-DEPLOY SCREEN"
163 D BMES^XPDUTL(TEXT)
164 S DIE=811.9,DR=".01///VA-IRAQ & AFGHAN POST-DEPLOY SCREEN",PXRMINST=1
165 D ^DIE
166 Q
167 ;
168 ;===============================================================
169RENAMTRM ;Rename all national terms so they start with VA-
170 N DA,DIE,DR,IEN,OLDNAME,NEWNAME,X
171 D BMES^XPDUTL("Renaming National Terms:")
172 S IEN=0 F S IEN=$O(^PXRMD(811.5,IEN)) Q:IEN'>0 D
173 . I $P($G(^PXRMD(811.5,IEN,100)),U)'="N" Q
174 . S OLDNAME=$P($G(^PXRMD(811.5,IEN,0)),U,1)
175 . I OLDNAME["VA-" Q
176 . D BMES^XPDUTL("Renaming Term: "_OLDNAME)
177 . S NEWNAME="VA-"_OLDNAME,DIE="^PXRMD(811.5,",DA=IEN,DR=".01///^S X=NEWNAME"
178 .;lock record
179 . L +^PXRMD(811.5,IEN):0 I $T D ^DIE L -^PXRMD(811.5,IEN)
180 S DIE="^PXRMD(811.4,"
181 S DA=$O(^PXRMD(811.4,"B","VA-IRAQ & AFGHAN SEP. DATE",""))
182 I $G(DA)="" Q
183 S DR=".01////VA-DISCHARGE DATE" D ^DIE
184 Q
185 ;===============================================================
186RTAXEXP ;Rebuild all taxonomy expansions.
187 N ALOW,AHIGH,FILENUM,HIGH,LOW,IEN,IND,TEMP,TEXT,X,X1,X2
188 S (X1,X2)="TAX"
189 D BMES^XPDUTL("Rebuilding taxonomy expansions and setting adjacent values.")
190 S IEN=0
191 F S IEN=+$O(^PXD(811.2,IEN)) Q:IEN=0 D
192 . S TEXT=" Working on taxonomy "_IEN
193 . D BMES^XPDUTL(TEXT)
194 . D DELEXTL^PXRMBXTL(IEN)
195 . D EXPAND^PXRMBXTL(IEN,"")
196 . F FILENUM=80,80.1,81 D
197 .. S IND=0
198 .. F S IND=+$O(^PXD(811.2,IEN,FILENUM,IND)) Q:IND=0 D
199 ... S TEMP=^PXD(811.2,IEN,FILENUM,IND,0)
200 ... S LOW=$P(TEMP,U,1),HIGH=$P(TEMP,U,2)
201 ... S ALOW=$S(FILENUM=80:$$PREV^ICDAPIU(LOW),FILENUM=80.1:$$PREV^ICDAPIU(LOW),FILENUM=81:$$PREV^ICPTAPIU(LOW))
202 ... S AHIGH=$S(FILENUM=80:$$NEXT^ICDAPIU(HIGH),FILENUM=80.1:$$NEXT^ICDAPIU(HIGH),FILENUM=81:$$NEXT^ICPTAPIU(HIGH))
203 ... S $P(^PXD(811.2,IEN,FILENUM,IND,0),U,3,4)=ALOW_U_AHIGH
204 D BMES^XPDUTL(" DONE")
205 Q
206 ;
207 ;===============================================================
208SENODE ;Rebuild the "E" index on definitions and terms.
209 ;This code probably does not need to be run, keep it in case there
210 ;is a problem at test sites.
211 N DA,DIK,IND,TEXT
212 S TEXT="Rebuilding E index for reminder definitions"
213 D BMES^XPDUTL(TEXT)
214 S IND=0
215 F S IND=+$O(^PXD(811.9,IND)) Q:IND=0 D
216 . S TEXT=" Working on reminder "_IND
217 . D BMES^XPDUTL(TEXT)
218 . K ^PXD(811.9,IND,20,"E")
219 . S DIK="^PXD(811.9,"_IND_",20,"
220 . S DA(1)=IND,DIK(1)=".01^E"
221 . D ENALL^DIK
222 S TEXT="Rebuilding E index for terms"
223 D BMES^XPDUTL(TEXT)
224 S IND=0
225 F S IND=+$O(^PXRMD(811.5,IND)) Q:IND=0 D
226 . S TEXT=" Working on term "_IND
227 . D BMES^XPDUTL(TEXT)
228 . K ^PXRMD(811.5,IND,20,"E")
229 . S DIK="^PXRMD(811.5,"_IND_",20,"
230 . S DA(1)=IND,DIK(1)=".01^E"
231 . D ENALL^DIK
232 Q
233 ;
234 ;===============================================================
235SVRSN ;Set the package version number.
236 N VRSN
237 S VRSN=$P($T(+2^PXRM),";",3)
238 S ^PXRM(800,1,"VERSION")=VRSN
239 Q
240 ;
241 ;===============================================================
242WEB ;Change the default web page from the prevention handbook
243 ;to the oqp page.
244 N IND,NEW,OLD
245 S OLD="http://vaww.va.gov/publ/direc/health/handbook/1120-2hk.htm"
246 S NEW="http://www.oqp.med.va.gov/cpg/cpg.htm"
247 S IND=$O(^PXRM(800,1,1,"B",$E(OLD,1,30),""))
248 I IND="" Q
249 K ^PXRM(800,1,1,IND,0)
250 K ^PXRM(800,1,1,"B",$E(OLD,1,30),IND)
251 S ^PXRM(800,1,1,"B",$E(NEW,1,30),IND)=""
252 S $P(^PXRM(800,1,1,IND,0),U,1)=NEW
253 S $P(^PXRM(800,1,1,IND,0),U,2)="OQP Clinical Guidelines"
254 Q
255 ;
256 ;===============================================================
257XPARAMS ;Set the next extract date in the IHD QUERI parameters
258 ;
259 ;Site must schedule extract with XU OPTION SCHEDULE option when ready
260 N IEN,LUVALUE
261 ;
262 ;IHD QUERI
263 S LUVALUE(1)="VA-IHD QUERI"
264 S IEN=+$$FIND1^DIC(810.2,"","KU",.LUVALUE)
265 ;Update next extract period as current period
266 I IEN S $P(^PXRM(810.2,IEN,0),U,6)=$$PERIOD^PXRMEUT("M")
267 ;
268 ;MH QUERI
269 S LUVALUE(1)="VA-MH QUERI"
270 S IEN=+$$FIND1^DIC(810.2,"","KU",.LUVALUE)
271 ;Update next extract period as current period
272 I IEN S $P(^PXRM(810.2,IEN,0),U,6)=$$PERIOD^PXRMEUT("M")
273 ;
274 Q
275 ;
Note: See TracBrowser for help on using the repository browser.