source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m@ 1593

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

revised back to 6/30/08 version

File size: 9.0 KB
Line 
1PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;06/23/2005
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;===============================================
4DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related
5 ;reminder exists and all the findings exist.
6 N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,LRD,OFINDING,PT01
7 N RRG,SPONSOR,TEXT,VERSN
8 S IENS=$O(FDA(811.9,""))
9 ;
10 ;Related reminder guideline field 1.4.
11 I $D(FDA(811.9,IENS,1.4)) D
12 . S RRG=FDA(811.9,IENS,1.4)
13 . S IEN=$$EXISTS^PXRMEXIU(811.9,RRG)
14 . I IEN=0 D
15 ..;Get replacement.
16 .. N DIC,X,Y
17 .. S TEXT(1)=" "
18 .. S TEXT(2)="The Related Reminder Guideline does not exist on your system!"
19 .. S TEXT(3)="It is "_RRG_" input a replacement or ^ to leave it empty."
20 .. D MES^XPDUTL(.TEXT)
21 ..;If this is being called during a KIDS install we need echoing on.
22 .. I $D(XPDNM) X ^%ZOSF("EON")
23 .. S DIC=811.9,DIC(0)="AEMQ"
24 .. D ^DIC
25 .. I $D(XPDNM) X ^%ZOSF("EOFF")
26 .. I Y=-1 K FDA(811.9,IENS,1.4)
27 .. E S FDA(811.9,IENS,1.4)=$P(Y,U,2)
28 ;
29 ;Sponsor field 101.
30 I $D(FDA(811.9,IENS,101)) D
31 . S SPONSOR=FDA(811.9,IENS,101)
32 . S IEN=$$FIND1^DIC(811.6,"","",SPONSOR)
33 . I IEN=0 D
34 ..;Get replacement.
35 .. N DIC,X,Y
36 .. S TEXT(1)=" "
37 .. S TEXT(2)="The Sponsor does not exist on your system!"
38 .. S TEXT(3)="It is "_SPONSOR_" input a replacement or ^ to leave it empty."
39 .. D MES^XPDUTL(.TEXT)
40 ..;If this is being called during a KIDS install we need echoing on.
41 .. I $D(XPDNM) X ^%ZOSF("EON")
42 .. S DIC=811.6,DIC(0)="AEMQ"
43 .. D ^DIC
44 .. I $D(XPDNM) X ^%ZOSF("EOFF")
45 .. I Y=-1 K FDA(811.9,IENS,101)
46 .. E S FDA(811.9,IENS,101)=$P(Y,U,2)
47 ;
48 ;Linked reminder dialog field 51.
49 S LRD=+$G(FDA(811.9,IENS,51))
50 S IEN=$$EXISTS^PXRMEXIU(801.41,LRD)
51 I IEN=0 K FDA(811.9,IENS,51)
52 ;
53 ;Search the finding multiple for replacements and missing findings.
54 D BLDALIST^PXRMVPTR(811.902,.01,.ALIST)
55 S IENS=""
56 F S IENS=$O(FDA(811.902,IENS)) Q:IENS="" D
57 . S (FINDING,OFINDING)=FDA(811.902,IENS,.01)
58 . S ABBR=$P(FINDING,".",1)
59 . S PT01=$P(FINDING,".",2)
60 . S FILENUM=$P(ALIST(ABBR),U,1)
61 . I $D(NAMECHG(FILENUM,PT01)) D
62 .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
63 .. S FDA(811.902,IENS,.01)=FINDING
64 . S IEN=+$$VFIND1(FINDING,.ALIST)
65 . I IEN>0 S FDA(811.902,IENS,.01)=ABBR_".`"_IEN
66 . I IEN=0 D
67 ..;Get replacement
68 .. N DIC,DUOUT,TEXT,X,Y
69 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
70 .. W !,TEXT
71 .. S DIC=FILENUM
72 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
73 .. S DIC(0)="AEMNQ"
74 .. S Y=-1
75 .. F Q:+Y'=-1 D
76 ...;If this is being called during a KIDS install we need echoing on.
77 ... I $D(XPDNM) X ^%ZOSF("EON")
78 ... D ^DIC
79 ... I $D(XPDNM) X ^%ZOSF("EOFF")
80 ... I $D(DUOUT) S Y="" K FDA
81 .. I Y="" Q
82 .. S FINDING=ABBR_"."_$P(Y,U,2),FDA(811.902,IENS,.01)=FINDING
83 .;Save the finding information for the history.
84 . S ^TMP("PXRMEXIA",$J,"DEFF",$P(IENS,",",1),OFINDING)=FINDING
85 .;Save changes to Orderable items for dialog
86 . I FILENUM=101.43,OFINDING'=FINDING
87 . S NAMECHG(FILENUM,$P(OFINDING,".",2))=$P(FINDING,".",2)
88 S VERSN=$$GETTAGV^PXRMEXU3(^PXD(811.8,PXRMRIEN,100,3,0),"<PACKAGE_VERSION>")
89 I VERSN=1.5 D CEFD^PXRMDATE(.FDA)
90 Q
91 ;
92 ;===============================================
93EXISTS(FILENUM,NAME,FLAG) ;Check for existence of an entry with the
94 ;same name. Return 0 for null name
95 I NAME="" Q 0
96 ;Return the ien if it does, 0 otherwise.
97 N IEN
98 I FILENUM=0 S IEN=$$EXISTS^PXRMEXCF(NAME) Q
99 N FLAGS,RESULT
100 S RESULT=NAME
101 ;Special lookup for files 80 and 80.1, they do not have a standard "B"
102 ;cross-reference.
103 I (FILENUM=80)!(FILENUM=80.1) D
104 .;Name may or may not have the necessary space appended, make sure
105 .;it does.
106 . S RESULT=$S($E(NAME,$L(NAME))'=" ":NAME_" ",1:NAME)
107 . S FLAGS="MX"
108 E S FLAGS="BX"
109 I FILENUM=811.6 S FLAGS=FLAGS_"U"
110 ;File 8927.1 only allows upper case .01s.
111 I FILENUM=8927.1 S RESULT=$$UP^XLFSTR(NAME)
112 S IEN=$$FIND1^DIC(FILENUM,"",FLAGS,RESULT)
113 I +IEN>0 Q IEN
114 ;If IEN is null then there was an error try FIND^DIC.
115 N FILENAME,LIST,MSG,NFOUND,TEXT
116 D FIND^DIC(FILENUM,"","",FLAGS,NAME,"","","","","LIST","MSG")
117 S NFOUND=+$P(LIST("DILIST",0),U,1)
118 I NFOUND=0 Q 0
119 I NFOUND=1 Q LIST("DILIST",2,1)
120 ;Multiple entries with the same name found.
121 S FILENAME=$$GET1^DID(FILENUM,"","","NAME")
122 S TEXT(1)="Warning there are "_NFOUND_" "_FILENAME_" entries with the name "_NAME_"!"
123 S TEXT(2)="If this is used as a finding, and it is not resolved by FileMan during"
124 S TEXT(3)="installation, any component using this finding will not install."
125 D EN^DDIOL(.TEXT)
126 I $G(FLAG)="W" H 3 Q LIST("DILIST",2,1)
127 I NFOUND>1 S IEN=$$GETIEN^PXRMEXU0(NFOUND,.LIST)
128 Q IEN
129 ;
130 ;===============================================
131GETACT(CHOICES,DIR) ;Get the action
132 ;If CHOICES is empty the only action is skip.
133 I CHOICES="" Q "S"
134 N DIROUT,DIRUT,DTOUT,DUOUT,X,Y
135 S DIR(0)="S"_U
136 I CHOICES["C" S DIR(0)=DIR(0)_"C:Create a new entry by copying to a new name"
137 I CHOICES["D" S DIR(0)=DIR(0)_";D:Delete (from the reminder/dialog)"
138 I CHOICES["I" S DIR(0)=DIR(0)_";I:Install"
139 I CHOICES["M" S DIR(0)=DIR(0)_";M:Merge findings"
140 I CHOICES["O" S DIR(0)=DIR(0)_";O:Overwrite the current entry"
141 I CHOICES["P" S DIR(0)=DIR(0)_";P:Replace (in the reminder/dialog) with an existing entry"
142 I CHOICES["Q" S DIR(0)=DIR(0)_";Q:Quit the install"
143 I CHOICES["R" S DIR(0)=DIR(0)_";R:Restart"
144 I CHOICES["S" S DIR(0)=DIR(0)_";S:Skip, do not install this entry"
145 ;If this is being called during a KIDS install we need echoing on.
146 I $D(XPDNM) X ^%ZOSF("EON")
147 D ^DIR
148 I $D(XPDNM) X ^%ZOSF("EOFF")
149 I $D(DIROUT)!$D(DIRUT) S Y="S"
150 I $D(DTOUT)!($D(DUOUT)) S Y="S"
151 Q Y
152 ;
153 ;===============================================
154GETNAME(MIN,MAX) ;Get a name to use.
155 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
156 S DIR(0)="FAOU"_U_MIN_":"_MAX
157 S DIR("A")="Input the new name: "
158 D ^DIR
159 I $D(DIROUT)!$D(DIRUT) Q ""
160 I $D(DTOUT)!$D(DUOUT) Q ""
161 Q Y
162 ;
163 ;===============================================
164GETUNAME(ATTR) ;Get a unique name to use, ATTR holds the attributes.
165 N IEN,NEWPT01,TEXT
166GNEW S NEWPT01=$$GETNAME(ATTR("MIN FIELD LENGTH"),ATTR("FIELD LENGTH"))
167 S IEN=+$$EXISTS(ATTR("FILE NUMBER"),NEWPT01)
168 I IEN>0 D G GNEW
169 . S TEXT=ATTR("FILE NAME")_" entry "_NEWPT01_" already exists, what do you want to do?"
170 . D EN^DDIOL(TEXT)
171 E S ATTR("NAME")=NEWPT01
172 Q NEWPT01
173 ;
174 ;===============================================
175HF(FDA,NAMECHG) ;Check the health factor to make sure a category does not
176 ;have a category.
177 N IENS
178 S IENS=$O(FDA(9999999.64,""))
179 I IENS="" Q
180 I FDA(9999999.64,IENS,.1)="CATEGORY" K FDA(9999999.64,IENS,.03)
181 Q
182 ;
183 ;===============================================
184LABPANEL(IEN) ;
185 N NODE
186 S NODE=^LAB(60,IEN,0)
187 I $P(NODE,U,4)'["CH" Q 1
188 I $P(NODE,U,5)="" Q 0
189 Q 1
190 ;
191 ;===============================================
192REXISTS(NAME,DATEP) ;See if this Exchange File entry already exists.
193 N IEN,LUVALUE
194 S LUVALUE(1)=NAME
195 S LUVALUE(2)=DATEP
196 S IEN=+$$FIND1^DIC(811.8,"","KU",.LUVALUE)
197 Q IEN
198 ;
199 ;===============================================
200SAME(ATTR,TA,NAME) ;Check existing entry and entry in packed reminder
201 ;definition to see if they are identical.
202 ;Present version only works for computed finding routines, other
203 ;types of entries can be added later.
204 N SAME
205 I ATTR("FILE NAME")="COMPUTED FINDING ROUTINE" S SAME=$$SAME^PXRMEXCF(.ATTR,.TA,NAME)
206 E S SAME=1
207 Q SAME
208 ;
209 ;===============================================
210TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the
211 ;findings exist.
212 N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01
213 ;Search the finding multiple for replacements and missing findings.
214 D BLDALIST^PXRMVPTR(811.52,.01,.ALIST)
215 S IENS=""
216 F S IENS=$O(FDA(811.52,IENS)) Q:IENS="" D
217 . S (FINDING,OFINDING)=FDA(811.52,IENS,.01)
218 . S ABBR=$P(FINDING,".",1)
219 . S PT01=$P(FINDING,".",2)
220 . S FILENUM=$P(ALIST(ABBR),U,1)
221 . I $D(NAMECHG(FILENUM,PT01)) D
222 .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
223 .. S FDA(811.52,IENS,.01)=FINDING
224 . S IEN=+$$VFIND1(FINDING,.ALIST)
225 . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN
226 . I IEN=0 D
227 ..;Get replacement
228 .. N DIC,DUOUT,TEXT,X,Y
229 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
230 .. D BMES^XPDUTL(TEXT)
231 .. S DIC=FILENUM
232 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
233 .. S DIC(0)="AEMNQ"
234 .. S Y=-1
235 .. F Q:+Y'=-1 D
236 ...;If this is being called during a KIDS install we need echoing on.
237 ... I $D(XPDNM) X ^%ZOSF("EON")
238 ... D ^DIC
239 ... I $D(XPDNM) X ^%ZOSF("EOFF")
240 ... I $D(DUOUT) D
241 .... S Y=""
242 .... K FDA
243 .. I Y="" K FDA(811.52,IENS)
244 .. E D
245 ... S FINDING=ABBR_"."_$P(Y,U,2)
246 ... S FDA(811.52,IENS,.01)=FINDING
247 .;Save the finding information for the history.
248 . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING
249 Q
250 ;
251 ;===============================================
252VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME
253 ;and ALIST which contains the link between abbreviations and files
254 ;return the IEN if it exists and 0 if no match if found.
255 N ABBR,IEN,FILENUM,PT01,RESULT
256 S IEN=0
257 S ABBR=$P(VPTR,".",1)
258 S PT01=$P(VPTR,".",2,99)
259 S FILENUM=$P(ALIST(ABBR),U,1)
260 S IEN=$$EXISTS(FILENUM,PT01)
261 Q IEN
262 ;
Note: See TracBrowser for help on using the repository browser.