source: ccr/trunk/p/C0CXPATH.m@ 528

Last change on this file since 528 was 528, checked in by George Lilly, 15 years ago

updates for XML handling

File size: 22.2 KB
RevLine 
[508]1C0CXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
2 ;;1.0;C0C;;May 19, 2009;
[391]3 ;Copyright 2008 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 W "This is an XML XPATH utility library",!
21 W !
22 Q
23 ;
[508]24OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE
[391]25 ;
26 N Y
27 S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME)
28 I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR
29 I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR
30 Q
31 ;
[508]32PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0)
[391]33 ; VAL IS A STRING AND STK IS PASSED BY NAME
34 ;
35 I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE
36 S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH
37 S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY
38 Q
39 ;
[508]40POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL
[391]41 ; VAL AND STK ARE PASSED BY REFERENCE
42 ;
43 I @STK@(0)<1 D ; IF ARRAY IS EMPTY
44 . S VAL=""
45 . S @STK@(0)=0
46 I @STK@(0)>0 D ;
47 . S VAL=@STK@(@STK@(0))
48 . K @STK@(@STK@(0))
49 . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY
50 Q
51 ;
[508]52PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME
[391]53 ;
54 N ZGI
55 F ZGI=1:1:@ASRC@(0) D ; FOR ALL OF THE SOURCE ARRAY
56 . D PUSH(ADEST,@ASRC@(ZGI)) ; PUSH ONE ELEMENT
57 Q
58 ;
[508]59MKMDX(STK,RTN) ; MAKES A MUMPS INDEX FROM THE ARRAY STK
[391]60 ; RTN IS SET TO //FIRST/SECOND/THIRD FOR THREE ARRAY ELEMENTS
61 S RTN=""
62 N I
63 ; W "STK= ",STK,!
64 I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY
65 . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
66 . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
67 . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
68 Q
69 ;
[508]70XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
[391]71 ; </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
72 ; ISTR IS PASSED BY VALUE
73 N CUR,TMP
74 I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET
75 . S TMP=$P(ISTR,"<",2)
76 I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
77 . S TMP=$P(TMP,"/",2)
78 S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
79 ; W "CUR= ",CUR,!
80 I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST>
81 . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
82 ; W "CUR2= ",CUR,!
83 Q CUR
84 ;
[512]85XVAL(ISTR) ; EXTRACTS THE VALUE FROM A FRAGMENT OF XML
86 ; <NAME>VALUE</NAME> WILL RETURN VALUE
87 N G
88 S G=$P(ISTR,">",2) ;STRIP OFF <NAME>
89 Q $P(G,"<",1) ; STRIP OFF </NAME> LEAVING VALUE
90 ;
91VDX2VDV(OUTVDV,INVDX) ; CONVERT AN VDX ARRAY TO VDV
92 ; VDX: @INVDX@(XPATH)=VALUE
93 ; VDV: @OUTVDV@(X1X2X3X4)=VALUE
94 ; THE VDV DATANAMES MIGHT BE MORE CONVENIENT FOR USE IN CODE
95 ; AN INDEX IS PROVIDED TO GO BACK TO VDX FOR CONVERSIONS
96 ; @VDV@("XPATH",X1X2X3X4)="XPATH"
97 N ZA,ZI,ZW
98 S ZI=""
99 F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ;
100 . S ZW=$TR(ZI,"/","") ; ELIMINATE ALL SLASHES - CAMEL CASE VARIABLE NAME
101 . W ZW,!
102 . S @OUTVDV@(ZW)=@INVDX@(ZI)
103 . S @OUTVDV@("XPATH",ZW)=ZI
104 Q
105 ;
[513]106VDX2XPG(OUTXPG,INVDX) ; CONVERT AN VDX ARRAY TO XPG
[512]107 ; VDX: @VDX@(XPATH)=VALUE
108 ; XPG: @(VDX(X1,X2,X3,X4))@=VALUE
109 ; THIS IS A STEP TOWARD GENERATING XML FROM A VDX
110 N ZA,ZI,ZW
111 S ZI=""
112 F S ZI=$O(@INVDX@(ZI)) Q:ZI="" D ;
113 . S ZW=$E(ZI,3,$L(ZI)) ; STRIP OFF INITIAL //
114 . S ZW2=$P(ZW,"/",1)
115 . F ZK=1:1:$L(ZW,"/") D PUSH("ZA",$P(ZW,"/",ZK))
[528]116 . ;ZWR ZA
[512]117 . S ZW2=ZA(1)
118 . F ZK=2:1:ZA(0) D ;
119 . . S ZW2=ZW2_""","""_ZA(ZK)
120 . K ZA
121 . S ZW2=""""_ZW2_""""
122 . W ZW2,!
123 . S ZN=OUTXPG_"("_ZW2_")"
124 . S @ZN=@INVDX@(ZI)
125 Q
126 ;
[513]127XML2XPG(OUTXPG,INXML) ; CONVERT AN XML ARRAY, PASSED BY NAME TO AN XPG ARRAY
128 ; XPG MEANS XPATH GLOBAL AND HAS THE FORM @OUTXPG@("X1","X2","X3")=VALUE
129 ;
130 ;N G1
[528]131 D INDEX(INXML,"G1",1) ; PRODUCES A VDX ARRAY IN G1, NO INDEX IS PRODUCED
[513]132 D VDX2XPG(OUTXPG,"G1") ; CONVERTS THE VDX ARRAY TO XPG FORM
133 Q
134 ;
135DO
136 D XPG2XML("^GPL2B","^GPL2A")
137 Q
138 ;
[528]139T1 ; TEST OUT THESE ROUTINES
140 D XML2XPG("G2","^GPL")
141 D XPG2XML("G3","G2")
142 K ^GPLOUT
143 M ^GPLOUT=G3
144 W $$OUTPUT^C0CXPATH("^GPLOUT(1)","GPLTEST.xml","/home/vademo2/EHR/p")
[513]145 Q
146 ;
[528]147XPG2XML(OUTXML,INXPG) ;
148 N C0CN,FWD,ZA,G,GA,ZQ
149 S ZQ=0 ; QUIT FLAG
150 F Q:ZQ=1 D ; LOOP THROUGH EVERYTHING
151 . I '$D(C0CN) D ; FIRST TIME THROUGH
152 . . K @OUTXML ; MAKE SURE OUTPUT ARRAY IS CLEAR
153 . . S FWD=1 ; START OUT GOING FORWARD THROUGH SUBSCRIPTS
154 . . S G=$Q(@INXPG) ; THIS ONE
155 . . S GN=$Q(@G) ; NEXT ONE
156 . . S C0CN=1 ; SUBSCRIPT COUNT
157 . . S ZQ=0 ; QUIT FLAG
158 . . D ZXO("?xml version=""1.0"" encoding=""UTF-8""?") ;MAKE IT REAL XML
159 . . I $QS(G,1)="ContinuityOfCareRecord" D ;
160 . . . D ZXO("?xml-stylesheet type=""text/xsl"" href=""ccr.xsl""?") ; HACK TO MAKE THE CCR STYLESHEET WORK
161 . I FWD D ; GOING FORWARDS
162 . . I C0CN<$QL(G) D ; NOT A DATA NODE
163 . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
164 . . . D ZXO(ZA) ; AND OPEN AN XML ELEMENT
165 . . . I @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord>" D ;
166 . . . . S @OUTXML@(@OUTXML@(0))="<ContinuityOfCareRecord xmlns=""urn:astm-org:CCR"">"
167 . . . S C0CN=C0CN+1 ; MOVE TO THE NEXT ONE
168 . . E D ; AT THE DATA NODE
169 . . . S ZA=$QS(G,C0CN) ; PULL OUT THE SUBSCRIPT
170 . . . D ZXVAL(ZA,@G) ; OUTPUT <X>VAL</X> FOR DATA NODE
171 . . . S FWD=0 ; GO BACKWARDS
172 . I 'FWD D ;GOING BACKWARDS
173 . . S GN=$Q(@G) ;NEXT XPATH
174 . . ;W "NEXT!",GN,!
175 . . S C0CN=C0CN-1 ; PREVIOUS SUBSCRIPT
176 . . I GN'="" D ;
177 . . . I $QS(G,C0CN)'=$QS(GN,C0CN) D ; NEED TO CLOSE OFF ELEMENT
178 . . . . D ZXC($QS(G,C0CN)) ;
179 . . . E I GN'="" D ; MORE ELEMENTS AT THIS LEVEL
180 . . . . S G=$Q(@G) ; ADVANCE TO NEW XPATH
181 . . . . S C0CN=C0CN+1 ; GET READY TO PROCESS NEXT SUBSCRIPT
182 . . . . S FWD=1 ; GOING FORWARD NOW
183 . I (GN="")&(C0CN=1) D Q ; WHEN WE ARE ALL DONE
184 . . D ZXC($QS(G,C0CN)) ; LAST ONE
185 . . S ZQ=1 ; QUIT NOW
186 Q
187 ;
[515]188ZXO(WHAT)
[513]189 D PUSH("GA",WHAT)
190 D PUSH(OUTXML,"<"_WHAT_">")
191 Q
192 ;
[515]193ZXC(WHAT)
[513]194 D POP("GA",.TMP)
195 D PUSH(OUTXML,"</"_WHAT_">")
196 Q
197 ;
[515]198ZXVAL(WHAT,VAL)
[513]199 D PUSH(OUTXML,"<"_WHAT_">"_VAL_"</"_WHAT_">")
200 Q
201 ;
[528]202INDEX(IZXML,VDX,NOINX) ; parse the XML in IZXML and produce an XPATH index
[512]203 ; GPL 5/24/09 AND OPTIONALLY PRODUCE THE VDX ARRAY PASSED BY NAME
204 ; @VDX@("XPATH")=VALUE
[528]205 ; ex. @IZXML@("XPATH")=FIRSTLINE^LASTLINE
[391]206 ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
207 ; XML SECTION
[528]208 ; IZXML IS PASSED BY NAME
209 ; IF NOINX IS SET TO 1, NO INDEX WILL BE GENERATED, BUT THE VDX WILL BE
[512]210 N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND,CURVAL,DVDX,LCNT
[391]211 N C0CSTK ; LEAVE OUT FOR DEBUGGING
[528]212 I '$D(NOINX) S NOINX=0 ; IF NOT PASSED, GENERATE AN INDEX
213 N ZXML
214 I NOINX S ZXML=$NA(^TMP("C0CINDEX",$J)) ; TEMP PLACE FOR INDEX TO DISCARD
215 E S ZXML=IZXML ; PLACE FOR INDEX TO KEEP
216 I '$D(@IZXML@(0)) D ; IF COUNT NOT IN NODE 0 COUNT THEM
[512]217 . S I="",LCNT=0
[528]218 . F S I=$O(@IZXML@(I)) Q:I="" S LCNT=LCNT+1
219 E S LCNT=@IZXML@(0) ; LINE COUNT PASSED IN ARRAY
[512]220 I LCNT=0 D Q ; NO XML PASSED
[391]221 . W "ERROR IN XML FILE",!
[512]222 S DVDX=0 ; DEFAULT DO NOT PRODUCE VDX INDEX
223 I $D(VDX) S DVDX=1 ; IF NAME PASSED, DO VDX
[391]224 S C0CSTK(0)=0 ; INITIALIZE STACK
[512]225 F I=1:1:LCNT D ; PROCESS THE ENTIRE ARRAY
[528]226 . S LINE=@IZXML@(I)
[391]227 . ;W LINE,!
228 . S FOUND=0 ; INTIALIZED FOUND FLAG
229 . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
230 . I FOUND'=1 D
231 . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E) D
232 . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
233 . . . ; ON THE SAME LINE
234 . . . ; W "FOUND ",LINE,!
235 . . . S FOUND=1 ; SET FOUND FLAG
236 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
237 . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
238 . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
239 . . . ; W "MDX=",MDX,!
240 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE
241 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
242 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE
243 . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST
[512]244 . . . . S CURVAL=$$XVAL(LINE) ; VALUE
245 . . . . S $P(@ZXML@(MDX),"^",3)=CURVAL ; THIRD PIECE
246 . . . . I DVDX S @VDX@(MDX)=CURVAL ; FILL IN VDX ARRAY IF REQUESTED
[391]247 . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
248 . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END
249 . . I LINE?.E1"</"1.E D ; LINE CONTAINS END OF A SECTION
250 . . . ; W "FOUND ",LINE,!
251 . . . S FOUND=1 ; SET FOUND FLAG
252 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
253 . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
254 . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
255 . . . D POP("C0CSTK",.TMP) ; REMOVE FROM STACK
256 . . . I TMP'=CUR D ; MALFORMED XML, END MUST MATCH START
257 . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
258 . . . . D PARY("C0CSTK") ; PRINT OUT THE STACK FOR DEBUGING
259 . . . . Q
260 . I FOUND'=1 D ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
261 . . I (LINE?.E1"<"1.E)&(LINE'["?>") D ; BEGINNING OF A SECTION
262 . . . ; W "FOUND ",LINE,!
263 . . . S FOUND=1 ; SET FOUND FLAG
264 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
265 . . . D PUSH("C0CSTK",CUR) ; ADD TO THE STACK
266 . . . D MKMDX("C0CSTK",.MDX) ; GENERATE THE M INDEX
267 . . . ; W "MDX=",MDX,!
268 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE
269 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
270 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE
271 . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
272 S @ZXML@("INDEXED")=""
[512]273 S @ZXML@("//")="1^"_LCNT ; ROOT XPATH
[528]274 I NOINX K @ZXML ; DELETE UNWANTED INDEX
[391]275 Q
276 ;
[508]277QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
[391]278 ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
279 ; IARY AND OARY ARE PASSED BY NAME
280 I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY
281 . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
282 N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
283 N TMP,I,J,QXPATH
284 S FIRST=1
285 S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
286 I XPATH'="//" D ; NOT A ROOT QUERY
287 . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
288 . S FIRST=$P(TMP,"^",1)
289 . S LAST=$P(TMP,"^",2)
290 K @OARY
291 S @OARY@(0)=+LAST-FIRST+1
292 S J=1
293 FOR I=FIRST:1:LAST D
294 . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
295 . S J=J+1
296 ; ZWR OARY
297 Q
298 ;
[508]299XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
[391]300 ; INDEX WITH TWO PIECES START^FINISH
301 ; IDX IS PASSED BY NAME
302 Q $P(@IDX@(XPATH),"^",1)
303 ;
[508]304XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
[391]305 ; INDEX WITH TWO PIECES START^FINISH
306 ; IDX IS PASSED BY NAME
307 Q $P(@IDX@(XPATH),"^",2)
308 ;
[508]309START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
[391]310 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
311 ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
312 Q $P(ISTR,";",2)
313 ;
[508]314FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
[391]315 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
316 Q $P(ISTR,";",3)
317 ;
[508]318ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
[391]319 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
320 Q $P(ISTR,";",1)
321 ;
[508]322BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
[391]323 ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
324 ; DEST IS CLEARED TO START
325 ; USES PUSH TO DO THE COPY
326 N I
327 K @BDEST
328 F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST
329 . N J,ATMP
330 . S ATMP=$$ARRAY(@BLIST@(I))
331 . I DEBUG W "ATMP=",ATMP,!
332 . I DEBUG W @BLIST@(I),!
333 . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ;
334 . . ; FOR EACH LINE IN THIS INSTR
335 . . I DEBUG W "BDEST= ",BDEST,!
336 . . I DEBUG W "ATMP= ",@ATMP@(J),!
337 . . D PUSH(BDEST,@ATMP@(J))
338 Q
339 ;
[508]340QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST
[391]341 ;
342 I DEBUG W "QUEUEING ",BLST,!
343 D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
344 Q
345 ;
[508]346CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
[391]347 ; KILLS CPDEST FIRST
348 N CPINSTR
349 I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,!
350 I @CPSRC@(0)<1 D ; BAD LENGTH
351 . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
352 . Q
353 ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
354 D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
355 D BUILD("CPINSTR",CPDEST)
356 Q
357 ;
[508]358QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
[391]359 ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
360 ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
361 ; USED TO INSERT CHILDREN NODES
362 I @QOXML@(0)<1 D ; MALFORMED XML
363 . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
364 . Q
365 I DEBUG W "DOING QOPEN",!
366 N S1,E1,QOT,QOTMP
367 S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
368 I $D(QOXPATH) D ; XPATH PROVIDED
369 . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
370 . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
371 I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT
372 . S E1=@QOXML@(0)-1
373 D QUEUE(QOBLIST,QOXML,S1,E1)
374 ; S QOTMP=QOXML_"^"_S1_"^"_E1
375 ; D PUSH(QOBLIST,QOTMP)
376 Q
377 ;
[508]378QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN
[391]379 ; ADDS THE LIST LINE OF QCXML TO QCBLIST
380 ; USED TO FINISH INSERTING CHILDERN NODES
381 ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
382 ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
383 I @QCXML@(0)<1 D ; MALFORMED XML
384 . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
385 I DEBUG W "GOING TO CLOSE",!
386 N S1,E1,QCT,QCTMP
387 S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
388 I $D(QCXPATH) D ; XPATH PROVIDED
389 . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
390 . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
391 I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT
392 . S S1=@QCXML@(0)
393 D QUEUE(QCBLIST,QCXML,S1,E1)
394 ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
395 Q
396 ;
[508]397INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE
[391]398 ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
399 ; OMITTED, INSERTION WILL BE AT THE ROOT
400 ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
401 ; XML AT THE END OF THE XPATH POINT
402 ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
403 N INSBLD,INSTMP
404 I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
405 I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
406 I '$D(@INSXML@(0)) D ; INSERT INTO AN EMPTY ARRAY
407 . D CP^C0CXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
408 I $D(@INSXML@(0)) D ; IF ORIGINAL ARRAY IS NOT EMPTY
409 . I $D(INSXPATH) D ; XPATH PROVIDED
410 . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
411 . . I DEBUG D PARY^C0CXPATH("INSBLD")
412 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT
413 . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
414 . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
415 . I $D(INSXPATH) D ; XPATH PROVIDED
416 . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
417 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT
418 . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
419 . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
420 . D CP^C0CXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
421 Q
422 ;
[508]423INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW
[391]424 ; INTO INNXML AT THE INNXPATH XPATH POINT
425 ;
426 N INNBLD,UXPATH
427 N INNTBUF
428 S INNTBUF=$NA(^TMP($J,"INNTBUF"))
429 I '$D(INNXPATH) D ; XPATH NOT PASSED
430 . S UXPATH="//" ; USE ROOT XPATH
431 I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
432 I '$D(@INNXML@(0)) D ; INNXML IS EMPTY
433 . D QUEUE^C0CXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
434 . D BUILD("INNBLD",INNXML)
435 I @INNXML@(0)>0 D ; NOT EMPTY
436 . D QOPEN("INNBLD",INNXML,UXPATH) ;
437 . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
438 . D QCLOSE("INNBLD",INNXML,UXPATH)
439 . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
440 . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
441 Q
442 ;
[508]443INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST
[391]444 ; BUT XDEST AN XNEW ARE PASSED BY NAME
445 N XBLD,XTMP
446 D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT
447 D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST
448 D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION
449 D BUILD("XBLD","XTMP") ; BUILD THE RESULT
450 D CP("XTMP",XDEST) ; COPY TO THE DESTINATION
451 I DEBUG D PARY("XDEST")
452 Q
453 ;
[508]454REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT
[391]455 ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
456 ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
457 ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
458 N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
459 S OLD=$NA(^TMP($J,"REPLACE_OLD"))
460 D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
461 S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
462 S XFIRST=$P(XNODE,"^",1)
463 S XLAST=$P(XNODE,"^",2)
464 I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG
465 . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
466 . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
467 I RENEW'="" D ; NEW XML IS NOT NULL
468 . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
469 . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
470 . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
471 I DEBUG W "REPLACE PREBUILD",!
472 I DEBUG D PARY("REBLD")
473 D BUILD("REBLD","RTMP")
474 K @REXML ; KILL WHAT WAS THERE
475 D CP("RTMP",REXML) ; COPY IN THE RESULT
476 Q
477 ;
[508]478MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
[391]479 ; W "Reporting on the missing",!
480 ; W OARY
481 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
482 N I
483 S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
484 F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY
485 . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE
486 . . D PUSH^C0CXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
487 . . Q
488 Q
489 ;
[508]490MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY
[391]491 ; AND PUT THE RESULTS IN OXML
492 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q
493 I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
494 N I,J,TNAM,TVAL,TSTR
495 S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT
496 F I=1:1:@OXML@(0) D ; LOOP THROUGH WHOLE ARRAY
497 . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
498 . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE?
499 . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS
500 . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS
501 . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,!
502 . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME
503 . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED
504 . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP?
505 . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD
506 . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
507 . . . . E D DOFLD ; PROCESS A FIELD
508 . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE
509 . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER
510 . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES
511 . . I DEBUG W TSTR
512 I DEBUG W "MAPPED",!
513 Q
514 ;
[508]515DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE
[391]516 ;
517 Q
518 ;
[508]519TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS
[391]520 ; THEXML IS PASSED BY NAME
521 N I,J,TMPXML,DEL,FOUND,INTXT
522 S FOUND=0
523 S INTXT=0
524 I DEBUG W "DELETING EMPTY ELEMENTS",!
525 F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY
526 . S J=@THEXML@(I)
527 . I J["<text>" D
528 . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM
529 . . I DEBUG W "IN HTML SECTION",!
530 . N JM,JP,JPX ; JMINUS AND JPLUS
531 . S JM=@THEXML@(I-1) ; LINE BEFORE
532 . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM
533 . S JP=@THEXML@(I+1) ; LINE AFTER
534 . I INTXT=0 D ; IF NOT IN AN HTML SECTION
535 . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH
536 . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES
537 . . . I DEBUG W I,J,JP,!
538 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
539 . . . S DEL(I)="" ; SET LINE TO DELETE
540 . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE
541 . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE
542 . . . I DEBUG W I,J,!
543 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
544 . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED
545 . . . I JM=JPX D ;
546 . . . . I DEBUG W I,JM_J_JPX,!
547 . . . . S DEL(I-1)=""
548 . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL
549 ; . I J'["><" D PUSH("TMPXML",J)
550 I FOUND D ; NEED TO DELETE THINGS
551 . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES
552 . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED
553 . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY
554 . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY
555 Q FOUND
556 ;
[508]557UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML
[391]558 ; XSEC IS A SECTION PASSED BY NAME
559 N XBLD,XTMP
560 D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML
561 D BUILD("XBLD","XTMP") ; BUILD THE RESULT
562 D CP("XTMP",XSEC) ; REPLACE PASSED XML
563 Q
564 ;
[508]565PARY(GLO) ;PRINT AN ARRAY
[391]566 N I
567 F I=1:1:@GLO@(0) W I_" "_@GLO@(I),!
568 Q
569 ;
[508]570H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY
[391]571 ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE
572 I '$D(IPRE) S IPRE=""
573 N H2I S H2I=""
574 ; W $O(@IHASH@(H2I)),!
575 F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH
576 . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES
577 . . ;W H2I_"^"_@IHASH@(H2I),!
578 . . N IH,IHI
579 . . S IH=$NA(@IHASH@(H2I)) ;
580 . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR
581 . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE
582 . . S IHI="" ; INDEX INTO "M" MULTIPLES
583 . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE
584 . . . ; W @IH@(IHI)
585 . . . S IH3=$NA(@IH2@(IHI))
586 . . . ; W "HEY",IH3,!
587 . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS
588 . . ; W IH,!
589 . . ; W "C0CZZ",!
590 . . ; W $NA(@IHASH@(H2I)),!
591 . . Q ;
592 . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I))
593 . ; W @IARYRTN@(0),!
594 Q
595 ;
[508]596XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES
[391]597 ; DEFINED IN INPUT XML XVIXML BY @@VAR@@
598 ; XVRTN AND XVIXML ARE PASSED BY NAME
599 ;
600 N XVI,XVTMP,XVT
601 F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML
602 . S XVT=@XVIXML@(XVI)
603 . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI
604 D H2ARY(XVRTN,"XVTMP")
605 Q
606 ;
[508]607DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE
[391]608 ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE
609 ;
610 N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED
611 I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE
612 . D LOAD^C0CCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
613 . S DXUSE="DTMP" ; DXUSE IS NAME
614 E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE
615 . D LOAD^C0CCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
616 . S DXUSE="DTMP" ; DXUSE IS NAME
617 E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE
618 N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE
619 D XVARS("DVARS",DXUSE) ; PULL OUT VARS
620 D PARY^C0CXPATH("DVARS") ;AND DISPLAY THEM
621 Q
622 ;
[508]623TEST ; Run all the test cases
[391]624 D TESTALL^C0CUNIT("C0CXPAT0")
625 Q
626 ;
[508]627ZTEST(WHICH) ; RUN ONE SET OF TESTS
[391]628 N ZTMP
629 S DEBUG=1
630 D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
631 D ZTEST^C0CUNIT(.ZTMP,WHICH)
632 Q
633 ;
[508]634TLIST ; LIST THE TESTS
[391]635 N ZTMP
636 D ZLOAD^C0CUNIT("ZTMP","C0CXPAT0")
637 D TLIST^C0CUNIT(.ZTMP)
638 Q
639 ;
Note: See TracBrowser for help on using the repository browser.