source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m@ 1006

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

revised back to 6/30/08 version

File size: 7.0 KB
Line 
1PXRMEXU4 ; SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;01/19/2005
2 ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
3 ;===============================================
4DLG(FDA,NAMECHG) ;Check the dialog for renamed entries, called by
5 ;silent installer. KIDSDONE is newed in INSDLG^PXRMEXSI.
6 N ABBR,ACTION,ALIST,DNAM,IEN,IENS,FILENUM,FINDING,NEWNAM,OFINDING
7 N ORITEM,OORITEM,PT01,RESULT,RRG,SRC,WP
8 S IENS=$O(FDA(801.41,""))
9 ;Definition .01
10 S (PT01,DNAM)=FDA(801.41,IENS,.01)
11 I $D(NAMECHG(801.41,PT01)) D
12 .S (FDA(801.41,IENS,.01),DNAM)=NAMECHG(801.41,PT01)
13 ;
14 ;Build list of finding types
15 D BLDALIST^PXRMVPTR(801.4118,.01,.ALIST)
16 ;Plus field 15 files
17 S ALIST("MH")=601,ALIST("TX")=811.2
18 S ALIST("WH")=790.404
19 ;Plus field 17 file
20 S ALIST("OI")=101.43
21 ;
22 ;Process SOURCE REMINDER
23 S SRC=$G(FDA(801.41,IENS,2))
24 I SRC]"" D
25 .S IEN=$$EXISTS^PXRMEXIU(811.9,SRC)
26 .I IEN=0 K FDA(801.41,IENS,2)
27 ;
28 ;Clear RESULT if not defined
29 S RESULT=$G(FDA(801.41,IENS,55))
30 I RESULT]"" D
31 .S IEN=$$EXISTS^PXRMEXIU(801.41,RESULT)
32 .I IEN=0 K FDA(801.41,IENS,55)
33 ;
34 ;Process ORDERABLE ITEM
35 S (ORITEM,OORITEM)=$G(FDA(801.41,IENS,17)),ACTION=""
36 I ORITEM'="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
37 .S PT01=ORITEM
38 .S ABBR="OI",FILENUM=$P(ALIST(ABBR),U)
39 .I $D(NAMECHG(FILENUM,PT01)) D
40 ..S ORITEM=NAMECHG(FILENUM,PT01)
41 ..S FDA(801.41,IENS,17)=ORITEM
42 .S IEN=+$$VFIND1^PXRMEXIU(ABBR_"."_ORITEM,.ALIST)
43 .I IEN=0 D
44 ..;Get replacement
45 ..N DIC,DIR,DUOUT,MSG,X,Y
46 ..S MSG(1)=" "
47 ..S MSG(2)="ORDERABLE ITEM entry "_ORITEM_" does not exist."
48 ..D MES^XPDUTL(.MSG)
49 ..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
50 ..I ACTION="Q" Q
51 ..I ACTION="D" K FDA(801.41,IENS,17) Q
52 ..S DIC=FILENUM
53 ..S DIC(0)="AEMNQ"
54 ..S Y=-1
55 ..F Q:+Y'=-1 D
56 ...;If this is being called during a KIDS install we need echoing on.
57 ...I $D(XPDNM) X ^%ZOSF("EON")
58 ...D ^DIC
59 ...I $D(XPDNM) X ^%ZOSF("EOFF")
60 ...;If this is being called during a KIDS install we need echoing on.
61 ...I $D(DUOUT) S Y="" Q
62 ...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
63 ..I Y="" S ACTION="Q" Q
64 ..S ORITEM=$P(Y,U,2)
65 ..S FDA(801.41,IENS,17)=ORITEM
66 .;Save the finding information for the history.
67 .I ORITEM'=OORITEM D
68 .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),ABBR_"."_OORITEM)=ABBR_"."_ORITEM
69 ;
70 ;Process FINDING ITEM
71 S (FINDING,OFINDING)=$G(FDA(801.41,IENS,15)),ACTION=""
72 I FINDING'="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
73 .S ABBR=$P(FINDING,".",1)
74 .S PT01=$P(FINDING,".",2)
75 .S FILENUM=$P(ALIST(ABBR),U,1)
76 .I $D(NAMECHG(FILENUM,PT01)) D
77 ..S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
78 ..S FDA(801.41,IENS,15)=FINDING
79 .S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
80 .I IEN=0 D
81 ..;Get replacement
82 ..N DIC,DIR,DUOUT,MSG,X,Y
83 ..S MSG(1)=" "
84 ..S MSG(2)="FINDING entry "_FINDING_" does not exist."
85 ..D MES^XPDUTL(.MSG)
86 ..S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR) I ACTION="S" S ACTION="Q"
87 ..I ACTION="Q" Q
88 ..I ACTION="D" K FDA(801.41,IENS,15) Q
89 ..S DIC=FILENUM
90 ..S DIC(0)="AEMNQ"
91 ..S Y=-1
92 ..F Q:+Y'=-1 D
93 ...;If this is being called during a KIDS install we need echoing on.
94 ...I $D(XPDNM) X ^%ZOSF("EON")
95 ...D ^DIC
96 ...I $D(XPDNM) X ^%ZOSF("EOFF")
97 ...;If this is being called during a KIDS install we need echoing on.
98 ...I $D(DUOUT) S Y="" Q
99 ...I Y=-1 D BMES^XPDUTL("You must input a replacement!")
100 ..I Y="" S ACTION="Q" Q
101 ..S FINDING=ABBR_"."_$P(Y,U,2)
102 ..S FDA(801.41,IENS,15)=FINDING
103 .;Save the finding information for the history.
104 .I FINDING'=OFINDING D
105 .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING
106 .;Convert ICD9 codes to `ien format
107 .I $P(FINDING,".")="ICD9" S FDA(801.41,IENS,15)="ICD9."_$$ICD9(FINDING)
108 ;
109 ;Look for replacements of TIU templates.
110 I $D(NAMECHG(8927.1)) D
111 .S WP=$G(FDA(801.41,IENS,25))
112 .I WP'="" D TIURPL("{FLD:",WP,.NAMECHG,8927.1)
113 .S WP=$G(FDA(801.41,IENS,35))
114 ;
115 ;Process ADDITIONAL FINDINGS
116 S IENS="",ACTION=""
117 F S IENS=$O(FDA(801.4118,IENS)) Q:IENS="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
118 . S (FINDING,OFINDING)=FDA(801.4118,IENS,.01)
119 . S ABBR=$P(FINDING,".",1)
120 . S PT01=$P(FINDING,".",2)
121 . S FILENUM=$P(ALIST(ABBR),U,1)
122 . I $D(NAMECHG(FILENUM,PT01)) D
123 .. S FINDING=ABBR_"."_NAMECHG(FILENUM,PT01)
124 .. S FDA(801.4118,IENS,.01)=FINDING
125 . S IEN=+$$VFIND1^PXRMEXIU(FINDING,.ALIST)
126 . I IEN=0 D Q:ACTION="Q"
127 ..;Get replacement
128 .. N DIC,DIR,DUOUT,MSG,X,Y
129 .. S MSG(1)=" "
130 .. S MSG(2)="ADDITIONAL FINDING entry "_FINDING_" does not exist."
131 .. D MES^XPDUTL(.MSG)
132 .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
133 .. I ACTION="S" S ACTION="Q"
134 .. I ACTION="Q" Q
135 .. I ACTION="D" K FDA(801.4118,IENS) Q
136 .. S DIC=FILENUM
137 .. S DIC(0)="AEMNQ"
138 .. S Y=-1
139 .. F Q:+Y'=-1 D
140 ...;If this is being called during a KIDS install we need echoing on.
141 ... I $D(XPDNM) X ^%ZOSF("EON")
142 ... D ^DIC
143 ... I $D(XPDNM) X ^%ZOSF("EOFF")
144 ... I $D(DUOUT) S Y="" Q
145 ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
146 .. I Y="" S ACTION="Q" Q
147 .. S FINDING=ABBR_"."_$P(Y,U,2)
148 .. S FDA(801.4118,IENS,.01)=FINDING
149 . ;Save the finding information for the history.
150 . I FINDING'=OFINDING D
151 .. S ^TMP("PXRMEXIA",$J,"DIAF",$P(IENS,",",1),OFINDING)=FINDING
152 . ;Convert ICD9 codes to `ien format
153 . I $P(FINDING,".")="ICD9" S FDA(801.4118,IENS,.01)=$$ICD9(FINDING)
154 ;
155 I ACTION="Q" S (PXRMDONE,KIDSDONE)=1 Q
156 ;Process DIALOG COMPONENT
157 S IENS="",ACTION=""
158 F S IENS=$O(FDA(801.412,IENS)) Q:IENS="" D I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
159 . S PT01=$G(FDA(801.412,IENS,2)) Q:PT01=""
160 . S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01))
161 .I NEWNAM'="" D
162 .. S FDA(801.412,IENS,2)=NEWNAM,PT01=NEWNAM
163 .S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
164 .I IEN=0 D
165 ..;Get replacement
166 .. N DIC,DIR,DUOUT,MSG,X,Y
167 .. S MSG(1)=" "
168 .. S MSG(2)="COMPONENT DIALOG entry "_PT01_" does not exist."
169 .. D MES^XPDUTL(.MSG)
170 .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
171 .. I ACTION="S" S ACTION="Q"
172 .. I ACTION="Q" Q
173 .. I ACTION="D" K FDA(801.412,IENS) Q
174 .. S DIC=FILENUM
175 .. S DIC(0)="AEMNQ"
176 .. S DIC("S")="I ""EG""[$P(^PXRMD(801.41,Y,0),U,4)"
177 .. S Y=-1
178 .. F Q:+Y'=-1 D
179 ...;If this is being called during a KIDS install we need echoing on.
180 ... I $D(XPDNM) X ^%ZOSF("EON")
181 ... D ^DIC
182 ... I $D(XPDNM) X ^%ZOSF("EOFF")
183 ... I $D(DUOUT) S Y="" Q
184 ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
185 .. I Y="" S ACTION="Q" Q
186 .. I Y'="" S FDA(801.412,IENS,2)=$P(Y,U,2)
187 Q
188 ;
189 ;===============================================
190 ;Convert ICD9 codes to `ien format
191ICD9(CODE) ;
192 N IEN
193 S IEN=$$FIND1^DIC(80,"","AMX",$P(CODE,".",2,99))
194 I 'IEN Q ""
195 Q "`"_IEN
196 ;
197 ;===============================================
198TIURPL(SRCH,WP,NAMEGHC,FILENUM) ;Replace TIU templates whose names have
199 ;changed.
200 N IND,RS,TEXT,TS,TYPE
201 I FILENUM=8927.1 S TYPE="TIU TEMPLATE"
202 E S TYPE="TIU OBJECT"
203 S IND=1
204 F S TEXT=$G(@WP@(IND)) Q:TEXT="" D
205 .I TEXT[SRCH D
206 ..S TS=""
207 ..F S TS=$O(NAMECHG(FILENUM,TS)) Q:TS="" D
208 ...S RS=NAMECHG(FILENUM,TS) Q:TEXT'[TS
209 ...S @WP@(IND)=$$STRREP^PXRMUTIL(TEXT,TS,RS)
210 ...;Save the replacement information for the history.
211 ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS)=RS
212 ...S ^TMP("PXRMEXIA",$J,"DIATIU",TYPE,TS,DNAM)=""
213 .S IND=IND+1
214 Q
215 ;
Note: See TracBrowser for help on using the repository browser.