| [1595] | 1 | C0PWS2 ; ERX/GPL - Web Service utilities; 8/31/09; 12/08/2010 ; 5/9/12 12:29am
|
|---|
| 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 | ; Modified by Chris Richardson, November, 2010.
|
|---|
| 6 | ; Code has been modified to accept very large XML documents and block them logically.
|
|---|
| 7 | ; 3101208 - RCR - Correct end of buffer condition, BF=">"
|
|---|
| 8 | QUIT
|
|---|
| 9 | ;
|
|---|
| 10 | ; TEST Lines below not intended for End Users. Programmers only.
|
|---|
| 11 | ; BEWARE ZWRITE SYNTAX. It may not work in other M Implementations.
|
|---|
| 12 | TEST(C0PDUZ,C0PDFN) ; TEST RETRIEVAL OF PATIENT1 MEDS
|
|---|
| 13 | ;S DEBUG=1 ;
|
|---|
| 14 | D SOAP("C0POUT",6,C0PDUZ,C0PDFN)
|
|---|
| 15 | ZWRITE C0POUT ; Should use ^%ZOSV Node, this is very GT.M Specific
|
|---|
| 16 | QUIT
|
|---|
| 17 | ;
|
|---|
| 18 | ACCOUNTF() QUIT 113059002 ; file number for account file
|
|---|
| 19 | ;
|
|---|
| 20 | XMLFN() QUIT 113059001 ; XML TEMPLATE FILE NUMBER
|
|---|
| 21 | ;
|
|---|
| 22 | BINDFN() QUIT 113059001.04 ; FILE NUMBER FOR BINDING SUBFILE
|
|---|
| 23 | ;
|
|---|
| 24 | ;
|
|---|
| 25 | GETTID(C0PWS,C0PTNAME) ; EXTRINSIC WHICH RETURNS THE TEMPLATE ID FOR
|
|---|
| 26 | ; TEMPLATE NAMED C0PTNAME BELONGING TO WEB SERVICE NAMED C0PWS
|
|---|
| 27 | ; ALSO WORKS IF THE ACCOUNT NUMBER IS PASSED IN C0PWS
|
|---|
| 28 | S C0PXF=113059001 ; FILE NUMBER FOR THE C0P XML TEMPLATE FILE
|
|---|
| 29 | S C0PAF=113059002 ; FILE NUMBER FOR THE C0P WS ACCT FILE
|
|---|
| 30 | N C0PA,C0PT ; C0P ACCOUNT AND C0P TEMPLATE
|
|---|
| 31 | DO
|
|---|
| 32 | . I C0PWS>0 S C0PA=C0PWS QUIT
|
|---|
| 33 | . ;
|
|---|
| 34 | . DO ; NAME NOT RECORD NUMBER IS PASSED FOR ACCOUNT
|
|---|
| 35 | . . S C0PA=$O(^C0PS("B",C0PWS,"")) ; RECORD NUMBER OF ACCOUNT
|
|---|
| 36 | . . I C0PA="" D Q ; OOPS ACCOUNT NOT FOUND
|
|---|
| 37 | . . . W "ACCOUNT "_C0PWS_" NOT FOUND",!
|
|---|
| 38 | . . .QUIT
|
|---|
| 39 | . .QUIT
|
|---|
| 40 | .QUIT
|
|---|
| 41 | S C0PT=$O(^C0PX("C",C0PA,C0PTNAME,"")) ; RECORD NUMBER OF TEMPLATE
|
|---|
| 42 | ; WE USE THE C INDEX TO INSURE THAT THE TEMPLATE BELONGS TO THE WEB SERVICE
|
|---|
| 43 | Q C0PT
|
|---|
| 44 | ;
|
|---|
| 45 | RESTID(C0PDUZ,C0PTID) ; RESOLVE TEMPLATE ID FROM SUBSCRIPTION
|
|---|
| 46 | ;
|
|---|
| 47 | N C0PAIEN,COPACCT,COPWBS,COPUTID
|
|---|
| 48 | S C0PAIEN=$$SUBINIT^C0PSUB(C0PDUZ) ;IEN OF SUBSCRIPTION
|
|---|
| 49 | ; N C0PACCT
|
|---|
| 50 | S C0PACCT=$$GET1^DIQ(C0PSUBF,C0PAIEN_","_C0PDUZ_",",1,"I") ;ACCT
|
|---|
| 51 | ; N C0PWBS
|
|---|
| 52 | S C0PWBS=$$GET1^DIQ(C0PAF,C0PACCT_",",4,"I") ;WEB SERVICE IEN
|
|---|
| 53 | ; N C0PUTID
|
|---|
| 54 | S C0PUTID=$$GETTID(C0PWBS,C0PTID) ;TEMPLATE ID
|
|---|
| 55 | Q C0PUTID
|
|---|
| 56 | ;
|
|---|
| 57 | SOAP(C0PRTN,C0PTID,C0PDUZ,C0PDFN,C0PVOR) ; MAKES A SOAP CALL FOR
|
|---|
| 58 | ; TEMPLATE ID C0PTID
|
|---|
| 59 | ; RETURNS THE XML RESULT IN C0PRTN, PASSED BY NAME
|
|---|
| 60 | ; C0PVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED
|
|---|
| 61 | ; BEFORE MAPPING
|
|---|
| 62 | ;
|
|---|
| 63 | ; ARTIFACTS SECTION
|
|---|
| 64 | ; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE
|
|---|
| 65 | ; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS
|
|---|
| 66 | ; WILL NOT BE NEWED.
|
|---|
| 67 | I $G(DEBUG)="" N C0PV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS
|
|---|
| 68 | S C0PV(100,"C0PXF","XML TEMPLATE FILE NUMBER")=""
|
|---|
| 69 | S C0PV(200,"C0PHEAD","SOAP HEADER VARIABLE NAME")=""
|
|---|
| 70 | S C0PV(300,"header","SOAP HEADER")=""
|
|---|
| 71 | S C0PV(400,"C0PMIME","MIME TYPE")=""
|
|---|
| 72 | S C0PV(500,"C0PURL","WS URL")=""
|
|---|
| 73 | S C0PV(550,"C0PPURL","PROXY URL")=""
|
|---|
| 74 | S C0PV(600,"C0PXML","XML VARIABLE NAME")=""
|
|---|
| 75 | S C0PV(700,"xml","OUTBOUND XML")=""
|
|---|
| 76 | S C0PV(800,"C0PRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")=""
|
|---|
| 77 | S C0PV(900,"C0PRHDR","RETURNED HEADER")=""
|
|---|
| 78 | S C0PV(1000,"C0PRXML","XML RESULT NORMALIZED")=""
|
|---|
| 79 | S C0PV(1100,"C0PR","REPLY TEMPLATE")=""
|
|---|
| 80 | S C0PV(1200,"C0PREDUX","REDUX STRING")=""
|
|---|
| 81 | S C0PV(1300,"C0PIDX","RESULT XPATH INDEX")=""
|
|---|
| 82 | S C0PV(1400,"C0PARY","RESULT XPATH ARRAY")=""
|
|---|
| 83 | S C0PV(1500,"C0PNOM","RESULT DOM DOCUMENT NAME")=""
|
|---|
| 84 | S C0PV(1600,"C0PID","RESULT DOM ID")=""
|
|---|
| 85 | N ZI,ZN,ZS
|
|---|
| 86 | S ZN=""
|
|---|
| 87 | D:$G(DEBUG)="" ; G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG
|
|---|
| 88 | . S ZI="",ZN="",ZS=""
|
|---|
| 89 | . F S ZI=$O(COPV(ZI)) Q:ZI="" D
|
|---|
| 90 | . . ; S ZJ=$O(C0PV(ZI,"")) ; SET UP NEW COMMAND
|
|---|
| 91 | . . S ZN=ZN_ZS_$O(C0PV(ZI,"")),ZS=","
|
|---|
| 92 | . .QUIT
|
|---|
| 93 | .QUIT
|
|---|
| 94 | I $L(ZN) N @ZN ; Apply collected NEW Variables 1 time
|
|---|
| 95 | ; NEW
|
|---|
| 96 | ; S ZI=$O(C0PV(ZI))
|
|---|
| 97 | ; S ZJ=$O(C0PV(ZI,"")) ; SET UP NEW COMMAND
|
|---|
| 98 | ;W ZJ,!
|
|---|
| 99 | ; N @ZJ ; NEW THE VARIABLE
|
|---|
| 100 | ; I $O(C0PV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT
|
|---|
| 101 | ;NOTNEW
|
|---|
| 102 | ; END ARTIFACTS
|
|---|
| 103 | ;
|
|---|
| 104 | D INITXPF("C0PF") ; SET FILE NUMBER AND PARAMATERS
|
|---|
| 105 | S C0PXF=C0PF("XML FILE NUMBER") ; FILE NUMBER FOR THE C0P XML TEMPLATE FILE
|
|---|
| 106 | D
|
|---|
| 107 | . I +C0PTID=0 D Q ; A STRING WAS PASSED FOR THE TEMPLATE NAME
|
|---|
| 108 | . . S C0PUTID=$$RESTID(C0PDUZ,C0PTID) ;RESOLVE TEMPLATE IEN FROM NAME
|
|---|
| 109 | . .QUIT
|
|---|
| 110 | . ;
|
|---|
| 111 | . S C0PUTID=C0PTID ; AN IEN WAS PASSED
|
|---|
| 112 | .QUIT
|
|---|
| 113 | N xml,template,header
|
|---|
| 114 | S C0PHEAD=$$GET1^DIQ(C0PXF,C0PUTID_",",2.2,,"header")
|
|---|
| 115 | S C0PMIME=$$GET1^DIQ(C0PXF,C0PUTID_",","MIME TYPE")
|
|---|
| 116 | S C0PPURL=$$GET1^DIQ(C0PXF,C0PUTID_",","PROXY SERVER")
|
|---|
| 117 | ;S C0PURL=$$GET1^DIQ(C0PXF,C0PUTID_",","URL") ;GPL CHANGE TO USE PROD FLAG
|
|---|
| 118 | D SETUP^C0PMAIN() ; INITIALIZE C0PACCT IEN OF WS ACCOUNT
|
|---|
| 119 | S C0PURL=$$WSURL^C0PMAIN(C0PACCT) ; RESOLVES PRODUCTION VS TEST
|
|---|
| 120 | S C0PXML=$$GET1^DIQ(C0PXF,C0PUTID_",",2.1,,"xml")
|
|---|
| 121 | S C0PTMPL=$$GET1^DIQ(C0PXF,C0PUTID_",",3,,"template")
|
|---|
| 122 | I C0PTMPL="template" D ; there is a template to process
|
|---|
| 123 | . K xml ; going to replace the xml array
|
|---|
| 124 | . D EN^C0PMAIN("xml","url",C0PDUZ,C0PDFN,C0PUTID,$G(C0PVOR))
|
|---|
| 125 | . ;N ZZG M ZZG(1)=xml
|
|---|
| 126 | . ;S ZDIR=^TMP("C0CCCR","ODIR")
|
|---|
| 127 | . ;ZWR ZZG(1)
|
|---|
| 128 | . ;W $$OUTPUT^C0CXPATH("xml(1)","GPLTEST-"_ZDFN_".xml",ZDIR)
|
|---|
| 129 | .QUIT
|
|---|
| 130 | I $G(C0PPROXY) S C0PURL=C0PPURL
|
|---|
| 131 | K C0PRSLT,C0PRHDR
|
|---|
| 132 | S ok=$$httpPOST^%zewdGTM(C0PURL,.xml,C0PMIME,.C0PRSLT,.header,"",.gpl5,.C0PRHDR)
|
|---|
| 133 | K C0PRXML
|
|---|
| 134 | I $D(GPLTEST) D ; WAY TO TEST WITH DATA FROM LIVE
|
|---|
| 135 | . K C0PSRLT ; GPL HACK TO TEST XML FROM LIVE
|
|---|
| 136 | . I GPLTEST=1 M C0PRSLT=^C0PG ; THIS IS THE BIG STATUS EMBEDDED XML FROM LIVE
|
|---|
| 137 | . I GPLTEST=2 M C0PRSLT=^C0PG2 ; THIS IS THE BIG REFILL XML FROM LIVE
|
|---|
| 138 | . Q
|
|---|
| 139 | ; The following is a temporary fix to keep eRx working while a better
|
|---|
| 140 | ; solution is developed. Template ID 6 is GETMEDS for eRx and it needs
|
|---|
| 141 | ; to handle xml files that are too big for NORMAL to handle. So, I wrote
|
|---|
| 142 | ; CHUNK which will allow us to handle any size xml file bound for the
|
|---|
| 143 | ; EWD parser.
|
|---|
| 144 | ; However, all the other templates in eRx need NORMAL to find the
|
|---|
| 145 | ; embedded XML file in their web service responses. So, we will use
|
|---|
| 146 | ; CHUNK for template 6 and continue to use NORMAL for all other templates
|
|---|
| 147 | ; we can handle big med lists, but not big web service calls.
|
|---|
| 148 | ; What is needed is a better NORMAL (see NORMAL2) or another routine
|
|---|
| 149 | ; to detect, extract, and decode embeded XML files of any size. gpl 10/8/10
|
|---|
| 150 | ;
|
|---|
| 151 | I $D(C0PRSLT(1)) D ;
|
|---|
| 152 | . D CHUNK("C0PRXML","C0PRSLT",1000) ;RETURN IN AN ARRAY
|
|---|
| 153 | . I $G(C0PRSLT("RELOC",1,1))'="" D ; THERE WAS EMBEDED XML
|
|---|
| 154 | . . K C0PRXML ; THROW AWAY WRAPPER
|
|---|
| 155 | . . M C0PRXML=C0PRSLT("RELOC",1) ; REPLACE WITH EMBEDDED DOCUMENT
|
|---|
| 156 | ; D:C0PUTID=6
|
|---|
| 157 | ;. I $D(C0PRSLT(1)) D CHUNK("C0PRXML","C0PRSLT",2000) QUIT ;RETURN IN AN ARRAY
|
|---|
| 158 | ;. ;
|
|---|
| 159 | ;. I $D(C0PRSLT(1)) D NORMAL("C0PRXML","C0PRSLT(1)") ;RETURN XML IN AN ARRAY
|
|---|
| 160 | ;.QUIT
|
|---|
| 161 | S C0PR=$$GET1^DIQ(C0PXF,C0PUTID_",",.03,"I") ; REPLY TEMPLATE
|
|---|
| 162 | ; reply templates are optional and are specified by populating a
|
|---|
| 163 | ; template pointer in field 2.5 of the request template
|
|---|
| 164 | ; if specified, the reply template is the source of the REDUX string
|
|---|
| 165 | ; used for XPath on the reply, and for UNBIND processing
|
|---|
| 166 | ; if no reply template is specified, REDUX is obtained from the request
|
|---|
| 167 | ; template and no UNBIND processing is performed. The XPath array is
|
|---|
| 168 | ; returned without variable bindings
|
|---|
| 169 | I C0PR'="" D ; REPLY TEMPLATE EXISTS
|
|---|
| 170 | . I +$G(DEBUG)'=0 W "REPLY TEMPLATE:"_C0PR,!
|
|---|
| 171 | . S C0PTID=C0PR ;
|
|---|
| 172 | .QUIT
|
|---|
| 173 | S C0PREDUX=$$GET1^DIQ(C0PXF,C0PUTID_",",2.5) ;XPATH REDUCTION STRING
|
|---|
| 174 | K C0PIDX,C0PARY ; XPATH INDEX AND ARRAY VARS
|
|---|
| 175 | S C0PNOM="C0PMEDS"_$J ; DOCUMENT NAME FOR THE DOM
|
|---|
| 176 | N ZBIG S ZBIG=0
|
|---|
| 177 | ;I C0PUTID'=6 D ;
|
|---|
| 178 | ;. S ZBIG=$$TOOBIG("C0PRXML") ; PATCH BY GPL WHICH ASSUMES ONLY
|
|---|
| 179 | ;. ; TEMPLATE 1 IS A REGULAR XML FILE.. EVERYTHING ELSE HAS EMBEDDED XML
|
|---|
| 180 | ;.QUIT
|
|---|
| 181 | ;D
|
|---|
| 182 | ;. I ZBIG>0 D QUIT ; PROBABLY AN EMBEDDED XML DOCUMENT
|
|---|
| 183 | ;. . S C0PID=$$UNWRAP("C0PRXML",ZBIG,C0PNOM) ; DECODE AND PARSE THE EMBEDED XML
|
|---|
| 184 | ;. .QUIT
|
|---|
| 185 | ;. ;
|
|---|
| 186 | ;. ; ELSE
|
|---|
| 187 | ;. S C0PID=$$PARSE^C0PXEWD("C0PRXML",C0PNOM) ;CALL THE PARSER
|
|---|
| 188 | ;.QUIT
|
|---|
| 189 | ; I $D(GPLTEST) B ; STOP TO LOOK AT C0PRXML --> use ZB SOAP+137^C0PWS2 //SMH
|
|---|
| 190 | S C0PID=$$PARSE^C0PXEWD("C0PRXML",C0PNOM) ;CALL THE PARSER
|
|---|
| 191 | S C0PID=$$FIRST^C0PXEWD($$ID^C0PXEWD(C0PNOM)) ;ID OF FIRST NODE
|
|---|
| 192 | D XPATH^C0PXEWD(C0PID,"/","C0PIDX","C0PARY","",C0PREDUX) ;XPATH GENERATOR
|
|---|
| 193 | S OK=$$DELETE^C0PXEWD(C0PNOM) ; REMOVE PARSED XML FROM THE EWD DOM
|
|---|
| 194 | ; Next, call UNBIND to map the reply XPath array to variables
|
|---|
| 195 | ; This is only done if a Reply Template is provided
|
|---|
| 196 | D DEMUXARY(C0PRTN,"C0PARY")
|
|---|
| 197 | ; M @C0PRTN=C0PARY
|
|---|
| 198 | QUIT
|
|---|
| 199 | ;
|
|---|
| 200 | TOOBIG(ZXML) ; EXTRINSIC WHICH RETURNS TRUE IF ANY NODE IS OVER 2000 CHARS
|
|---|
| 201 | ; RETURNS THE INDEX OF THE LARGE NODE . IF NO LARGE NODE, RETURNS ZERO
|
|---|
| 202 | N ZI,ZR
|
|---|
| 203 | S ZI=""
|
|---|
| 204 | S ZR=0 ; DEFAULT FALSE
|
|---|
| 205 | ; First time we go over 1,000, we can stop.
|
|---|
| 206 | F S ZI=$O(@ZXML@(ZI)) Q:ZI="" I $L(@ZXML@(ZI))>1000 S ZR=ZI Q ; First oversize stops
|
|---|
| 207 | QUIT ZR
|
|---|
| 208 | ; ===================
|
|---|
| 209 | NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
|
|---|
| 210 | ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
|
|---|
| 211 | ;
|
|---|
| 212 | N INBF,ZI,ZN,ZTMP
|
|---|
| 213 | S ZN=1,INBF=@INXML
|
|---|
| 214 | S @OUTXML@(ZN)=$P(INBF,"><",ZN)_">"
|
|---|
| 215 | ; S ZN=ZN+1
|
|---|
| 216 | ; F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ;
|
|---|
| 217 | ; Should speed up, and not leave a dangling node, and doesn't stop at first NULL
|
|---|
| 218 | F ZN=2:1:$L(INBF,"><") S @OUTXML@(ZN)="<"_$P(INBF,"><",ZN)_">"
|
|---|
| 219 | ; . ; S ZN=ZN+1
|
|---|
| 220 | ; .QUIT
|
|---|
| 221 | QUIT
|
|---|
| 222 | ; ================
|
|---|
| 223 | ; The goal of this block has changed a little bit. Most modern MUMPS engines can
|
|---|
| 224 | ; handle a 1,000,000 byte string. We will use BF to hold hunks that big so that
|
|---|
| 225 | ; we can logically suck up a big hunk of the input to supply the reblocking of the XML
|
|---|
| 226 | ; into more logical blocks less than 2000 bytes in length blocks.
|
|---|
| 227 | ; A series of signals will be needed, Source (INXML) is exhausted (INEND),
|
|---|
| 228 | ; BF is less than 2200 bytes (BFLD, BuFfer reLoaD)
|
|---|
| 229 | ; BF is Full (BF contains 998,000 bytes or more, BFULL)
|
|---|
| 230 | ; BF and Process is Complete (BFEND)
|
|---|
| 231 | ; ZSIZE defaults to 2,000 now, but can be set lower or higher
|
|---|
| 232 | ;
|
|---|
| 233 | CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS
|
|---|
| 234 | ; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
|
|---|
| 235 | ; OUTXML IS ALSO PASSED BY NAME
|
|---|
| 236 | ; IF ZSIZE IS NOT PASSED, 2000 IS USED
|
|---|
| 237 | I '$D(ZSIZE) S ZSIZE=2000 ; DEFAULT BLOCK SIZE
|
|---|
| 238 | N BF,BFEND,BFLD,BFMAX,BFULL,INEND,ZB,ZI,ZJ,ZK,ZL,ZN
|
|---|
| 239 | ; S ZB=ZSIZE-1
|
|---|
| 240 | S ZN=1
|
|---|
| 241 | S BFMAX=998000
|
|---|
| 242 | S ZI=0 ; BEGINNING OF INDEX TO INXML
|
|---|
| 243 | S (BFLD,BFEND,BFULL,INEND)=0,BF=""
|
|---|
| 244 | ; Major loop loads the buffer, BF, and unloads it into the Output Array
|
|---|
| 245 | ; in
|
|---|
| 246 | F D Q:BFEND
|
|---|
| 247 | . ; Input LOADER
|
|---|
| 248 | . D:'INEND
|
|---|
| 249 | . . F S ZI=$O(@INXML@(ZI)) S INEND=(ZI="") Q:INEND!BFULL D ; LOAD EACH STRING IN INXML
|
|---|
| 250 | . . . S BF=BF_@INXML@(ZI) ; ADD TO THE BF STRING
|
|---|
| 251 | . . . S BFULL=($L(BF)>BFMAX)
|
|---|
| 252 | . . .QUIT
|
|---|
| 253 | . .QUIT
|
|---|
| 254 | . ; Full Buffer, BF, now check for Encryption and Unpack
|
|---|
| 255 | . D TEST4COD(.BF,"C0PRSLT(""RELOC"")")
|
|---|
| 256 | . ; Output BREAKER
|
|---|
| 257 | . F Q:BFLD D ; ZJ=1:ZSIZE:ZL D ;
|
|---|
| 258 | . . ; ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
|
|---|
| 259 | . . F ZK=ZSIZE:-1:0 Q:$E(BF,ZK)=">"
|
|---|
| 260 | . . I ZK=0 S ZK=ZSIZE
|
|---|
| 261 | . . S @OUTXML@(ZN)=$E(BF,1,ZK) ; PULL OUT THE PIECE
|
|---|
| 262 | . . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
|
|---|
| 263 | . . S BF=$E(BF,ZK+1,BFMAX)
|
|---|
| 264 | . . S BFLD=($L(BF)<(ZSIZE*2))
|
|---|
| 265 | . .QUIT
|
|---|
| 266 | . S BFEND=(INEND&BFLD)!(">"[BF)
|
|---|
| 267 | . I $L(BF)&BFEND S @OUTXML@(ZN)=BF,BF=""
|
|---|
| 268 | .QUIT
|
|---|
| 269 | QUIT
|
|---|
| 270 | ; ==============
|
|---|
| 271 | ; Test for Encryption, extract it and decode it.
|
|---|
| 272 | TEST4COD(INBF,RELOC)
|
|---|
| 273 | N DBF,I,MSK,TBF,TRG,RCNT
|
|---|
| 274 | S RCNT=0
|
|---|
| 275 | ; Segments expected <seg 1>DATA</seg 1><seg 2>DATA</seg 2>
|
|---|
| 276 | ; ^ ^
|
|---|
| 277 | S MSK="" ; It turns out that some of the characters used were not reliable
|
|---|
| 278 | F I=32:1:42,44:1:47,62:1:64,91:1:96 S MSK=MSK_$C(I)
|
|---|
| 279 | F I=1:1:$L(INBF,"</")-1 D
|
|---|
| 280 | . S TBF=$RE($P($RE($P(INBF,"</",I)),">"))
|
|---|
| 281 | . ; Remove sample for testing
|
|---|
| 282 | . ; Set the trigger, mostly included to show intent and associated code
|
|---|
| 283 | . ; this could be refined later if determined already obvious enough
|
|---|
| 284 | . S TRG=0
|
|---|
| 285 | . ;DO:$L(TBF)>20 ; If $TR doesn't remove anything, then these characters are not there
|
|---|
| 286 | . ; gpl trying to keep refills from crashing.. 20 chars is not enough
|
|---|
| 287 | . DO:$L(TBF)>100 ; If $TR doesn't remove anything, then these characters are not there
|
|---|
| 288 | . . I (TBF=$TR(TBF,MSK)) S TRG=1
|
|---|
| 289 | . . ; I (TBF=$TR(TBF," <->@*!?.,:;#$%&[/|\]={}~")) S TRG=1
|
|---|
| 290 | . . ; <>!"#$%&'()*,-./67:;<>?@[\]^_`fqr{|}~ <<= Ignore 6,7,f,q, and r
|
|---|
| 291 | . . ; Now we set up for the DECODE and replacement in INBF
|
|---|
| 292 | . . DO:TRG
|
|---|
| 293 | . . . N A,C,CC,CV,CCX,K,XBF,T,V
|
|---|
| 294 | . . . DO
|
|---|
| 295 | . . . . N I
|
|---|
| 296 | . . . . S DBF=$$DECODER(TBF)
|
|---|
| 297 | . . . .QUIT
|
|---|
| 298 | . . . ;
|
|---|
| 299 | . . . S CCX=""
|
|---|
| 300 | . . . F K=1:1:$L(DBF) S CC=$E(DBF,K) S:CC?1C C=$A(CC),A(C)=$G(A(C))+1
|
|---|
| 301 | . . . S C="",V=""
|
|---|
| 302 | . . . F S C=$O(A(C)) Q:C="" S CCX=CCX_$C(C) S:A(C)>V V=A(C),CV=C
|
|---|
| 303 | . . . S CC=$C(CV)
|
|---|
| 304 | . . . ; The "_$C(13,10)_" may need to be generalized, tested and set earlier
|
|---|
| 305 | . . . ; Expand embedded XML in XBF
|
|---|
| 306 | . . . F K=1:1:$L(DBF,CC) S T=$P(DBF,CC,K),XBF(K)=$TR(T,CCX)
|
|---|
| 307 | . . . S RCNT=RCNT+1
|
|---|
| 308 | . . . M @RELOC@(RCNT)=XBF
|
|---|
| 309 | . . . ; Curley braces and = makes it so it won't trigger a second time by retest.
|
|---|
| 310 | . . . S INBF=$P(INBF,TBF)_"<{REPLACED}="_RCNT_$P(INBF,TBF,2,999)
|
|---|
| 311 | . . .QUIT
|
|---|
| 312 | . .QUIT
|
|---|
| 313 | .QUIT
|
|---|
| 314 | ; Now shorten the INBF so it gets smaller
|
|---|
| 315 | ;S INBF=$P(INBF,">",I+1,99999)
|
|---|
| 316 | QUIT
|
|---|
| 317 | ;
|
|---|
| 318 | DECODER(BF) ; Decrypts the Encrypted Strings
|
|---|
| 319 | QUIT $$DECODE^RGUTUU(BF)
|
|---|
| 320 | ;
|
|---|
| 321 | NORMAL2(OUTXML,INXML) ;NORMALIZES AN ARRAY OF XML STRINGS PASSED BY NAME INXML
|
|---|
| 322 | ; AS @INXML@(1) TO @INXML@(x) ALL NUMERIC
|
|---|
| 323 | ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
|
|---|
| 324 | ; this routine doesn't work unless the blocks are on xml tag boundaries - gpl
|
|---|
| 325 | ; which is hard to do... this routine is left here awaiting future development
|
|---|
| 326 | N ZI,ZN,ZJ
|
|---|
| 327 | S ZJ=0
|
|---|
| 328 | S ZN=1
|
|---|
| 329 | F S ZJ=$O(@INXML@(ZJ)) Q:+ZJ=0 D ; FOR EACH XML STRING IN ARRAY
|
|---|
| 330 | . S @OUTXML@(ZN)=$P(@INXML@(ZJ),"><",ZN)_">"
|
|---|
| 331 | . S ZN=ZN+1
|
|---|
| 332 | . F S @OUTXML@(ZN)="<"_$P(@INXML@(ZJ),"><",ZN) Q:$P(@INXML@(ZJ),"><",ZN+1)="" D ;
|
|---|
| 333 | . . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
|
|---|
| 334 | . . S ZN=ZN+1
|
|---|
| 335 | . .QUIT
|
|---|
| 336 | .QUIT
|
|---|
| 337 | QUIT
|
|---|
| 338 | ; ===============
|
|---|
| 339 | ;
|
|---|
| 340 | UNWRAP(ZXML,ZI,ZNOM) ; EXTRINSIC TO LOCATE, DECODE AND PARSE AN EMBEDED XML DOC
|
|---|
| 341 | ; RETURNS THE DOCID OF THE DOM
|
|---|
| 342 | N ZS,ZX
|
|---|
| 343 | S ZS=$P($P(@ZXML@(ZI),">",2),"<",1) ; PULL OUT THE ENCODED STRING
|
|---|
| 344 | S ZX=$$DECODE^RGUTUU(ZS)
|
|---|
| 345 | N ZZ
|
|---|
| 346 | N ZY S ZY="<?xml version=""1.0"" encoding=""utf-8""?>"
|
|---|
| 347 | I $E(ZX,1,5)'="<?xml" S ZZ(1)=ZY_ZX
|
|---|
| 348 | E S ZZ(1)=ZX
|
|---|
| 349 | N ZI
|
|---|
| 350 | ;F ZI=1:1 Q:$$REDUCE(.ZZ,ZI) ; CHOP THE STRING INTO 4000 CHAR ARRAY
|
|---|
| 351 | S ZI=$$REDUCRCR(.ZZ,1) ; RECURSIVE VERSION OF REDUCE
|
|---|
| 352 | S G=$$PARSE^C0PXEWD("ZZ",C0PNOM)
|
|---|
| 353 | ; GTM Specific
|
|---|
| 354 | ; I G=0 ZWR ^TMP("MXMLERR",$J,*) B
|
|---|
| 355 | QUIT G
|
|---|
| 356 | ; =============
|
|---|
| 357 | REDUCE(ZARY,ZN) ; WILL REDUCE ZARY(ZN) BY CHOPPING IT TO 4000 CHARS
|
|---|
| 358 | ; AND PUTTING THE REST IN ZARY(ZN+1)
|
|---|
| 359 | ; ZARY IS PASSED BY REFERENCE
|
|---|
| 360 | ; EXTRINSIC WHICH RETURNS FALSE IF THERE IS NOTHING TO REDUCE
|
|---|
| 361 | I $L(ZARY(ZN))<4001 QUIT 0 ;NOTHING TO REDUCE
|
|---|
| 362 | ;
|
|---|
| 363 | S ZARY(ZN+1)=$E(ZARY(ZN),4001,$L(ZZ(ZN))) ;BREAK IT UP
|
|---|
| 364 | S ZARY(ZN)=$E(ZARY(ZN),1,4000) ;
|
|---|
| 365 | QUIT 1 ;ACTUALLY REDUCED
|
|---|
| 366 | ; ===========
|
|---|
| 367 | REDUCRCR(ZARY,ZN) ; RECURSIVE VERSION OF REDUCE ABOVE
|
|---|
| 368 | ; WILL REDUCE ZARY(ZN) BY CHOPPING IT TO 4000 CHARS
|
|---|
| 369 | ; AND PUTTING THE REST IN ZARY(ZN+1)
|
|---|
| 370 | ; ZARY IS PASSED BY REFERENCE
|
|---|
| 371 | ; EXTRINSIC WHICH RETURNS FALSE IF THERE IS NOTHING TO REDUCE
|
|---|
| 372 | I $L(ZARY(ZN))<4001 Q 0 ;NOTHING TO REDUCE
|
|---|
| 373 | ;
|
|---|
| 374 | S ZARY(ZN+1)=$E(ZARY(ZN),4001,$L(ZZ(ZN))) ;BREAK IT UP
|
|---|
| 375 | S ZARY(ZN)=$E(ZARY(ZN),1,4000) ;
|
|---|
| 376 | I '$$REDUCRCR(.ZARY,ZN+1) Q 1 ; CALL RECURSIVELY
|
|---|
| 377 | ;
|
|---|
| 378 | QUIT 1 ;ACTUALLY REDUCED
|
|---|
| 379 | ;
|
|---|
| 380 | DEMUXARY(OARY,IARY) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
|
|---|
| 381 | ; FORMAT @OARY@(x,xpath) where x is the first multiple
|
|---|
| 382 | N ZI,ZJ,ZK,ZL S ZI=""
|
|---|
| 383 | F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ;
|
|---|
| 384 | . D DEMUX^C0CMXP("ZJ",ZI)
|
|---|
| 385 | . S ZK=$P(ZJ,"^",3)
|
|---|
| 386 | . S ZK=$RE($P($RE(ZK),"/",1))
|
|---|
| 387 | . S ZL=$P(ZJ,"^",1)
|
|---|
| 388 | . I ZL="" S ZL=1
|
|---|
| 389 | . S @OARY@(ZL,ZK)=@IARY@(ZI)
|
|---|
| 390 | .QUIT
|
|---|
| 391 | QUIT
|
|---|
| 392 | ;
|
|---|
| 393 | PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
|
|---|
| 394 | ; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
|
|---|
| 395 | ; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
|
|---|
| 396 | N ZR
|
|---|
| 397 | M ^CacheTempEWD($j)=@INXML ;
|
|---|
| 398 | S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
|
|---|
| 399 | K ^CacheTempEWD($j) ;clean up after
|
|---|
| 400 | QUIT ZR
|
|---|
| 401 | ;
|
|---|
| 402 | TBLD(INT) ; TEMPLATE BUILD OF TEMPLATE INT
|
|---|
| 403 | ; want to break this up into pieces - gpl
|
|---|
| 404 | ; THE TEMPLATE NEEDS TO EXIST AND THE DEFINING XML URL MUST BE POPULATED
|
|---|
| 405 | ; THEN THE DEFINING XML WILL BE RETRIVED AND STORED INTO THE RAW XML FIELD
|
|---|
| 406 | ; IT WILL BE TRANSFORMED INTO A TEMPLATE AND STORED IN THE TEMPLATE FIELD
|
|---|
| 407 | ; ALL THE XPATHs WILL BE EXTRACTED AND A BINDING MULTIPLE CREATED FOR EACH
|
|---|
| 408 | ; ALL IN ONE SIMPLE ROUTINE
|
|---|
| 409 | ; WHAT REMAINS IS FOR MANUAL ENTRY OF THE OTHER FIELDS IN THE BINDINGS
|
|---|
| 410 | N C0PXTF S C0PXTF=113059001 ; XML TEMPLATE FILE
|
|---|
| 411 | N C0PURL ; URL TO RETRIEVE THE DEFINING XML FOR THE TEMPLATE
|
|---|
| 412 | S C0PURL=$$GET1^DIQ(C0PXTF,INT,2)
|
|---|
| 413 | D GET1URL^C0PEWD2(C0PURL)
|
|---|
| 414 | D CLEAN^DILF
|
|---|
| 415 | ; D WP^DIE(ZF,ZIEN_",",1,,$NA(@ZOR@(ZD,ZI,"TX"))) ; WP OF ORDER TXT
|
|---|
| 416 | D WP^DIE(C0PXTF,INT_",",2.1,,$NA(gpl))
|
|---|
| 417 | D WP^DIE(C0PXTF,INT_",",3,,$NA(gplTEMP))
|
|---|
| 418 | ;N C0PFDA ; DON'T NEW FOR TESTING
|
|---|
| 419 | D ADDXP("gpl2",INT)
|
|---|
| 420 | QUIT
|
|---|
| 421 | ; ==========
|
|---|
| 422 | COMPILE(INTID) ;COMPILE A XML TEMPLATE IN RECORD INTID
|
|---|
| 423 | D INITXPF("C0PF") ;FILE ARRAY TO POINT TO C0P FILES
|
|---|
| 424 | D COMPILE^C0CMXP(INTID,"C0PF") ;COMPILE THE TEMPLATE
|
|---|
| 425 | QUIT
|
|---|
| 426 | ; ==========
|
|---|
| 427 | CPBIND(INID,OUTID,FORCE) ; COPIES XPATH BINDINGS FROM TEMPLATE INID
|
|---|
| 428 | ; TO TEMPLATE OUTID - ONLY BINDINGS FOR MATCHING XPATHS ARE COPIED
|
|---|
| 429 | ; NOTE - REDO THIS TO USE FILEMAN CALLS GPL
|
|---|
| 430 | ; WILL NOT OVERWRITE UNLESS FORCE=1
|
|---|
| 431 | N FARY,ZI
|
|---|
| 432 | S FARY="C0PF"
|
|---|
| 433 | D INITXPF("C0PF")
|
|---|
| 434 | I +OUTID=0 S OUTID=$$RESTID^C0CSOAP(OUTID,FARY) ;RESOLVE TEMPLATE NAME
|
|---|
| 435 | I +INID=0 S INID=$$RESTID^C0CSOAP(INID,FARY) ;RESOLVE TEMPLATE NAME
|
|---|
| 436 | S ZI=0
|
|---|
| 437 | F S ZI=$O(^C0PX(OUTID,5,ZI)) Q:+ZI=0 D ; FOR EACH XPATH IN OUTID
|
|---|
| 438 | . W !,ZI," ",^C0PX(OUTID,5,ZI,0)
|
|---|
| 439 | . S ZN=^C0PX(OUTID,5,ZI,0)
|
|---|
| 440 | . I $D(^C0PX(OUTID,5,ZI,1)) D ;Q ;
|
|---|
| 441 | . . W !,"ERROR XPATH BINDING EXISTS ",ZI
|
|---|
| 442 | . .QUIT
|
|---|
| 443 | . D ; LOOK FOR MATCHING XPATH IN SOURCE
|
|---|
| 444 | . . S ZJ=$O(^C0PX(INID,5,"B",ZN,""))
|
|---|
| 445 | . . ;W " FOUND:",ZJ
|
|---|
| 446 | . . I ZJ'="" D ;
|
|---|
| 447 | . . . ;W !,"SETTING ",$G(^C0PX(INID,5,ZJ,1))
|
|---|
| 448 | . . . S ^C0PX(OUTID,5,ZI,0)=^C0PX(INID,5,ZJ,0) ;GET BOTH FIELDS
|
|---|
| 449 | . . . S ^C0PX(OUTID,5,ZI,1)=$G(^C0PX(INID,5,ZJ,1))
|
|---|
| 450 | QUIT
|
|---|
| 451 | ;
|
|---|
| 452 | INITXPF(ARY) ;INITIAL XML/XPATH FILE ARRAY
|
|---|
| 453 | ;
|
|---|
| 454 | S @ARY@("XML FILE NUMBER")=113059001
|
|---|
| 455 | S @ARY@("BINDING SUBFILE NUMBER")=113059001.04
|
|---|
| 456 | S @ARY@("MIME TYPE")="2.3"
|
|---|
| 457 | S @ARY@("PROXY SERVER")="2.4"
|
|---|
| 458 | S @ARY@("REPLY TEMPLATE")=".03"
|
|---|
| 459 | S @ARY@("TEMPLATE NAME")=".01"
|
|---|
| 460 | S @ARY@("TEMPLATE XML")="3"
|
|---|
| 461 | S @ARY@("URL")="1"
|
|---|
| 462 | S @ARY@("WSDL URL")="2"
|
|---|
| 463 | S @ARY@("XML")="2.1"
|
|---|
| 464 | S @ARY@("XML HEADER")="2.2"
|
|---|
| 465 | S @ARY@("XPATH REDUCTION STRING")="2.5"
|
|---|
| 466 | S @ARY@("CCR VARIABLE")="4"
|
|---|
| 467 | S @ARY@("FILEMAN FIELD NAME")="1"
|
|---|
| 468 | S @ARY@("FILEMAN FIELD NUMBER")="1.2"
|
|---|
| 469 | S @ARY@("FILEMAN FILE POINTER")="1.1"
|
|---|
| 470 | S @ARY@("INDEXED BY")=".05"
|
|---|
| 471 | S @ARY@("SQLI FIELD NAME")="3"
|
|---|
| 472 | S @ARY@("VARIABLE NAME")="2"
|
|---|
| 473 | QUIT
|
|---|
| 474 | ;
|
|---|
| 475 | ADDXP(INARY,TID) ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID
|
|---|
| 476 | N FARY
|
|---|
| 477 | S FARY="C0PFILES"
|
|---|
| 478 | D INITXPF(FARY)
|
|---|
| 479 | D ADDXP^C0CMXP(INARY,TID,FARY) ;
|
|---|
| 480 | QUIT
|
|---|
| 481 | ;
|
|---|
| 482 | ADDXML(INXML,TEMPID) ;ADD XML TO A TEMPLATE ID TEMPID
|
|---|
| 483 | ; INXML IS PASSED BY NAME
|
|---|
| 484 | N FARY S FARY="C0PFILES"
|
|---|
| 485 | D INITXPF(FARY)
|
|---|
| 486 | D ADDXML^C0CMXP(INXML,TEMPID,FARY) ;CALL C0C ROUTINE TO ADD TO THE FILE
|
|---|
| 487 | QUIT
|
|---|
| 488 | ;
|
|---|
| 489 | ADDTEMP(INXML,TEMPID,FARY) ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID FIELD 3
|
|---|
| 490 | ;
|
|---|
| 491 | N FARY
|
|---|
| 492 | S FARY="C0PFILES"
|
|---|
| 493 | D INITXPF(FARY)
|
|---|
| 494 | D ADDTEMP^C0CMXP(INXML,TEMPID,FARY)
|
|---|
| 495 | QUIT
|
|---|
| 496 | ;
|
|---|
| 497 | GETXML(OUTXML,TEMPID,FARY) ;GET THE XML FROM TEMPLATE TEMPID
|
|---|
| 498 | ;
|
|---|
| 499 | N FARY
|
|---|
| 500 | S FARY="C0PFILES"
|
|---|
| 501 | D INITXPF(FARY)
|
|---|
| 502 | N C0PUTID ; TEMPLATE IEN TO USE
|
|---|
| 503 | D GETXML^C0CMXP(OUTXML,TEMPID,FARY)
|
|---|
| 504 | QUIT
|
|---|
| 505 | ;
|
|---|
| 506 | GETTEMP(OUTXML,TEMPID,FARY) ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID
|
|---|
| 507 | ;
|
|---|
| 508 | N FARY
|
|---|
| 509 | S FARY="C0PFILES"
|
|---|
| 510 | D INITXPF(FARY)
|
|---|
| 511 | N C0PUTID ; TEMPLATE IEN TO USE
|
|---|
| 512 | D GETTEMP^C0CMXP(OUTXML,TEMPID,FARY)
|
|---|
| 513 | QUIT
|
|---|
| 514 | ;
|
|---|
| 515 | COPYHDR(ZS,ZD) ; COPY XML HEADER FROM RECORD ZS TO ZD
|
|---|
| 516 | ; ASSUMES C0P XML TEMPLATE FILE
|
|---|
| 517 | N FARY
|
|---|
| 518 | D INITXPF("FARY")
|
|---|
| 519 | D COPYWP^C0CMXP("XML HEADER",ZS,ZD,"FARY")
|
|---|
| 520 | QUIT
|
|---|
| 521 | ;
|
|---|
| 522 | UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
|
|---|
| 523 | K ZERR
|
|---|
| 524 | D CLEAN^DILF
|
|---|
| 525 | D UPDATE^DIE("","C0PFDA","","ZERR")
|
|---|
| 526 | I $D(ZERR) D ERROR^C0PMAIN(",U113059008,",$ST($ST,"PLACE"),"ERX-UPDIE-FAIL","Fileman Data Update Failure") QUIT
|
|---|
| 527 | K C0PFDA
|
|---|
| 528 | QUIT
|
|---|
