source: ePrescribing/trunk/p/C0PCPRS1.m@ 1595

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

initial release of ePrescribing

File size: 13.0 KB
Line 
1C0PCPRS1 ; CCDCCR/GPL - ePrescription utilities; 8/1/09 ; 5/8/12 10:18pm
2 ;;1.0;C0P;;Apr 25, 2012;Build 103
3 ;Copyright 2009 George Lilly. 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 ;
20 Q
21 ;
22 ; THESE ROUTINE CONSTITUTE ALL OF THE ENTRY POINTS IN THE ERX PACKAGE
23 ; THAT ARE USED BY CPRS.
24 ; ERXRPC IS USED BY CPRS TO LAUNCH THE MEDICATION COMPOSE SCREEN
25 ; IT IS ALSO USED BY CPRS TO PROCESS AN INCOMPLETE ORDER ALERT
26 ; ERXPULL IS USED BY CPRS AFTER A SESSION WITH THE EPRESCRIBING PROVIDER
27 ; TO PULL BACK ANY NEW MEDICATIONS AND ALLERGIES FROM THAT SESSION
28 ; IT DOES MEDICATION AND ALLERGY RECONCILLIATION
29 ; ALERTRPC IS USED BY CPRS TO LAUCH THE RENEWAL REQUEST SCREEN IN THE
30 ; EPRECRIBING PROVIDER. AFTER THE RENEWAL SESSION ENDS, ERXPULL IS ALSO
31 ; CALLED
32 ; GPL JUNE, 2010
33 ;
34 ; TEST Lines below not intended for End Users. Programmers only.
35 ; BEWARE ZWRITE SYNTAX. It may not work in other M Implementations.
36TEST1 ; TEST ERX RPC FROM COMMAND LINE - RETURN RAW HTTPS POST ARRAY
37 ;
38 N C0PG1
39 D ERXRPC(.C0PG1,"135","2")
40 W $$OUTPUT^C0CXPATH("C0PG1(1)","Test-RPC-POST1.html","/home/dev/CCR/"),!
41 ZWRITE C0PG1
42 Q
43 ;
44TEST2 ; TEST ERX RPC FROM COMMAND LINE - RETURN CODED HTTPS POST ARRAY
45 ;
46 Q
47 ;
48ERXPULL(RTN,IDUZ,IDFN) ;RPC TO PULL BACK DRUGS AND ALLERGIES
49 ;
50 S ^TMP("GPL","PULLBACKDFN")=IDFN ; debugging
51 N UDFN
52 S UDFN=IDFN
53 I $D(^TMP("C0E",$J,"NEWDFN")) D ; IF THERE IS A NEW RENEWAL PATIENT
54 . I IDFN'=0 Q ; SHOULD BE ZERO FOR A NO MATCH RENEWAL
55 . S UDFN=^TMP("C0E",$J,"NEWDFN") ; GET THE MATCHED PATIENT DFN
56 . S ^TMP("GPL","NEWDFN")=UDFN ; debugging
57 . K ^TMP("C0E",$J,"NEWDFN") ; ERASE IT NOW THAT IT IS USED
58 D GETRXNS^C0PALGY1(IDUZ,UDFN,.RTN) ;PULL BACK ALLERGIES AND ADD TO ALLERGIES
59 D GETMEDS^C0PRECON(IDUZ,UDFN,.RTN) ;PULL BACK MEDS AND ADD TO NON-VA MEDS
60 I $G(RTN(1))="" S RTN(1)="OK"
61 I UDFN'=IDFN S RNT(1)="DFN="_UDFN ; TELL CPRS ABOUT THE NEW DFN
62 ;D REFILL^C0PREFIL ; PULL BACK REFILL REQUESTS EVERY TIME
63 Q
64 ;
65TESTUC0P
66 S ZA="OR,18,11305;135;3120305.103008"
67 D ALERTRPC(.GPL,135,18,1,ZA)
68 Q
69 ;
70TESTALRT(GPL,ZDUZ,ZDFN,MODE) ; TEST THE ALERT RPC
71 ;
72 ;S G=$O(^XTV(8992,135,"XQA",""),-1)
73 ;S G=3110102.15081201
74 ;S ZA="OR,18,11305;135;"_G ;3101223.125521" ; AN ALERT RECORD ID
75 ;S ZA="OR,0,11305;135;3110103.09324904"
76 I $G(MODE)'=1 S MODE=0 ; TEST MODE HERE
77 N ZI,ZJ S ZI=0
78 F S ZI=$O(^XTV(8992,ZDUZ,"XQA",ZI)) Q:ZI="" D ;
79 . S ZJ=^XTV(8992,ZDUZ,"XQA",ZI,0)
80 . I ZJ["no match" S G=ZI
81 I $G(G)="" W !,"OOPS" Q ;
82 S ZA="OR,18,11305;135;"_G
83 ;S ZA="OR,18,11305;135;3110810.123002"
84 W !,ZA
85 D ALERTRPC(.GPL,ZDUZ,ZDFN,1,ZA,MODE)
86 Q
87 I ZDFN=18 D ALERTRPC(.GPL,135,18,1,ZA)
88 E D ;
89 . ;S ZA="OR,0,11305;1;3101223.125521"
90 . D ALERTRPC(.GPL,135,0,1,ZA)
91 Q
92ALERTRPC(RTN,IDUZ,IDFN,DEST,ISTR,MODE) ;RPC FOR ERX ALERTS
93 ; MODE IS A MODE SWITCH IF MODE=1 WE ARE USING THE BROWSER REDIRECT
94 ; METHOD OF CLICKING THROUGH. THIS IS DONE TO COMPLETE NOMATCH RENEWALS
95 ; FROM EWD
96 ; IF MODE IS NOT SPECIFIED OR IS NOT 1, WE WILL USE THE CPRS REDIRECT
97 ; METHOD OF CLICKING THROUGH.
98 ; THE MAIN DIFFERENCE BETWEEN THE TWO MODES IS THE HTML PACKAGING
99 ; SURROUNDING THE NCSCRIPT XML
100 ;
101 I $G(MODE)'=1 S MODE=0 ; MODE IS 0 IF IT'S NOT 1
102 S C0PRMODE=1 ; RENEWAL MODE - KILL AT THE END
103 ;
104 ; FIRST SEE IF LOOK UP THE RENEWAL GUID
105 N ZGUID,ZALRT,C0PMED,ZDOB,ZSEX
106 ; USE THE NEW GETALRT^C0PREFIL TO GET THE GUID DIRECTLY FROM
107 ; THE ALERT TRACKING FILE USING THE RECORDID PASSED IN ISTR
108 ;D GETALRT^C0PREFIL("ZALRT",ISTR) ; GET THE ENTIRE ALERT
109 ;S ZGUID=$G(ZALRT("DATA FOR PROCESSING")) ; PULL OUT THE GUID
110 ; GET THE GUID THE QUICK WAY DIRECTLY FROM THE GLOBAL
111 S ZALRT=$P(ISTR,";",3) ;THE TIME PORTION OF THE RECORD ID
112 S ZGUID=$G(^XTV(8992,IDUZ,"XQA",ZALRT,1)) ;WHERE THE GUID SHOULD BE
113 S ZDOB=$P(ZGUID,"^",2) ; DATE OF BIRTH
114 S ZSEX=$P(ZGUID,"^",3) ; GENDER
115 S ZGUID=$P(ZGUID,"^",1) ; GUID IS PIECE ONE
116 I ZGUID'="" D ; FOUND THE ALERT
117 . N ZNM S ZNM=$G(^XTV(8992,IDUZ,"XQA",ZALRT,0)) ; THE ALERT RECORD
118 . S C0PRNM=$P($P(ZNM,"[eRx] ",2)," Renewal",1) ; patient name
119 . S C0PMED=$P(ZNM,"request for ",2) ; name of the medication
120 ;I ZGUID="" S ^G("NOGUID")=ISTR
121 ;I ZGUID="" M ^G("NOGUID")=^XTV(8992,IDUZ,"XQA")
122UC0P1 I ZGUID="" D Q ; This is usually a missing Alert due to timing
123 . ; of the batch job and the CPRS request to process an error.
124 . W "ERROR EXTRACTING ALERT",!
125 . I $T(LOG^%ZTER)="" D ^%ZTER Q ;
126 . N C0PERR S C0PERR="UC0P1"
127 . S C0PERR("PLACE")="UC0P1^C0PCPRS1"
128 . D LOG^%ZTER(.C0PERR)
129 ;N DONE S DONE=0
130 ;I ZGUID="" D ; TRY AND FIND THE GUID ANYWAY
131 ;. N ZZI S ZZI=0
132 ;. F S ZZI=$O(^XTV(8992,IDUZ,"XQA",ZZI)) Q:DONE Q:ZZI="" D ;
133 ;. . N ZA S ZA=$G(^XTV(8992,IDUZ,"XQA",ZZI,0))
134 ;. . ;W !,ZA B
135 ;. . I ZA="" Q ; SHOULDN'T HAPPEN
136 ;. . I $P(ZA,ZALRT,2)'="" D ;
137 ;. . . N ZNM S ZNM=$G(^XTV(8992,IDUZ,"XQA",ZZI,0)) ; THE ALERT RECORD
138 ;. . . S C0PRNM=$P($P(ZNM,"[eRx] ",2)," Renewal",1) ; patient name
139 ;. . . S ZGUID=$G(^XTV(8992,IDUZ,"XQA",ZZI,1)) ; THE GUID
140 ;. . . S ZDOB=$P(ZGUID,"^",2) ; DATE OF BIRTH
141 ;. . . S ZSEX=$P(ZGUID,"^",3) ; GENDER
142 ;. . . S ZGUID=$P(ZGUID,"^",1) ; GUID IS PIECE ONE
143 ;. . . S C0PMED=$P(ZNM,"request for ",2) ; name of the medication
144 ;. . . S DONE=1
145 I ZGUID="" W "ERROR EXTRACTING ALERT",! Q ;
146 ;S ZGUID=$P(ZGUID,U,3) ;THE VALUE IS IN P3
147 ;S ZIEN=$O(^C0PRE("E","A",IDUZ,IDFN,ISTR,"")) ;LOOK FOR AN ACTIVE ALERT
148 ;I ZIEN="" D Q ; OOPS NO MATCHING ALERT. THIS IS AN ERROR
149 ;. W "ERROR ALERT NOT FOUND",!
150 ;S ZGUID=$$GET1^DIQ(113059006,ZIEN_",",.01,"I")
151 ; BUILD THE NCSRIPT XML FOR RENEWALS
152 N ZTID
153 S ZTID=$$RESTID^C0PWS1(IDUZ,"RENEWREQ") ;
154 N GVOR ; VARIABLE OVERRIDE ARRAY
155 S GVOR=""
156 S GVOR("REQUESTED-PAGE")="renewal"
157 N ZARY,ZURL
158 D EN^C0PMAIN("ZARY","ZURL",IDUZ,IDFN,,"GVOR") ; GET THE NCSCRIPT
159 I IDFN=0 D DELETE^C0CXPATH("ZARY","//NCScript/Patient") ;delete patient
160 I IDFN=0 D ; GOING TO CALL THE EWD RENEWAL PATIENT MATCHING SCREEN
161 . S C0PNONAME=1
162 . S C0PSAV("IDUZ")=IDUZ
163 . M C0PSAV("DUZ")=DUZ
164 . S C0PSAV("DFN")=0
165 . S C0PSAV("C0PRenewalName")=C0PRNM ; THE RENEWAL NAME
166 . S C0PSAV("RenewalDOB")=ZDOB ; PHARMACY REQUEST DATE OF BIRTH
167 . S C0PSAV("RenewalSex")=ZSEX ; PHARMACY REQUEST GENDER
168 . S C0PSAV("renewalToken")=ISTR ; CPRS ALERT TOKEN IDENTIFIER
169 . S C0PMED=$P(C0PMED,"^",1) ; CLEAN UP THE MEDICATION NAME
170 . S C0PSAV("medication")=C0PMED ; MEDICATION BEING RENEWED
171 . S C0PSAV("C0PGuid")=ZGUID ; RENEWAL GUID
172 . S C0PSAV("dollarJ")=$J ; save the $J of the CPRS session
173 . ; PASSING THE SUPERVISING DOCTOR DUZ ALONG TO THE EWD RENEWAL SCREEN
174 . S C0PSAV("SUPERVISING-DUZ")=$G(C0PVARS("SUPERVISING-DOCTOR-DUZ")) ;
175 N ZTMP
176 D GETTEMP^C0PWS1("ZTMP",ZTID)
177 N ZV
178 S ZV("RENEWAL-GUID")=ZGUID
179 S ZV("RESPONSE-CODE")="Undetermined"
180 N ZRVAR,ZREXML
181 D BIND^C0PMAIN("ZRVAR","ZV",ZTID)
182 D MAP^C0CXPATH("ZTMP","ZRVAR","ZREXML")
183 K ZREXML(0) ;
184 D INSERT^C0CXPATH("ZARY","ZREXML","//NCScript")
185 K ZARY(0)
186 D WRAP(.RTN,.ZARY,MODE)
187 K C0PRMODE ; TURN OFF THE RENEWAL MODE
188 Q
189 ;
190ERXRPC(RTN,IDUZ,IDFN) ; RPC CALL TO RETURN HTTPS POST ARRAY FOR MEDS ORDERING
191 ;
192 ;I IDUZ=135 D TESTALRT(.RTN,IDFN) Q ;GPLTESTING
193 N C0PXML,C0PURL
194 D EN^C0PMAIN("C0PXML","C0PURL",IDUZ,IDFN,,,1) ;INCLUDE FREEFORM ALLERGIES
195 D WRAP(.RTN,.C0PXML) ; WRAP IN HTML FOR PROCESSING IN CPRS
196 Q
197 ;
198WRAP(ZRTN,ZINARY,MODE) ;WRAPS AN XML ARRAY (ZINARY) IN HTML FOR PROCESSING
199 ; BY CPRS - ZINARY AND ZRTN ARE PASSED BY REFERENCE
200 ; SEE COMMENT ABOVE ABOUT THE MODE SWITCH
201 I $G(MODE)'=1 S MODE=0 ; BROWSER REDIRECT MODE IS 0 IF IT IS NOT 1
202 ;
203 I '$D(ZINARY(1)) D Q ; NOT SET UP FOR ERX
204 . S ZRTN(1)="ERROR, PROVIDER NOT SUBSCRIBED"
205 I MODE'=1 S ZINARY(1)="RxInput="_ZINARY(1)
206 ; GPL - GET THE URL FROM THE XML TEMPLATE FILE BASED ON PRODUCTION FLAG
207 ;S url="https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx"
208 D SETUP^C0PMAIN() ;INITALIZE C0PACCT WS ACCOUNT IEN
209 S url=$$CTURL^C0PMAIN(C0PACCT) ; PRODUCTION OR TEST URL
210 I $G(C0PNONAME)=1 D ;
211 . I MODE Q ; WE'VE ALREADY BEEN TO EWD. THIS IS SECOND TIME
212 . n token s token=$$STORE^C0CEWD("C0PSAV") ; STORE FOR EWD SCREENS
213 . N ZT,ZU,ZP
214 . S ZT=$O(^C0PX("B","C0P RENEWAL NOMATCH URL","")) ; IEN FOR URL
215 . ; EXAMPLE URL: https://viper/dev/eRx/index1.ewd - be sure it matches
216 . ; your system
217 . S ZU=$$GET1^DIQ(113059001,ZT_",",1) ; URL OF NOMATCH RENEWAL SCREEN
218 . I C0PVARS("SUBSCRIBER-USERTYPE")="MidlevelPrescriber" S ZP="midmatch.ewd"
219 . E S ZP="index1.ewd" ; midlevels get their own page
220 . S url=ZU_ZP_"?token="""_token_"""" ; ewd interface
221 . S C0PNONAME=0
222 I MODE D BRSRDR Q ; BROWSER REDIRCT PACKAGEING INSTEAD OF httpPOST2
223 S ok=$$httpPOST2(.ZRTN,url,.ZINARY,"application/x-www-form-urlencoded",.gpl6,"","",.gpl5,.gpl7)
224 Q
225 ;
226BRSRDR ; GENERATE BROWSER REDIRECT PACKAGING TO RETURN TO BE SENT TO THE
227 ; BROWSER
228 ;
229 N ZB,ZTMP,ZTOP,ZBOT,ZTID1,ZTID2,ZVARS
230 S ZTID1=$$RESTID^C0PWS1(IDUZ,"C0P RENEWAL BRSRDR TOP") ; TOP XML IEN
231 S ZTID2=$$RESTID^C0PWS1(IDUZ,"C0P RENEWAL BRSRDR BOTTOM") ; BOTTOM XML IEN
232 D GETXML^C0PWS1("ZTMP",ZTID1) ; TOP XML
233 S ZVARS("url")=url
234 D MAP^C0CXPATH("ZTMP","ZVARS","ZTOP") ; SET THE URL PROPERLY
235 D GETXML^C0PWS1("ZBOT",ZTID2) ; BOTTOM XML
236 D QUEUE^C0CXPATH("ZB","ZTOP",1,$O(ZTOP(""),-1)) ; ADD TOP TO BUILD LIST
237 D QUEUE^C0CXPATH("ZB","ZINARY",1,$O(ZINARY(""),-1)) ; ADD NCSCRIPT
238 D QUEUE^C0CXPATH("ZB","ZBOT",1,$O(ZBOT(""),-1)) ; ADD BOTTOM
239 D BUILD^C0CXPATH("ZB","ZRTN") ; BUILD RETURN HTML
240 K ZRTN(0) ; KILL LENTGH NODE
241 Q
242 ;
243GETPOST1(URL) ;
244 ;RETRIEVES WSDL SAMPLE XML FROM A WEBSERVICE AT ADDRESS URL PASSED BY VALUE
245 ;RETURNS THE XML IN ARRAY gpl
246 s ok=$$httpGET^%zewdGTM(URL,.gpl)
247 ;W "XML retrieved from Web Service:",!
248 ;ZWR gpl
249 D INDEX^C0CXPATH("gpl","gpl2",-1,"gplTEMP")
250 Q
251 ;
252httpPOST2(ARY,url,payload,mimeType,html,headerArray,timeout,test,rawResponse,respHeaders,sslHost,sslPort)
253 ;ORGINALLY THIS ROUTINE WAS FROM zewdGTM.m (thanks Rob!)
254 ;HACKED BY GPL TO RETURN ITS HTML IN AN ARRAY (ARY PASSED BY REF)
255 ;INSTEAD OF SENDING IT OUT A TPC PORT
256 ;THE ARY WILL BE SENT VIA RPC TO CPRS TO LAUNCH A BROWERS
257 ;USING THIS "POST" HTML AS THE STARTING PAGE (THANKS ART)
258 ;USES THE ROUTINE gw BELOW TO BUILD THE ARRAY
259 ; todo: html not used, test not used, rawResponse, respHeaders
260 ; sam's notes: this routine doesn't actually post anything; it just formats.
261 n contentLength,dev,host,HTTPVersion,io,port,rawURL,ssl,urllc
262 n zg ; gpl
263 ;
264 k rawResponse,html
265 s HTTPVersion="1.0"
266 s rawURL=url
267 s ssl=0
268 s port=80
269 s urllc=$$zcvt^%zewdAPI(url,"l")
270 i $e(urllc,1,7)="http://" d
271 . s url=$e(url,8,$l(url))
272 . s sslHost=$p(url,"/",1)
273 . s sslPort=80
274 e i $e(urllc,1,8)="https://" d
275 . s url=$e(url,9,$l(url))
276 . s ssl=1
277 . s sslHost=$g(sslHost)
278 . i sslHost="" s sslHost="127.0.0.1"
279 . s sslPort=$g(sslPort)
280 . i sslPort="" s sslPort=89
281 e QUIT "Invalid URL"
282 s host=$p(url,"/",1)
283 i host[":" d
284 . s port=$p(host,":",2)
285 . s host=$p(host,":",1)
286 s url="/"_$p(url,"/",2,5000)
287 i $g(timeout)="" s timeout=20
288 ;
289 ;GPL s io=$io
290 i $g(test)'=1 d
291 . ;GPL s dev=$$openTCP(sslHost,sslPort,timeout)
292 ;GPL . u dev
293 i ssl d
294 . ;w "POST "_rawURL_" HTTP/"_HTTPVersion_$c(13,10)
295 . s zg="POST "_rawURL_" HTTP/"_HTTPVersion_"^M"
296 . d gw(zg)
297 e d
298 . ;w "POST "_url_" HTTP/"_HTTPVersion_$c(13,10)
299 . s zg="POST "_url_" HTTP/"_HTTPVersion_"^M"
300 . d gw(zg)
301 ;w "Host: "_host
302 s zg="Host: "_host
303 d gw(zg)
304 i port'=80 s zg=":"_port d gw(zg) ;w ":"_port
305 s zg=$c(13,10) d gw(zg) ;w $c(13,10)
306 s zg="Accept: */*"_$c(13,10) d gw(zg) ;w "Accept: */*"_"^M"
307 ;
308 i $d(headerArray) d
309 . n n
310 . s n=""
311 . f s n=$o(headerArray(n)) q:n="" d
312 . . ;w headerArray(n)_$c(13,10)
313 . . s zg=headerArray(n)_"^M"
314 . . d gw(zg)
315 ;
316 s mimeType=$g(mimeType)
317 i mimeType="" s mimeType="application/x-www-form-urlencoded"
318 s contentLength=0
319 i $d(payload) d
320 . n no
321 . s no=""
322 . f s no=$O(payload(no)) q:no="" D
323 . . s contentLength=contentLength+$l(payload(no))
324 . s contentLength=contentLength
325 . s zg="Content-Type: "_mimeType ;w "Content-Type: ",mimeType
326 . d gw(zg)
327 . i $g(charset)'="" d ;
328 . . ;w "; charset=""",charset,""""
329 . . s zg="; charset="""_charset_""""
330 . . d gw(zg)
331 . s zg="^M" d gw(zg) ;w $c(13,10)
332 . ;w "Content-Length: ",contentLength,$c(13,10)
333 . s zg="Content-Length: "_contentLength_"^M"
334 . d gw(zg)
335 ;
336 s zg="^M" d gw(zg) ;w $c(13,10)
337 i $D(payload) d
338 . n no
339 . s no=""
340 . f s no=$O(payload(no)) q:no="" d
341 . . ;w payload(no)
342 . . s zg=payload(no)
343 . . d gw(zg)
344 ;
345 s zg="^M" d gw(zg) ;w $c(13,10)
346 ;w $c(13,10),! gpl- what does a bang send out????????
347 ;
348 ; That's the request sent !
349 ;
350 ;g httpResponse
351 ;
352 q ""
353 ;
354gw(LINE) ; Private proc; Adds line to end of array
355 ;
356 I '$D(ARY(1)) S ARY(1)=LINE
357 E D ;
358 . N CNT
359 . S CNT=$O(ARY(""),-1)
360 . S CNT=CNT+1
361 . S ARY(CNT)=LINE
362 Q
363 ;
Note: See TracBrowser for help on using the repository browser.