| [1595] | 1 | C0PCPRS1 ; 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.
|
|---|
| 36 | TEST1 ; 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 | ;
|
|---|
| 44 | TEST2 ; TEST ERX RPC FROM COMMAND LINE - RETURN CODED HTTPS POST ARRAY
|
|---|
| 45 | ;
|
|---|
| 46 | Q
|
|---|
| 47 | ;
|
|---|
| 48 | ERXPULL(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 | ;
|
|---|
| 65 | TESTUC0P
|
|---|
| 66 | S ZA="OR,18,11305;135;3120305.103008"
|
|---|
| 67 | D ALERTRPC(.GPL,135,18,1,ZA)
|
|---|
| 68 | Q
|
|---|
| 69 | ;
|
|---|
| 70 | TESTALRT(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
|
|---|
| 92 | ALERTRPC(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")
|
|---|
| 122 | UC0P1 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 | ;
|
|---|
| 190 | ERXRPC(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 | ;
|
|---|
| 198 | WRAP(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 | ;
|
|---|
| 226 | BRSRDR ; 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 | ;
|
|---|
| 243 | GETPOST1(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 | ;
|
|---|
| 252 | httpPOST2(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 | ;
|
|---|
| 354 | gw(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 | ;
|
|---|
