source: ePrescribing/trunk/p/C0PKIDS.m@ 1699

Last change on this file since 1699 was 1595, checked in by George Lilly, 12 years ago

initial release of ePrescribing
File size: 15.0 KB
RevLine 
[1595]1C0PKIDS ; VEN/SMH - eRx KIDS Utilities ; 5/4/12 4:26pm
2 ;;1.0;C0P;;Apr 25, 2012;Build 7
3 ; (C) Sam Habiel 2012
4 ; Licensed under GPL.
5 ;
6 ;Copyright 2012 Sam Habiel. Licensed under the terms of the GNU
7 ;General Public License See attached copy of the License.
8 ;
9 ;This program is free software; you can redistribute it and/or modify
10 ;it under the terms of the GNU General Public License as published by
11 ;the Free Software Foundation; either version 2 of the License, or
12 ;(at your option) any later version.
13 ;
14 ;This program is distributed in the hope that it will be useful,
15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;GNU General Public License for more details.
18 ;
19 ;You should have received a copy of the GNU General Public License along
20 ;with this program; if not, write to the Free Software Foundation, Inc.,
21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
22 ;
23 ; This routine contains utilities for KIDS distribution of E-Rx.
24 ;
25 ; PEPs:
26 ; For RxNorm dist: RXNTRAN,RXNPOST
27 ; For FDB files: FDBTRAN,FDBPOST
28 ;
29 ;
30ENV ; Environment Check
31 ; If EWD version is less than 800, don't install
32 I $$TRIM^XLFSTR($G(^%zewd("version")))<800 DO QUIT
33 . W "A recent version of EWD must be installed before installing ",!
34 . W "e-Prescribing. Installation cannot continue.",!
35 . S XPDQUIT=1
36 ; Check if C0C 1.1 is installed
37 QUIT
38POST ; Main Post Installation routine
39 ;
40 ; KIDS will file the modified RPs ORWPS COVER and ORWPS DETAIL
41 ; KIDS will install the Mail Group ERX HELP DESK
42 ;
43 D MES^XPDUTL("Adding E-Prescribing RPCs to CPRS Broker Context")
44 D REGNMSP("C0P","OR CPRS GUI CHART") ; Register C0P RPs to the Broker Context
45 ;
46 ; Add two alerts to the OE/RR Notifications file
47 D MES^XPDUTL("Adding E-Prescribing Notifications to the OE/RR Notification File")
48 ;
49 N C0PFDA
50 ; Entry 1
51 S C0PFDA(100.9,"?+1,",.001)=11305 ; NUMBER
52 S C0PFDA(100.9,"?+1,",.01)="C0P ERX REFILL REQUEST" ; NAME
53 ; .02 is not filled out, but triggered by the .01
54 S C0PFDA(100.9,"?+1,",.03)="ERX REFILL REQUEST" ; MESSAGE TEXT
55 S C0PFDA(100.9,"?+1,",.04)="PKG" ; MESSAGE TYPE
56 S C0PFDA(100.9,"?+1,",.05)="R" ; ACTION FLAG
57 S C0PFDA(100.9,"?+1,",.06)="RUN" ; ENTRY POINT
58 S C0PFDA(100.9,"?+1,",.07)="C0PREFIL" ; ROUTINE NAME
59 S C0PFDA(100.9,"?+1,",1.5)="OR" ; RELATED PACKAGE
60 S C0PFDA(100.9,"?+1,",4)="Used by the C0P eRx package for eRx Refill Requests"
61 ;
62 ; Entry 2
63 S C0PFDA(100.9,"?+2,",.001)=11306 ; NUMBER
64 S C0PFDA(100.9,"?+2,",.01)="C0P ERX INCOMPLETE ORDER" ; NAME
65 ; .02 is not filled out, but triggered by the .01
66 S C0PFDA(100.9,"?+2,",.03)="ERX INCOMPLETE ORDER" ; MESSAGE TEXT
67 S C0PFDA(100.9,"?+2,",.04)="PKG" ; MESSAGE TYPE
68 S C0PFDA(100.9,"?+2,",.05)="R" ; ACTION FLAG
69 S C0PFDA(100.9,"?+2,",.06)="STATUS" ; ENTRY POINT
70 S C0PFDA(100.9,"?+2,",.07)="C0PREFIL" ; ROUTINE NAME
71 S C0PFDA(100.9,"?+2,",1.5)="OR" ; RELATED PACKAGE
72 S C0PFDA(100.9,"?+2,",4)="Used by the C0P eRx package for eRx Incomplete Order Alerts"
73 ;
74 N C0PERR ; Errors go here.
75 D UPDATE^DIE("","C0PFDA","","C0PERR") ; no flags, FDA, ien_root, msg_root
76 ;
77 ; ew ew ew I hate $Q... still don't understand it.
78 I $D(C0PERR) D
79 . D MES^XPDUTL("WARNING: Updating the OE/RR Notification file failed.")
80 . S C0PERR=$Q(C0PERR)
81 . F S C0PERR=$Q(@C0PERR) Q:C0PERR="" D MES^XPDUTL(C0PERR_": "_@C0PERR)
82 ;
83 ; Done with that; now add the x-ref to file 200 on the NPI field.
84 ; Thank you to D ^DIKCBLD for writing this for me!
85 ;
86 D MES^XPDUTL("Adding NPI Cross Reference to New Person File")
87 N C0PXR,C0PRES,C0POUT,C0PERR
88 S C0PXR("FILE")=200
89 S C0PXR("NAME")="C0PNPI"
90 S C0PXR("TYPE")="R"
91 S C0PXR("USE")="LS"
92 S C0PXR("EXECUTION")="F"
93 S C0PXR("ACTIVITY")="IR"
94 S C0PXR("SHORT DESCR")="Regular index on NPI for eRx"
95 S C0PXR("VAL",1)=41.99
96 S C0PXR("VAL",1,"SUBSCRIPT")=1
97 S C0PXR("VAL",1,"LENGTH")=30
98 S C0PXR("VAL",1,"COLLATION")="F"
99 D CREIXN^DDMOD(.C0PXR,"S",.C0PRES,"C0POUT","C0PERR")
100 I $D(C0PERR) D MES^XPDUTL("NPI Cross-Reference Creation on File 200 failed")
101 ;
102 ; Ditto: Add the x-ref to file 50 on the PSNDF VA PRODUCT NAME ENTRY
103 D MES^XPDUTL("Adding PSNDF VA PRODUCT NAME ENTRY xref to Drug File")
104 N C0PXR,C0PRES,C0POUT,C0PERR
105 S C0PXR("FILE")=50
106 S C0PXR("NAME")="AC0P"
107 S C0PXR("TYPE")="R"
108 S C0PXR("USE")="S"
109 S C0PXR("EXECUTION")="F"
110 S C0PXR("ACTIVITY")="IR"
111 S C0PXR("SHORT DESCR")="For eRx - a sort only index on the VAPRODUCT number"
112 S C0PXR("DESCR",1)="This index is used for the VISTA e-Rx project. This index enables a "
113 S C0PXR("DESCR",2)="programmer to search for a drug using the VA Product. This index will"
114 S C0PXR("DESCR",3)="be used to match drugs received from the remote service to the local drug"
115 S C0PXR("DESCR",4)="file. Drugs received using the remote service are received using RxNorm"
116 S C0PXR("DESCR",5)="CUI or First Databank MEDID. Either one of those will be translated to a"
117 S C0PXR("DESCR",6)="VUID, which is matched against the VA Product file, which then is matched"
118 S C0PXR("DESCR",7)="to the local drug pointing to the VA Product. "
119 S C0PXR("VAL",1)=22
120 S C0PXR("VAL",1,"SUBSCRIPT")=1
121 S C0PXR("VAL",1,"COLLATION")="F"
122 D CREIXN^DDMOD(.C0PXR,"S",.C0PRES,"C0POUT","C0PERR")
123 I $D(C0PERR) D MES^XPDUTL("PSNDF VA PRODUCT NAME ENTRY xref Creation failed")
124 ;
125 ; Add Free Txt Entry to Pharmacy Orderable Item
126 ; Again... this time file the Free Text Drug into Pharmacy Orderablem Items
127 ; if it isn't already there!
128 D MES^XPDUTL("Adding Free Txt Entry to Pharmacy Orderable Item file")
129 ;
130 N PSEDITNM S PSEDITNM=1 ; Fileman gatekeeper for adding entries
131 N C0PFDA
132 S C0PFDA(50.7,"?+1,",.01)="FREE TXT DRUG" ; Name
133 S C0PFDA(50.7,"?+1,",.02)=40 ; DOSAGE FORM: MISCELANEOUS
134 S C0PFDA(50.7,"?+1,",.04)=3110428 ; INACTIVE DATE: (any value would do!)
135 ;
136 N C0PERR ; Errors go here.
137 D UPDATE^DIE("","C0PFDA","","C0PERR") ; no flags, FDA, ien_root, msg_root
138 ;
139 I $D(C0PERR) D
140 . D MES^XPDUTL("Couldn't add FREE TXT DRUG to Pharmacy Orderable Item File")
141 . S C0PERR=$Q(C0PERR)
142 . F S C0PERR=$Q(@C0PERR) Q:C0PERR="" D MES^XPDUTL(C0PERR_": "_@C0PERR)
143 ;
144 D MES^XPDUTL("")
145 D MES^XPDUTL("Remember to install the following patches: ")
146 D MES^XPDUTL("They may be legally protected; see documentation on how to")
147 D MES^XPDUTL("acquire them. Contact Geroge Lilly at glilly@glilly.net for questions")
148 D MES^XPDUTL(" - C0P*1.0*1 -> New Crop WebServices Data")
149 D MES^XPDUTL(" - C0P*1.0*2 -> RxNorm Data 2012-04 Release")
150 D MES^XPDUTL(" - C0P*1.0*3 -> First Databank Data 2012-03 Release")
151 D MES^XPDUTL("")
152 D MES^XPDUTL("Make sure to set-up the following after installation: ")
153 D MES^XPDUTL(" - Account Info in C0P WS ACCT")
154 D MES^XPDUTL(" - Institution address fields in file 4")
155 D MES^XPDUTL(" - Hospital Location E-Rx fields")
156 D MES^XPDUTL(" - New Person E-Rx fields")
157 D MES^XPDUTL(" - Mail users to mail group: ERX HELP DESK")
158 D MES^XPDUTL(" - Schedule C0P ERX BATCH to run every 15 min using an eRx user")
159 ;
160 ; I think we are done!
161 QUIT
162 ; --> RxNorm Files
163RXNTRAN ; Transportation Routine for RxNorm Files, PEP
164 M @XPDGREF@("C0P","RXN")=^C0P("RXN")
165 QUIT
166RXNPOST ; Post Install Routine for RxNorm Files, PEP
167 D MES^XPDUTL("Installing RxNorm Concepts File")
168 K ^C0P("RXN")
169 M ^C0P("RXN")=@XPDGREF@("C0P","RXN")
170 QUIT
171 ; <-- RxNorm Files
172 ;
173 ; --> FDB Files
174FDBTRAN ; Unified Transportation EP for FDB Files, PEP
175 D FDBDTRAN,FDBATRAN,IMPTRAN ; Drugs, Allergies, Import Templates
176 QUIT
177FDBPOST ; Unified Post Install Routine for FDB Files, PEP
178 D FDBDPOST,FDBAPOST,IMPPOST ; Drugs, Allergies, Import Templates
179 QUIT
180 ; <-- FDB Files
181 ;
182 ; Rest is private
183FDBDTRAN ; Transportation Routine for FDB Drug File, private
184 M @XPDGREF@("C0P","FDBD")=^C0P("FDB")
185 QUIT
186FDBDPOST ; Post Install Routine for FDB Drug File, private
187 D MES^XPDUTL("Installing FDB Drug File")
188 K ^C0P("FDB") ; Kill original file
189 M ^C0P("FDB")=@XPDGREF@("C0P","FDBD") ; Merge from Global
190 QUIT
191FDBATRAN ; Transportation Routine for FDB Allergies File, private
192 M @XPDGREF@("C0P","FDBA")=^C0PALGY
193 QUIT
194FDBAPOST ; Post Install Routine for FDB Allergies File, private
195 D MES^XPDUTL("Installing FDB Allergy File")
196 K ^C0PALGY ; Kill original file
197 M ^C0PALGY=@XPDGREF@("C0P","FDBA") ; Merge from Global
198 QUIT
199 ;
200 ; --> Import Templates
201IMPTRAN ; Transport Import Template for loading FDB files, private
202 ;
203 ; Get the IEN of the import templates to transport off...
204 N FDBDIEN S FDBDIEN=$O(^DIST(.46,"B","C0P FDB TBLCOMPOSITEDRUG",""))
205 N FDBAIEN S FDBAIEN=$O(^DIST(.46,"B","C0P FDB TBLCOMPOSITEALLERGY",""))
206 ;
207 ; Put in transport global, remove creator DUZ (can't guarantee in dest sys)
208 M @XPDGREF@("C0P","IMPFDBD")=^DIST(.46,FDBDIEN) ; Get first template
209 S $P(@XPDGREF@("C0P","IMPFDBD",0),U,5)="" ; Remove Creator
210 M @XPDGREF@("C0P","IMPFDBA")=^DIST(.46,FDBAIEN) ; Get second template
211 S $P(@XPDGREF@("C0P","IMPFDBA",0),U,5)="" ; Remove Creator
212 ;
213 QUIT
214 ;
215IMPPOST ; Post init for Import Templates, private
216 ; TODO: Before using as a general KIDS utility, this does not
217 ; check if the destination fields exist. Destination fields are
218 ; FREE TEXT fields in the Import Template.
219 ;
220 D MES^XPDUTL("Installing FDB Files' Import Templates")
221 ; Part 1: Delete old entries if they already exist.
222 ;
223 ; Get IENs
224 N FDBDIEN S FDBDIEN=$O(^DIST(.46,"B","C0P FDB TBLCOMPOSITEDRUG",""))
225 N FDBAIEN S FDBAIEN=$O(^DIST(.46,"B","C0P FDB TBLCOMPOSITEALLERGY",""))
226 ;
227 ; Kill off: Indexes first, then record. Lock before you do.
228 N C0PNAME
229 F C0PNAME="FDBDIEN","FDBAIEN" D ; For each variable
230 . I @C0PNAME D ; If that entry is found (see $O above)
231 . . L +^DIST(.46,@C0PNAME):0 ; Lock
232 . . ; IX2: Fire all Kill x-refs for one record.
233 . . N DIK,DA S DIK="^DIST(.46,",DA=@C0PNAME D IX2^DIK ; Kill Logic
234 . . K ^DIST(.46,@C0PNAME) ; Remove record
235 . . L -^DIST(.46,@C0PNAME) ; Unlock
236 ;
237 ; Part 2: Update New Entries into File
238 ; Get next available IEN in Import Template File
239 N LASTIEN S LASTIEN=$O(^DIST(.46," "),-1) ; Last internal entry number in file
240 ;
241 N NEXTIEN S NEXTIEN=LASTIEN ; Use below... incrementer!
242 ;
243 ; Merge data into the next IEN for each of the refs in the transported global
244 ; Block below gets next IEN available.
245 ; Lock on ^DIST(.46,NEXTIEN) acquired below.
246 F C0PNAME="IMPFDBD","IMPFDBA" DO
247 . ;
248 . ; Loop below to get an IEN for our new record number
249 . N DONE ; control variable for mini loop below
250 . F D Q:$G(DONE) ; loop until done
251 . . S NEXTIEN=NEXTIEN+1 ; Next IEN available, we guess
252 . . L +^DIST(.46,NEXTIEN):0 ELSE QUIT ; Can we lock it? If not quit and try the next
253 . . I $D(^DIST(.46,NEXTIEN)) L -^DIST(.46,NEXTIEN) QUIT ; if we locked it, is it really empty? If not, unlock and try next
254 . . S DONE=1 QUIT ; ok. we are sure we got it. Tell the loop we are done.
255 . ;
256 . M ^DIST(.46,NEXTIEN)=@XPDGREF@("C0P",C0PNAME) ; Merge entry
257 . ;
258 . ; Fire off xrefs (IX1 fires SET for xrefs for one record)
259 . N DIK,DA S DIK="^DIST(.46,",DA=NEXTIEN D IX1^DIK
260 . ;
261 . ; Update zero node
262 . S $P(^DIST(.46,0),U,3)=NEXTIEN ; most recently assigned internal entry number
263 . S $P(^DIST(.46,0),U,4)=NEXTIEN ; current total number of entries
264 . ;
265 . L -^DIST(.46,NEXTIEN) ; Unlock it
266 QUIT
267 ; <-- Import Templates
268 ;
269 ; SMH: All Code below comes from FOIA RPMS from routine CIAURPC
270 ; Written by Doug Martin.
271 ;
272 ; Register/unregister RPCs within a given namespace to a context
273REGNMSP(NMSP,CTX,DEL) ;EP
274 N RPC,IEN,LEN
275 S LEN=$L(NMSP),CTX=+$$GETOPT(CTX)
276 I $G(DEL) D
277 .S IEN=0
278 .F S IEN=$O(^DIC(19,CTX,"RPC","B",IEN)) Q:'IEN D
279 ..I $E($G(^XWB(8994,IEN,0)),1,LEN)=NMSP,$$REGRPC(IEN,CTX,1)
280 E D
281 .Q:LEN<2
282 .S RPC=NMSP
283 .F D:$L(RPC) S RPC=$O(^XWB(8994,"B",RPC)) Q:NMSP'=$E(RPC,1,LEN)
284 ..F IEN=0:0 S IEN=$O(^XWB(8994,"B",RPC,IEN)) Q:'IEN I $$REGRPC(IEN,.CTX)
285 Q
286 ; Register/unregister an RPC to/from a context
287 ; RPC = IEN or name of RPC
288 ; CTX = IEN or name of context
289 ; DEL = If nonzero, the RPC is unregistered (defaults to 0)
290 ; Returns -1 if already registered; 0 if failed; 1 if succeeded
291REGRPC(RPC,CTX,DEL) ;EP
292 S RPC=+$$GETRPC(RPC)
293 Q $S(RPC<1:0,1:$$REGMULT(19.05,"RPC",RPC,.CTX,.DEL))
294 ; Add/remove a context to/from the ITEM multiple of another context.
295REGCTX(SRC,DST,DEL) ;EP
296 S SRC=+$$GETOPT(SRC)
297 Q $S('SRC:0,1:$$REGMULT(19.01,10,SRC,.DST,.DEL))
298 ; Add/delete an entry to/from a specified OPTION multiple.
299 ; SFN = Subfile #
300 ; NOD = Subnode for multiple
301 ; ITM = Item IEN to add
302 ; CTX = Option to add to
303 ; DEL = Delete flag (optional)
304REGMULT(SFN,NOD,ITM,CTX,DEL) ;
305 N FDA,IEN
306 S CTX=+$$GETOPT(CTX)
307 S DEL=+$G(DEL)
308 S IEN=+$O(^DIC(19,CTX,NOD,"B",ITM,0))
309 Q:'IEN=DEL -1
310 K ^TMP("DIERR",$J)
311 I DEL S FDA(SFN,IEN_","_CTX_",",.01)="@"
312 E S FDA(SFN,"+1,"_CTX_",",.01)=ITM
313 D UPDATE^DIE("","FDA")
314 S FDA='$D(^TMP("DIERR",$J)) K ^($J)
315 Q FDA
316 ; Register a protocol to an extended action protocol
317 ; Input: P-Parent protocol
318 ; C-Child protocol
319REGPROT(P,C,ERR) ;EP
320 N IENARY,PIEN,AIEN,FDA
321 D
322 .I '$L(P)!('$L(C)) S ERR="Missing input parameter" Q
323 .S IENARY(1)=$$FIND1^DIC(101,"","",P)
324 .S AIEN=$$FIND1^DIC(101,"","",C)
325 .I 'IENARY(1)!'AIEN S ERR="Unknown protocol name" Q
326 .S FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN
327 .D UPDATE^DIE("S","FDA","IENARY","ERR")
328 Q:$Q $G(ERR)=""
329 Q
330 ; Remove nonexistent RPCs from context
331CLNRPC(CTX) ;EP
332 N IEN
333 S CTX=+$$GETOPT(CTX)
334 F IEN=0:0 S IEN=$O(^DIC(19,CTX,"RPC","B",IEN)) Q:'IEN D:'$D(^XWB(8994,IEN)) REGRPC(IEN,CTX,1)
335 Q
336 ; Return IEN of option
337GETOPT(X) ;EP
338 N Y
339 Q:X=+X X
340 S Y=$$FIND1^DIC(19,"","X",X)
341 W:'Y "Cannot find option "_X,!!
342 Q Y
343 ; Return IEN of RPC
344GETRPC(X) ;EP
345 N Y
346 Q:X=+X X
347 S Y=$$FIND1^DIC(8994,"","X",X)
348 W:'Y "Cannot find RPC "_X,!!
349 Q Y
Note: See TracBrowser for help on using the repository browser.