source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m@ 1536

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

initial load of FOIAVistA 6/30/08 version

File size: 8.6 KB
Line 
1PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;07/27/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
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=$S(LRD="":0,1:+$O(^PXRMD(801.41,"B",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 ;===============================================
200TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the
201 ;findings exist.
202 N ABBR,ALIST,IEN,IENS,FILENUM,FINDING,OFINDING,PT01
203 ;Search the finding multiple for replacements and missing findings.
204 D BLDALIST^PXRMVPTR(811.52,.01,.ALIST)
205 S IENS=""
206 F S IENS=$O(FDA(811.52,IENS)) Q:IENS="" D
207 . S (FINDING,OFINDING)=FDA(811.52,IENS,.01)
208 . S ABBR=$P(FINDING,".",1)
209 . S PT01=$P(FINDING,".",2)
210 . S FILENUM=$P(ALIST(ABBR),U,1)
211 . I $D(NAMECHG(FILENUM,PT01)) D
212 .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
213 .. S FDA(811.52,IENS,.01)=FINDING
214 . S IEN=+$$VFIND1(FINDING,.ALIST)
215 . I IEN>0 S FDA(811.52,IENS,.01)=ABBR_".`"_IEN
216 . I IEN=0 D
217 ..;Get replacement
218 .. N DIC,DUOUT,TEXT,X,Y
219 .. S TEXT="Finding "_FINDING_" does not exist; input a replacement or ^ to quit the install."
220 .. D BMES^XPDUTL(TEXT)
221 .. S DIC=FILENUM
222 .. I DIC="60" S DIC("S")="I $$LABPANEL^PXRMEXIU(Y)"
223 .. S DIC(0)="AEMNQ"
224 .. S Y=-1
225 .. F Q:+Y'=-1 D
226 ...;If this is being called during a KIDS install we need echoing on.
227 ... I $D(XPDNM) X ^%ZOSF("EON")
228 ... D ^DIC
229 ... I $D(XPDNM) X ^%ZOSF("EOFF")
230 ... I $D(DUOUT) D
231 .... S Y=""
232 .... K FDA
233 .. I Y="" K FDA(811.52,IENS)
234 .. E D
235 ... S FINDING=ABBR_"."_$P(Y,U,2)
236 ... S FDA(811.52,IENS,.01)=FINDING
237 .;Save the finding information for the history.
238 . S ^TMP("PXRMEXIA",$J,"TRMF",$P(IENS,",",1),OFINDING)=FINDING
239 Q
240 ;
241 ;===============================================
242VFIND1(VPTR,ALIST) ;Given a variable pointer of the form ABBR.NAME
243 ;and ALIST which contains the link between abbreviations and files
244 ;return the IEN if it exists and 0 if no match if found.
245 N ABBR,IEN,FILENUM,PT01,RESULT
246 S IEN=0
247 S ABBR=$P(VPTR,".",1)
248 S PT01=$P(VPTR,".",2,99)
249 S FILENUM=$P(ALIST(ABBR),U,1)
250 S IEN=$$EXISTS(FILENUM,PT01)
251 Q IEN
252 ;
Note: See TracBrowser for help on using the repository browser.