source: ePrescribing/trunk/p/C0PRECON.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: 10.5 KB
Line 
1C0PRECON ; VEN/SMH - Utilities for Medication Reconciliation; 5/8/12 4:34pm
2 ;;1.0;C0P;;Apr 25, 2012;Build 103
3 ;Copyright 2009 Sam Habiel. Licensed under the terms of the GNU
4 ;General Public License See attached copy of the License.
5 ;
6 ;This program is free software; you can redistribute it and/or modify
7 ;it under the terms of the GNU General Public License as published by
8 ;the Free Software Foundation; either version 2 of the License, or
9 ;(at your option) any later version.
10 ;
11 ;This program is distributed in the hope that it will be useful,
12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;GNU General Public License for more details.
15 ;
16 ;You should have received a copy of the GNU General Public License along
17 ;with this program; if not, write to the Free Software Foundation, Inc.,
18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19 Q
20 ;
21GETMEDS(C0PDUZ,C0PDFN,ZRTN) ; Public Proc
22 ; Retreives meds from WebService, matches them against VistA,
23 ; compares them with current meds, saves into Non-Va multiple in file 55
24 ; (pharmacy patient)
25 ;
26 ; Input:
27 ; - C0PDUZ: DUZ
28 ; - C0PDFN: DFN
29 ;
30 I $G(^TMP("C0PNOPULLBACK")) Q ; TURNS OFF PULLBACK PROCESSING
31 ; FOR TESTING NEW CROP OPTIONS - KEEPS VISTA ERX DRUGS INTACT AND ADDS NO
32 ; NEW DRUGS
33 N C0PWSMEDS
34 D SOAP^C0PWS1("C0PWSMEDS","GETMEDS",C0PDUZ,C0PDFN) ; soap call for WS meds
35 I C0PWSMEDS(1,"Status")'="OK" Q ; bad return from ws call
36 N CURRENTMEDS
37 D GET^C0PCUR(.CURRENTMEDS,C0PDFN) ; current meds in VistA
38 N ZDUPS ; ARRAY TO KEEP TRACK OF DUPLICATES SO THAT WE CAN
39 ; DISCONTINUE ERX MEDS THAT ARE NOT IN THE WEB SERVICE LIST
40 N I
41 FOR I=1:1:C0PWSMEDS(1,"RowCount") DO
42 . N MEDTOADD M MEDTOADD=C0PWSMEDS(I)
43 . N DUPID S DUPID=$$DUP(MEDTOADD("DrugID"),.CURRENTMEDS) ; check for dups
44 . N MEDTXT S MEDTXT=$$FULLNAME^C0PLKUP(MEDTOADD("DrugID"))
45 . I 'DUPID S DUPID=$$FREMAT(MEDTXT,.CURRENTMEDS) ;check
46 . ; for free text drug match gpl
47 . I DUPID S ZDUPS(DUPID,I)="" ; INDEX BY CURRENT MED NUMBER
48 . I DUPID D ; if indeed duplicate, check if WS Drug is newer drug
49 . . N RXDATENOTIME
50 . . S RXDATENOTIME=$P($$FMDATE(MEDTOADD("PrescriptionDate")),".")
51 . . I RXDATENOTIME>CURRENTMEDS(DUPID,"START") D ; if newer
52 . . . ;D DC^C0PNVA(C0PDFN,$P(CURRENTMEDS(DUPID,0),U)) ;dc old one
53 . . . D DC^C0PNVA(C0PDFN,CURRENTMEDS(DUPID,"NVAIEN")) ; gpl
54 . . . D ADD(.MEDTOADD,C0PDFN,C0PDUZ) ; add new one
55 . . E ; do nothing here: Current med in Vista is newer or equivalent one
56 . E D ADD(.MEDTOADD,C0PDFN,C0PDUZ) ; not a duplicate med
57 ; NOW LOOK THROUGH CURRENT MEDS TO SEE WHICH NEED TO BE DISCONTINUED
58 S I=""
59 F S I=$O(CURRENTMEDS(I)) Q:I="" D ; FOR EACH CURRENT MED
60 . I $O(ZDUPS(I,""))="" D ; DUPLICATE DRUG NOT FOUND
61 . . I $P(CURRENTMEDS(I,0),U,9)'="ACTIVE" Q ; might be discontinued
62 . . S ZT=$$DRUGNAM^C0PLKUP(.CURRENTMEDS,I)
63 . . I ZT="" S ZT=$P(CURRENTMEDS(I,0),U,2)
64 . . N ZN S ZN=$P($G(CURRENTMEDS(I,0)),U,1)
65 . . S ZT=ZN_" "_ZT
66 . . ;S ZT=$P(CURRENTMEDS(I,0),U,1)_" "_$P(CURRENTMEDS(I,0),U,2)
67 . . I ZN["N;" D ; DISCONTINUE THE NONVA MED
68 . . . I $G(CURRENTMEDS(I,"COMMENTS",1))["Received from E-Rx Web Service" D ;
69 . . . . D DC^C0PNVA(C0PDFN,CURRENTMEDS(I,"NVAIEN")) ;dc the med
70 . . . . S ZT="Discontinued "_ZT
71 . . E S ZT="Can't Discontinue "_ZT
72 . . D MAPERR(.ZRTN,"DRUGS",ZT)
73 QUIT
74ADD(MEDTOADD,C0PDFN,C0PDUZ) ; Private Proc - Add med to VistA
75 ; Input:
76 ; - MEDTOADD: WebService Drug information, by Reference
77 ; - C0PDFN: DFN, by Value
78 ; - C0PDUZ: DUZ, By Value
79 ; Output:
80 ; - None
81 N DRUGS S DRUGS=$$DRUG2^C0PLKUP(MEDTOADD("DrugID"))
82 N ZR,ZII ; GPL NEED TO FIND A NON-ZERO MATCH
83 F ZII=1:1:10 S ZR=$P(DRUGS,U,ZII) Q:ZR>0 ; $$DRUG2 RETURNS a^b^c FOR MATCHES
84 S DRUGS=ZR ; WE WANT THE FIRST NON-ZERO MATCH
85 I +DRUGS=0 DO QUIT
86 . D SENDMSG(.MEDTOADD,C0PDFN)
87 . D NFADD(.MEDTOADD,C0PDFN,C0PDUZ)
88 . N ZT
89 . S ZT="Error Mapping Drug: "_MEDTOADD("DrugName")_" ID: "_MEDTOADD("DrugID")
90 . D MAPERR(.ZRTN,"DRUGS",ZT) ; CALL ERROR ROUTINE TO RECORD NO MATCH FOR DRUG
91 N DRUG S DRUG=+DRUGS ; grab the first entry; as good as any for now
92 N ORDIEN S ORDIEN=$$GET1^DIQ(50,DRUG,"PHARMACY ORDERABLE ITEM","I")
93 N DOSAGE S DOSAGE=MEDTOADD("DosageNumberDescription")_" "_MEDTOADD("DosageForm")
94 ; ****** ADDED BY GPL 10/5/10 TO ALWAYS CAPTURE FDB NAME IN SIG
95 N MEDTXT S MEDTXT=$$FULLNAME^C0PLKUP(MEDTOADD("DrugID"))
96 I MEDTXT="" S MEDTXT=MEDTOADD("DrugName") ; drug not found condition gpl
97 S DOSAGE=MEDTXT_"| "_MEDTOADD("DosageNumberDescription")_" "_MEDTOADD("DosageForm") ; | delimiter added by gpl 2/5/2010
98 ; ****** END MOD
99 N ROUTE S ROUTE=MEDTOADD("Route")
100 N SCHEDULE S SCHEDULE=MEDTOADD("DosageFrequencyDescription")
101 I MEDTOADD("TakeAsNeeded")="Y" S SCHEDULE=SCHEDULE_" PRN" ; Vista stores PRN in schedule
102 N START S START=$$FMDATE(MEDTOADD("PrescriptionDate"))
103 N COMMENT
104 S COMMENT(1)="Received from E-Rx Web Service" ;todo: move to dialog file
105 S COMMENT(2)="Order Guid: "_$G(MEDTOADD("OrderGuid"))
106 S COMMENT(3)="Physician Name: "_$G(MEDTOADD("PhysicianName"))
107 S COMMENT(4)="Prescription Date: "_$G(MEDTOADD("PrescriptionDate"))
108 S COMMENT(5)="Prescription Guid: "_$G(MEDTOADD("PrescriptionGuid"))
109 S COMMENT(6)="Notes: "_$G(MEDTOADD("PrescriptionNotes"))
110 ; add codes for Certification and Free Txt repair processing - gpl
111 S COMMENT(7)=$$CODES^C0PLKUP(MEDTOADD("DrugID")) ;
112 D FILE^C0PNVA(C0PDFN,ORDIEN,DRUG,DOSAGE,ROUTE,SCHEDULE,START,C0PDUZ,.COMMENT)
113 QUIT
114MAPERR(ZRTN,ZTYP,ZTXT) ; ZTYP IS THE TYPE OF MAPPING ERROR
115 ; (IE DRUGS OR ALLERGY)
116 ; ZRTN IS PASSED BY REFERENCE AND IS THE ARRAY OF ERROR MESSAGES
117 ; THIS ROUTINE ADDS THE ERROR MESSAGE TO THE END OF THE ARRAY
118 ; ZTXT IS THE ERROR MESSAGE
119 ;
120 N ZI
121 I $G(^TMP("C0PDEBUG"))="" Q ; ONLY SHOW MAPPING ERRORS ON DEBUG
122 I '$D(ZRTN) S ZI=1
123 E S ZI=$O(ZRTN(""),-1)+1 ;ONE PASSED THE END OF ZRTN
124 S ZRTN(ZI)=ZTXT
125 Q
126 ;
127FMDATE(C0PD) ; Public $$ - Get fileman date from dates formatted like 11/7/09 10:22:34 PM
128 ; Input: Date like 11/7/09 10:22:34 PM
129 ; Output: Timson date precise up to seconds
130 S $E(C0PD,$F(C0PD," ")-1)="@" ; put @ b/n date and time for fm
131 N %DT S %DT="TS" ; seconds are required
132 N X,Y
133 S X=C0PD D ^%DT
134 I Y<0 D ^%ZTER ; Problem converting date... wake up programmer
135 QUIT Y
136 ;
137DUP(FDBDRUGID,CURRENTMEDS) ; Private $$ - Is Drug already documented for patient?
138 ; Input:
139 ; FDBDRUGID By Value
140 ; CURRENTMEDS By Reference
141 ; Output:
142 ; "" if no duplicate
143 ; CURRENTMEDS ien if duplicate
144 N DRUGS S DRUGS=$$DRUG2^C0PLKUP(FDBDRUGID)
145 ; add a check for the CODES in Comment(6) - to update if not there
146 N C0PCODES S C0PCODES=$$CODES^C0PLKUP(FDBDRUGID)
147 N I S I=""
148 N FOUND S FOUND=0
149 F Q:FOUND=1 S I=$O(CURRENTMEDS(I)) Q:I="" D ; loop through current meds
150 . I '$D(CURRENTMEDS(I,"DRUG")) QUIT ; continue if no drug id
151 . I $G(CURRENTMEDS(I,"COMMENTS",1))'["Received from E-Rx Web Service" Q ;
152 . ; DON'T MATCH ON DRUGS THAT ARE NOT ERX
153 . ; check for CODES in COMMENTS(6)
154 . I $G(CURRENTMEDS(I,"COMMENTS",6))'=C0PCODES D ; add codes
155 . . ;S ^PS(55,C0PDFN,"NVA",I,1,7,0)=C0PCODES ; right into the global
156 . I $P(CURRENTMEDS(I,0),U,9)'["ACTIVE" QUIT ; quit if not active
157 . I ("^"_DRUGS_"^")[("^"_CURRENTMEDS(I,"DRUG")_"^") S FOUND=1
158 QUIT I ; entry if Found, "" if not found
159 ;
160FREMAT(FDBDNAME,CURRENTMEDS,ZMED) ;MATCH A FREE TEXT DRUG EXTRINSIC
161 ; THE DRUG ID HAS BEEN STORED IN THE COMMENT OF EACH ERX NONVA DRUG
162 ; ZMED IS WHICH DRUG IN CURRENTMEDS WHICH IS PASSED BY REF
163 ; FDBDNAME IS THE DRUG NAME AND IS PASSED BY VALUE ; GPL
164 N I S I=""
165 ; add a check for the CODES in Comment(6) - to update if not there
166 N C0PCODES S C0PCODES=$$CODES^C0PLKUP(MEDTOADD("DrugID"))
167 N FOUND S FOUND=0
168 F Q:FOUND=1 S I=$O(CURRENTMEDS(I)) Q:I="" D ; loop through current meds
169 . I $D(CURRENTMEDS(I,"DRUG")) QUIT ; SKIP OVER MAPPED DRUGS
170 . I $P(CURRENTMEDS(I,0),U,9)'["ACTIVE" QUIT ; quit if not active
171 . I FDBDNAME=$$DRUGNAM^C0PLKUP(.CURRENTMEDS,I) S FOUND=1
172 I FOUND=1 D ;
173 . S ZT="Drug Dup Found: "_MEDTOADD("DrugName")_" ID: "_MEDTOADD("DrugID")
174 . ; check for CODES in COMMENTS(6)
175 . I $G(CURRENTMEDS(I,"COMMENTS",6))'=C0PCODES D ; add codes
176 . . ;S ^PS(55,C0PDFN,"NVA",I,1,7,0)=C0PCODES ; right into the global
177 . D MAPERR(.ZRTN,"DRUGS",ZT) ; CALL ERROR ROUTINE TO RECORD NO MATCH FOR DRUG
178 Q I ; entry if Found, "" if not found
179 ;
180SENDMSG(MEDTOADD,C0PDFN) ; Private EP - Send Bulletin saying drug not found
181 ; Input:
182 ; - MEDTOADD: WS Med entry By Reference
183 ; - C0PDFN: DFN by Value
184 ; Output:
185 ; - None
186 ; info: tested 12/14/09
187 ; todo: move this to a background call - it takes too long!
188 N DUZ ; remove old value to make the postmaster the sender
189 N XMDUZ S XMDUZ="E-Rx WebService" ; supposed sender
190 N XMTEXT ; unused
191 N XMY ; unused
192 N XMBTMP ; unused
193 N XMDF ; unused
194 N XMDT ; unused - will send message now
195 N XMYBLOB ; unused
196 N XMB
197 S XMB="C0P EXTERNAL DRUG NOT FOUND" ; bulletin name
198 S (XMB(1),XMB(5))=$$GET1^DIQ(2,C0PDFN,"PRIMARY LONG ID") ; chart #
199 S (XMB(2),XMB(3))=$$FULLNAME^C0PLKUP(MEDTOADD("DrugID")) ; drug not matched
200 S XMB(4)=$$GET1^DIQ(2,C0PDFN,.01) ; patient name
201 D ^XMB
202 QUIT
203 ;
204NFADD(MEDTOADD,C0PDFN,C0PDUZ) ; Private Proc - Add free text med to VistA
205 ; Input:
206 ; - MEDTOADD: WebService Drug information, by Reference
207 ; - C0PDFN: DFN, by Value
208 ; - C0PDUZ: DUZ, By Value
209 ; Output:
210 ; - None
211 ; info: tested 12/16/09
212 ; Stores med along side dosage in dosage field as free text
213 N ORDIEN S ORDIEN=$$FIND1^DIC(50.7,"","QX","FREE TXT DRUG","B") ; todo: change to a parameter
214 N DOSAGE
215 N MEDTXT S MEDTXT=$$FULLNAME^C0PLKUP(MEDTOADD("DrugID"))
216 I MEDTXT="" S MEDTXT=MEDTOADD("DrugName") ; drug not found condition gpl
217 S DOSAGE=MEDTXT_"| "_MEDTOADD("DosageNumberDescription")_" "_MEDTOADD("DosageForm") ; | delimiter added by gpl 2/5/2010
218 N ROUTE S ROUTE=MEDTOADD("Route")
219 N SCHEDULE S SCHEDULE=MEDTOADD("DosageFrequencyDescription")
220 I MEDTOADD("TakeAsNeeded")="Y" S SCHEDULE=SCHEDULE_" PRN" ;
221 N START S START=$$FMDATE(MEDTOADD("PrescriptionDate"))
222 N COMMENT
223 S COMMENT(1)="Received from E-Rx Web Service" ;todo: move to dialog file
224 S COMMENT(2)="Order Guid: "_$G(MEDTOADD("OrderGuid"))
225 S COMMENT(3)="Physician Name: "_$G(MEDTOADD("PhysicianName"))
226 S COMMENT(4)="Prescription Date: "_$G(MEDTOADD("PrescriptionDate"))
227 S COMMENT(5)="Prescription Guid: "_$G(MEDTOADD("PrescriptionGuid"))
228 S COMMENT(6)="Notes: "_$G(MEDTOADD("PrescriptionNotes"))
229 ; add codes for Certification and Free Txt repair processing - gpl
230 S COMMENT(7)=$$CODES^C0PLKUP(MEDTOADD("DrugID")) ;
231 D FILE^C0PNVA(C0PDFN,ORDIEN,"",DOSAGE,ROUTE,SCHEDULE,START,C0PDUZ,.COMMENT)
232 ;N COMMENT ;added DrugID to comment 1/27/2010 gpl
233 ;S COMMENT="Received from E-Rx Web Service (DrugID:"_MEDTOADD("DrugID")_")"
234 ;D FILE^C0PNVA(C0PDFN,ORDIEN,"",DOSAGE,ROUTE,SCHEDULE,START,C0PDUZ,COMMENT)
235 QUIT
Note: See TracBrowser for help on using the repository browser.