source: ePrescribing/trunk/p/C0PWS2.m@ 1693

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

initial release of ePrescribing

File size: 19.3 KB
Line 
1C0PWS2 ; 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.
12TEST(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 ;
18ACCOUNTF() QUIT 113059002 ; file number for account file
19 ;
20XMLFN() QUIT 113059001 ; XML TEMPLATE FILE NUMBER
21 ;
22BINDFN() QUIT 113059001.04 ; FILE NUMBER FOR BINDING SUBFILE
23 ;
24 ;
25GETTID(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 ;
45RESTID(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 ;
57SOAP(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 ;
200TOOBIG(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 ; ===================
209NORMAL(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 ;
233CHUNK(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.
272TEST4COD(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 ;
318DECODER(BF) ; Decrypts the Encrypted Strings
319 QUIT $$DECODE^RGUTUU(BF)
320 ;
321NORMAL2(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 ;
340UNWRAP(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 ; =============
357REDUCE(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 ; ===========
367REDUCRCR(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 ;
380DEMUXARY(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 ;
393PARSE(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 ;
402TBLD(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 ; ==========
422COMPILE(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 ; ==========
427CPBIND(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 ;
452INITXPF(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 ;
475ADDXP(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 ;
482ADDXML(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 ;
489ADDTEMP(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 ;
497GETXML(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 ;
506GETTEMP(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 ;
515COPYHDR(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 ;
522UPDIE ; 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
Note: See TracBrowser for help on using the repository browser.