source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIC.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: 7.7 KB
Line 
1PXRMEXIC ; SLC/PKR/PJH - Routines to install repository entry components. ;09/21/2004
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;=================================================
4FILE(PXRMRIEN,EXISTS,IND120,JND120,ACTION,ATTR,NAMECHG) ;Read and process a
5 ;file entry in repository entry PXRMRIEN. IND120 and JND120 are the
6 ;indexes for the component list. ACTION is one of the possible actions.
7 I ACTION="S" Q
8 N DATA,FDA,FDAEND,FDASTART,FIELD,FILENUM
9 N IEN,IENS,IENREND,IENROOT,IENRSTR,IND,INDICES
10 N LINE,MSG,NEW01,PXNAT,PXRMEDOK,PXRMEXCH
11 N SITEIEN,SRCIEN,TEMP,TFDA,TNAME,TOPFNUM,VERSN
12 N WPLCNT,WPTMP
13 ;Set PXRMEDOK so files pointing to sponsors can be installed.
14 ;Set PXRMEXCH so national entries can be installed and prevent
15 ;execution of the input transform for custom logic fields.
16 ;Set PXNAT to allow installation of national (those starting with VA-)
17 ;PCE items.
18 S (PXNAT,PXRMEDOK,PXRMEXCH)=1
19 S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0)
20 S FDASTART=+$P(TEMP,U,2)
21 S FDAEND=+$P(TEMP,U,3)
22 S IENRSTR=+$P(TEMP,U,4)
23 S IENREND=+$P(TEMP,U,5)
24 F IND=FDASTART:1:FDAEND D
25 . S LINE=^PXD(811.8,PXRMRIEN,100,IND,0)
26 . S INDICES=$P(LINE,"~",1)
27 . S DATA=$P(LINE,"~",2)
28 . S FILENUM=$P(INDICES,";",1)
29 . S IENS=$P(INDICES,";",2)
30 . I IND=START S SRCIEN=+IENS
31 . S FIELD=$P(INDICES,";",3)
32 . I LINE["WP-start" D
33 .. S DATA="WPTMP("_IND_","_+FIELD_")"
34 .. S WPLCNT=$P(LINE,"~",3)
35 .. D WORDPROC(PXRMRIEN,.WPTMP,IND,+FIELD,.IND,WPLCNT)
36 . I (IND=START)&((FIELD=.01)!(FIELD=.001)) D
37 ..;Save the top level file number.
38 .. S TOPFNUM=FILENUM
39 ..;If the action is copy let FileMan determine where to put it.
40 .. I ACTION="C" S IENROOT(SRCIEN)=$S($G(PXRMLOWX)=1:$$LOIEN^PXRMEXU5(FILENUM),1:"")
41 ..;
42 ..;If the action is install try to install at the source ien. If
43 ..;an entry already exists at the source ien let FileMan determine
44 ..;where to put it.
45 .. I ACTION="I" D
46 ... S SITEIEN=+$$FIND1^DIC(FILENUM,"","Q","`"_SRCIEN)
47 ... I SITEIEN>0 S IENROOT(SRCIEN)=""
48 ... E S IENROOT(SRCIEN)=$S($G(PXRMLOWX)=1:$$LOIEN^PXRMEXU5(FILENUM),1:SRCIEN)
49 ..;
50 ..;If the action is merge or overwrite get the existing ien.
51 .. I (ACTION="M")!(ACTION="O") D
52 ... S SITEIEN=$$EXISTS^PXRMEXIU(FILENUM,DATA)
53 ... S IENROOT(SRCIEN)=""
54 .;
55 . S FDA(FILENUM,IENS,FIELD)=DATA
56 ;
57 ;Initialize the edit history.
58 D INIEH(TOPFNUM,IENS,.FDA,.WPTMP)
59 ;Build the IENROOT
60 F IND=IENRSTR:1:IENREND D
61 . I IND=0 Q
62 . S TEMP=^PXD(811.8,PXRMRIEN,100,IND,0)
63 . S IENROOT($P(TEMP,U,1))=$P(TEMP,U,2)
64 ;Check for name changes, i.e., the copy action.
65 D NAMECHG(.FDA,.NAMECHG,TOPFNUM)
66 ;Special handling for file 801.41
67 I TOPFNUM=801.41 D Q:PXRMDONE
68 . I ACTION="M" D MERGE^PXRMEXU5(801.41,EXISTS,"15;18*",.FDA,.IENROOT)
69 . D DLG^PXRMEXU4(.FDA,.NAMECHG)
70 ;
71 ;Special handling for file 810.9
72 I TOPFNUM=810.9 D LOC^PXRMEXU0(.FDA)
73 ;
74 ;If the file number is 811.4 the user must have programmer
75 ;access to install it.
76 I (TOPFNUM=811.4)&(DUZ(0)'="@") D Q
77 . W !,"Only programmers can install Reminder Computed Findings."
78 ;
79 ;Special handling for file 811.5.
80 I TOPFNUM=811.5 D Q:'$D(FDA)
81 .;If the site has any findings already mapped merge them in.
82 . I ACTION="M" D MERGE^PXRMEXU5(811.5,EXISTS,"20*",.FDA,.IENROOT)
83 . D TERM^PXRMEXIU(.FDA,.NAMECHG)
84 ;
85 ;Special handling for file 811.9.
86 I TOPFNUM=811.9 D
87 .;Don't execute the input transform for custom logic fields.
88 . S PXRMEXCH=1
89 . D DEF^PXRMEXIU(.FDA,.NAMECHG)
90 ;If FDA is not defined at this point the user has opted to abort
91 ;the install.
92 I '$D(FDA) Q
93 ;
94 ;Special handling for file 9999999.64.
95 I TOPFNUM=9999999.64 D
96 . D HF^PXRMEXIU(.FDA,.NAMECHG)
97 ;
98 ;If the action is merge oroverwrite do a test install before deleting
99 ;the original entry.
100 I (ACTION="M")!(ACTION="O") D
101 .;Make the .01 unique for the test install.
102 . S IENS=$O(FDA(TOPFNUM,""))
103 .;Get the length of the .01 field
104 . D FIELD^DID(TOPFNUM,.01,"","FIELD LENGTH","ATTR")
105 . S TNAME="tmp"_$E(FDA(TOPFNUM,IENS,.01),1,ATTR("FIELD LENGTH")-3)
106 .;Make sure the test entry does not already exist.
107 . D DELALL^PXRMEXFI(TOPFNUM,TNAME)
108 . K ^TMP($J,"TFDA") M ^TMP($J,"TFDA")=FDA K FDA
109 . K TFDA M TFDA=^TMP($J,"TFDA")
110 . S TFDA(TOPFNUM,IENS,.01)=TNAME
111 . D UPDATE^DIE("E","TFDA","IENROOT","MSG")
112 . I $D(MSG) D
113 .. W !,"The update failed, UPDATE^DIE returned the following error message:"
114 .. D AWRITE^PXRMUTIL("MSG")
115 .. W !!,ATTR("FILE NAME")," entry ",$G(ATTR("PT01"))," did not get installed!"
116 .. W !,"Examine the above error message for the reason.",!
117 .. H 2
118 . I '$D(MSG) K TFDA M FDA=^TMP($J,"TFDA")
119 . K ^TMP($J,"TFDA")
120 .;Delete the test entry.
121 . D DELALL^PXRMEXFI(TOPFNUM,TNAME)
122 .;If the original update worked put the entry at its original ien.
123 ;Install the FDA.
124 I '$D(MSG) D
125 .;Delete the existing entry.
126 . I (ACTION="M")!(ACTION="O") D
127 .. D DELETE^PXRMEXFI(TOPFNUM,SITEIEN)
128 .. S IENROOT(SRCIEN)=SITEIEN
129 . I $D(PXRMCLAS) D SCLASS^PXRMEXU5(TOPFNUM,PXRMCLAS,.FDA)
130 . D UPDATE^DIE("E","FDA","IENROOT","MSG")
131 . I $D(MSG) D
132 .. W !,"The update failed, UPDATE^DIE returned the following error message:"
133 .. D AWRITE^PXRMUTIL("MSG")
134 .. W !!,ATTR("FILE NAME")," entry ",$G(ATTR("PT01"))," did not get installed!"
135 .. W !,"Examine the above error message for the reason.",!
136 .. H 2
137 S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")
138 I TOPFNUM=811.9,VERSN=1.5 D
139 . N IEN,PXRMEXCH,X
140 . S IEN=IENROOT(SRCIEN)
141 .;For reminder definitions build the found/not found text counts.
142 . D SFNFTC^PXRMEXU0(IEN)
143 .;Build the internal logic and finding strings.
144 . S X=$G(^PXD(811.9,IEN,30))
145 . I X'="" D CPPCLS^PXRMLOGX(IEN,X)
146 . S X=$G(^PXD(811.9,IEN,34))
147 . I X'="" D CPRESLS^PXRMLOGX(IEN,X)
148 . D BLDALL^PXRMLOGX(IEN,"","")
149 Q
150 ;
151 ;=================================================
152INIEH(FILENUM,IENS,FDA,WPTMP) ;If the file is a clinical reminder file and
153 ;it has an edit history initialize the history.
154 I (FILENUM<800)!(FILENUM>811.9) Q
155 ;
156 N IENS,SFN,TARGET,WP
157 D FIELD^DID(FILENUM,"EDIT HISTORY","","SPECIFIER","TARGET")
158 S SFN=+$G(TARGET("SPECIFIER"))
159 I SFN=0 Q
160 S IENS=$O(FDA(SFN,""))
161 I IENS="" Q
162 S FDA(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
163 S FDA(SFN,IENS,1)=$$GET1^DIQ(200,DUZ,.01)
164 ;The word-processing field is set when the packing is done.
165 S WP=FDA(SFN,IENS,2)
166 K @WP
167 S @WP@(1)="Exchange Install"
168 Q
169 ;
170 ;=================================================
171NAMECHG(FDA,NAMECHG,FILENUM) ;If this component has been copied to a new
172 ;name make the change.
173 N CLASS,IENS,PT01
174 S IENS=$O(FDA(FILENUM,""))
175 S PT01=FDA(FILENUM,IENS,.01)
176 I $D(NAMECHG(FILENUM,PT01)) D
177 . S FDA(FILENUM,IENS,.01)=NAMECHG(FILENUM,PT01)
178 . I (FILENUM<801.41)!(FILENUM>811.9) Q
179 .;Once a component has been copied CLASS can no longer be national.
180 . S CLASS=$G(FDA(FILENUM,IENS,100))
181 . I CLASS["N" S FDA(FILENUM,IENS,100)="LOCAL"
182 .;The Sponsor is also removed.
183 . K FDA(FILENUM,IENS,101)
184 Q
185 ;
186 ;=================================================
187RTNLD(PXRMRIEN,START,END,ATTR,RTN) ;Load a routine from the repository into
188 ;the array RTN.
189 N IND,LINE,LN,ROUTINE
190 S LINE=^PXD(811.8,PXRMRIEN,100,START,0)
191 S ROUTINE=$P(LINE,";",1)
192 S ROUTINE=$TR(ROUTINE," ","")
193 S ATTR("FILE NUMBER")=0
194 S ATTR("NAME")=$P(LINE,";",1)
195 S ATTR("NAME")=$TR(ATTR("NAME")," ","")
196 S ATTR("MIN FIELD LENGTH")=3
197 S ATTR("FIELD LENGTH")=8
198 S LN=0
199 F IND=START:1:END D
200 . S LN=LN+1
201 . S LINE=^PXD(811.8,PXRMRIEN,100,IND,0)
202 . S RTN(LN,0)=LINE
203 Q
204 ;
205 ;=================================================
206RTNSAVE(RTN,NAME) ;Save the routine loaded in RTN to the name
207 ;found in NAMECHG.
208 N DIE,XCN
209 ;%ZOSF("SAVE") requires a global.
210 K ^TMP($J,"PXRMRTN")
211 S DIE="^TMP($J,""PXRMRTN"","
212 M ^TMP($J,"PXRMRTN")=RTN
213 S XCN=0
214 S X=NAME
215 X ^%ZOSF("SAVE")
216 K ^TMP($J,"PXRMRTN")
217 Q
218 ;
219 ;=================================================
220WORDPROC(PXRMRIEN,WPTMP,I1,I2,IND,WPLCNT) ;Load WPTMP with the word
221 ;processing field.
222 N I3
223 F I3=1:1:WPLCNT D
224 . S IND=IND+1
225 . S WPTMP(I1,I2,I3)=$G(^PXD(811.8,PXRMRIEN,100,IND,0))
226 Q
227 ;
Note: See TracBrowser for help on using the repository browser.