source: ccr/trunk/p/GPLXPATH.m@ 329

Last change on this file since 329 was 313, checked in by George Lilly, 16 years ago

changes for RPMS support - set TMP("GPLCCR","RPMS")=1

File size: 18.0 KB
Line 
1GPLXPATH ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
2 ;;0.2;CCDCCR;nopatch;noreleasedate
3 ;Copyright 2008 WorldVistA. 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 ;
24OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE
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 ;
32PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0)
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 ;
40POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL
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 ;
52PUSHA(ADEST,ASRC) ; PUSH ASRC ONTO ADEST, BOTH PASSED BY NAME
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 ;
59MKMDX(STK,RTN) ; MAKES A MUMPS INDEX FROM THE ARRAY STK
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 ;
70XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
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 ;
85INDEX(ZXML) ; parse the XML in ZXML and produce an XPATH index
86 ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE
87 ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
88 ; XML SECTION
89 ; ZXML IS PASSED BY NAME
90 N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND
91 N GPLSTK ; LEAVE OUT FOR DEBUGGING
92 I '$D(@ZXML@(0)) D ; NO XML PASSED
93 . W "ERROR IN XML FILE",!
94 S GPLSTK(0)=0 ; INITIALIZE STACK
95 F I=1:1:@ZXML@(0) D ; PROCESS THE ENTIRE ARRAY
96 . S LINE=@ZXML@(I)
97 . ;W LINE,!
98 . S FOUND=0 ; INTIALIZED FOUND FLAG
99 . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
100 . I FOUND'=1 D
101 . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E) D
102 . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
103 . . . ; ON THE SAME LINE
104 . . . ; W "FOUND ",LINE,!
105 . . . S FOUND=1 ; SET FOUND FLAG
106 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
107 . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
108 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
109 . . . ; W "MDX=",MDX,!
110 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE
111 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
112 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE
113 . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST
114 . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
115 . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END
116 . . I LINE?.E1"</"1.E D ; LINE CONTAINS END OF A SECTION
117 . . . ; W "FOUND ",LINE,!
118 . . . S FOUND=1 ; SET FOUND FLAG
119 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
120 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
121 . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
122 . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
123 . . . I TMP'=CUR D ; MALFORMED XML, END MUST MATCH START
124 . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
125 . . . . D PARY("GPLSTK") ; PRINT OUT THE STACK FOR DEBUGING
126 . . . . Q
127 . I FOUND'=1 D ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
128 . . I (LINE?.E1"<"1.E)&(LINE'["?>") D ; BEGINNING OF A SECTION
129 . . . ; W "FOUND ",LINE,!
130 . . . S FOUND=1 ; SET FOUND FLAG
131 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
132 . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
133 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
134 . . . ; W "MDX=",MDX,!
135 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE
136 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
137 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE
138 . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
139 S @ZXML@("INDEXED")=""
140 S @ZXML@("//")="1^"_@ZXML@(0) ; ROOT XPATH
141 Q
142 ;
143QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
144 ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
145 ; IARY AND OARY ARE PASSED BY NAME
146 I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY
147 . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
148 N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
149 N TMP,I,J,QXPATH
150 S FIRST=1
151 S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
152 I XPATH'="//" D ; NOT A ROOT QUERY
153 . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
154 . S FIRST=$P(TMP,"^",1)
155 . S LAST=$P(TMP,"^",2)
156 K @OARY
157 S @OARY@(0)=+LAST-FIRST+1
158 S J=1
159 FOR I=FIRST:1:LAST D
160 . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
161 . S J=J+1
162 ; ZWR OARY
163 Q
164 ;
165XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
166 ; INDEX WITH TWO PIECES START^FINISH
167 ; IDX IS PASSED BY NAME
168 Q $P(@IDX@(XPATH),"^",1)
169 ;
170XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
171 ; INDEX WITH TWO PIECES START^FINISH
172 ; IDX IS PASSED BY NAME
173 Q $P(@IDX@(XPATH),"^",2)
174 ;
175START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
176 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
177 ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
178 Q $P(ISTR,";",2)
179 ;
180FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
181 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
182 Q $P(ISTR,";",3)
183 ;
184ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
185 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
186 Q $P(ISTR,";",1)
187 ;
188BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
189 ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
190 ; DEST IS CLEARED TO START
191 ; USES PUSH TO DO THE COPY
192 N I
193 K @BDEST
194 F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST
195 . N J,ATMP
196 . S ATMP=$$ARRAY(@BLIST@(I))
197 . I DEBUG W "ATMP=",ATMP,!
198 . I DEBUG W @BLIST@(I),!
199 . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ;
200 . . ; FOR EACH LINE IN THIS INSTR
201 . . I DEBUG W "BDEST= ",BDEST,!
202 . . I DEBUG W "ATMP= ",@ATMP@(J),!
203 . . D PUSH(BDEST,@ATMP@(J))
204 Q
205 ;
206QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST
207 ;
208 I DEBUG W "QUEUEING ",BLST,!
209 D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
210 Q
211 ;
212CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
213 ; KILLS CPDEST FIRST
214 N CPINSTR
215 I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,!
216 I @CPSRC@(0)<1 D ; BAD LENGTH
217 . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
218 . Q
219 ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
220 D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
221 D BUILD("CPINSTR",CPDEST)
222 Q
223 ;
224QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
225 ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
226 ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
227 ; USED TO INSERT CHILDREN NODES
228 I @QOXML@(0)<1 D ; MALFORMED XML
229 . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
230 . Q
231 I DEBUG W "DOING QOPEN",!
232 N S1,E1,QOT,QOTMP
233 S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
234 I $D(QOXPATH) D ; XPATH PROVIDED
235 . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
236 . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
237 I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT
238 . S E1=@QOXML@(0)-1
239 D QUEUE(QOBLIST,QOXML,S1,E1)
240 ; S QOTMP=QOXML_"^"_S1_"^"_E1
241 ; D PUSH(QOBLIST,QOTMP)
242 Q
243 ;
244QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN
245 ; ADDS THE LIST LINE OF QCXML TO QCBLIST
246 ; USED TO FINISH INSERTING CHILDERN NODES
247 ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
248 ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
249 I @QCXML@(0)<1 D ; MALFORMED XML
250 . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
251 I DEBUG W "GOING TO CLOSE",!
252 N S1,E1,QCT,QCTMP
253 S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
254 I $D(QCXPATH) D ; XPATH PROVIDED
255 . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
256 . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
257 I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT
258 . S S1=@QCXML@(0)
259 D QUEUE(QCBLIST,QCXML,S1,E1)
260 ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
261 Q
262 ;
263INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE
264 ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
265 ; OMITTED, INSERTION WILL BE AT THE ROOT
266 ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
267 ; XML AT THE END OF THE XPATH POINT
268 ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
269 N INSBLD,INSTMP
270 I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
271 I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
272 I '$D(@INSXML@(0)) D ; INSERT INTO AN EMPTY ARRAY
273 . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
274 I $D(@INSXML@(0)) D ; IF ORIGINAL ARRAY IS NOT EMPTY
275 . I $D(INSXPATH) D ; XPATH PROVIDED
276 . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
277 . . I DEBUG D PARY^GPLXPATH("INSBLD")
278 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT
279 . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
280 . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
281 . I $D(INSXPATH) D ; XPATH PROVIDED
282 . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
283 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT
284 . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
285 . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
286 . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
287 Q
288 ;
289INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW
290 ; INTO INNXML AT THE INNXPATH XPATH POINT
291 ;
292 N INNBLD,UXPATH
293 N INNTBUF
294 S INNTBUF=$NA(^TMP($J,"INNTBUF"))
295 I '$D(INNXPATH) D ; XPATH NOT PASSED
296 . S UXPATH="//" ; USE ROOT XPATH
297 I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
298 I '$D(@INNXML@(0)) D ; INNXML IS EMPTY
299 . D QUEUE^GPLXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
300 . D BUILD("INNBLD",INNXML)
301 I @INNXML@(0)>0 D ; NOT EMPTY
302 . D QOPEN("INNBLD",INNXML,UXPATH) ;
303 . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
304 . D QCLOSE("INNBLD",INNXML,UXPATH)
305 . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
306 . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
307 Q
308 ;
309INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST
310 ; BUT XDEST AN XNEW ARE PASSED BY NAME
311 N XBLD,XTMP
312 D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT
313 D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST
314 D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION
315 D BUILD("XBLD","XTMP") ; BUILD THE RESULT
316 D CP("XTMP",XDEST) ; COPY TO THE DESTINATION
317 I DEBUG D PARY("XDEST")
318 Q
319 ;
320REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT
321 ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
322 ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
323 ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
324 N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
325 S OLD=$NA(^TMP($J,"REPLACE_OLD"))
326 D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
327 S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
328 S XFIRST=$P(XNODE,"^",1)
329 S XLAST=$P(XNODE,"^",2)
330 I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG
331 . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
332 . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
333 I RENEW'="" D ; NEW XML IS NOT NULL
334 . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
335 . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
336 . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
337 I DEBUG W "REPLACE PREBUILD",!
338 I DEBUG D PARY("REBLD")
339 D BUILD("REBLD","RTMP")
340 K @REXML ; KILL WHAT WAS THERE
341 D CP("RTMP",REXML) ; COPY IN THE RESULT
342 Q
343 ;
344MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
345 ; W "Reporting on the missing",!
346 ; W OARY
347 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
348 N I
349 S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
350 F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY
351 . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE
352 . . D PUSH^GPLXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
353 . . Q
354 Q
355 ;
356MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY
357 ; AND PUT THE RESULTS IN OXML
358 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q
359 I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
360 N I,J,TNAM,TVAL,TSTR
361 S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT
362 F I=1:1:@OXML@(0) D ; LOOP THROUGH WHOLE ARRAY
363 . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
364 . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE?
365 . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS
366 . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS
367 . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,!
368 . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME
369 . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED
370 . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP?
371 . . . . I '$D(@INARY@(TNAM,"F")) D ; NOT A SPECIAL FIELD
372 . . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
373 . . . . E D DOFLD ; PROCESS A FIELD
374 . . . S TVAL=$$SYMENC^MXMLUTL(TVAL) ;MAKE SURE THE VALUE IS XML SAFE
375 . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER
376 . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES
377 . . I DEBUG W TSTR
378 I DEBUG W "MAPPED",!
379 Q
380 ;
381DOFLD ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE
382 ;
383 Q
384 ;
385TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS
386 ; THEXML IS PASSED BY NAME
387 N I,J,TMPXML,DEL,FOUND,INTXT
388 S FOUND=0
389 S INTXT=0
390 I DEBUG W "DELETING EMPTY ELEMENTS",!
391 F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY
392 . S J=@THEXML@(I)
393 . I J["<text>" D
394 . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM
395 . . I DEBUG W "IN HTML SECTION",!
396 . N JM,JP,JPX ; JMINUS AND JPLUS
397 . S JM=@THEXML@(I-1) ; LINE BEFORE
398 . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM
399 . S JP=@THEXML@(I+1) ; LINE AFTER
400 . I INTXT=0 D ; IF NOT IN AN HTML SECTION
401 . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH
402 . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES
403 . . . I DEBUG W I,J,JP,!
404 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
405 . . . S DEL(I)="" ; SET LINE TO DELETE
406 . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE
407 . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE
408 . . . I DEBUG W I,J,!
409 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
410 . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED
411 . . . I JM=JPX D ;
412 . . . . I DEBUG W I,JM_J_JPX,!
413 . . . . S DEL(I-1)=""
414 . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL
415 ; . I J'["><" D PUSH("TMPXML",J)
416 I FOUND D ; NEED TO DELETE THINGS
417 . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES
418 . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED
419 . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY
420 . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY
421 Q FOUND
422 ;
423UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML
424 ; XSEC IS A SECTION PASSED BY NAME
425 N XBLD,XTMP
426 D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML
427 D BUILD("XBLD","XTMP") ; BUILD THE RESULT
428 D CP("XTMP",XSEC) ; REPLACE PASSED XML
429 Q
430 ;
431PARY(GLO) ;PRINT AN ARRAY
432 N I
433 F I=1:1:@GLO@(0) W I_" "_@GLO@(I),!
434 Q
435 ;
436H2ARY(IARYRTN,IHASH,IPRE) ; CONVERT IHASH TO RETURN ARRAY
437 ; IPRE IS OPTIONAL PREFIX FOR THE ELEMENTS. USED FOR MUPTIPLES 1^"VAR"^VALUE
438 I '$D(IPRE) S IPRE=""
439 N H2I S H2I=""
440 ; W $O(@IHASH@(H2I)),!
441 F S H2I=$O(@IHASH@(H2I)) Q:H2I="" D ; FOR EACH ELEMENT OF THE HASH
442 . I $QS(H2I,$QL(H2I))="M" D Q ; SPECIAL CASE FOR MULTIPLES
443 . . ;W H2I_"^"_@IHASH@(H2I),!
444 . . N IH,IHI
445 . . S IH=$NA(@IHASH@(H2I)) ;
446 . . S IH2A=$O(@IH@("")) ; SKIP OVER MULTIPLE DISCRIPTOR
447 . . S IH2=$NA(@IH@(IH2A)) ; PAST THE "M","DIRETIONS" FOR EXAMPLE
448 . . S IHI="" ; INDEX INTO "M" MULTIPLES
449 . . F S IHI=$O(@IH2@(IHI)) Q:IHI="" D ; FOR EACH SUB-MULTIPLE
450 . . . ; W @IH@(IHI)
451 . . . S IH3=$NA(@IH2@(IHI))
452 . . . ; W "HEY",IH3,!
453 . . . D H2ARY(.IARYRTN,IH3,IPRE_";"_IHI) ; RECURSIVE CALL - INDENTED ELEMENTS
454 . . ; W IH,!
455 . . ; W "GPLZZ",!
456 . . ; W $NA(@IHASH@(H2I)),!
457 . . Q ;
458 . D PUSH(IARYRTN,IPRE_"^"_H2I_"^"_@IHASH@(H2I))
459 . ; W @IARYRTN@(0),!
460 Q
461 ;
462XVARS(XVRTN,XVIXML) ; RETURNS AN ARRAY XVRTN OF ALL UNIQUE VARIABLES
463 ; DEFINED IN INPUT XML XVIXML BY @@VAR@@
464 ; XVRTN AND XVIXML ARE PASSED BY NAME
465 ;
466 N XVI,XVTMP,XVT
467 F XVI=1:1:@XVIXML@(0) D ; FOR ALL LINES OF THE XML
468 . S XVT=@XVIXML@(XVI)
469 . I XVT["@@" S XVTMP($P(XVT,"@@",2))=XVI
470 D H2ARY(XVRTN,"XVTMP")
471 Q
472 ;
473DXVARS(DXIN) ;DISPLAY ALL VARIABLES IN A TEMPLATE
474 ; IF PARAMETERS ARE NULL, DEFAULTS TO CCR TEMPLATE
475 ;
476 N DXUSE,DTMP ; DXUSE IS NAME OF VARIABLE, DTMP IS VARIABLE IF NOT SUPPLIED
477 I DXIN="CCR" D ; NEED TO GO GET CCR TEMPLATE
478 . D LOAD^GPLCCR0("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
479 . S DXUSE="DTMP" ; DXUSE IS NAME
480 E I DXIN="CCD" D ; NEED TO GO GET CCD TEMPLATE
481 . D LOAD^GPLCCD1("DTMP") ; LOAD CCR TEMPLATE INTO DXTMP
482 . S DXUSE="DTMP" ; DXUSE IS NAME
483 E S DXUSE=DXIN ; IF PASSED THE TEMPLATE TO USE
484 N DVARS ; PUT VARIABLE NAME RESULTS IN ARRAY HERE
485 D XVARS("DVARS",DXUSE) ; PULL OUT VARS
486 D PARY^GPLXPATH("DVARS") ;AND DISPLAY THEM
487 Q
488 ;
489TEST ; Run all the test cases
490 D TESTALL^GPLUNIT("GPLXPAT0")
491 Q
492 ;
493ZTEST(WHICH) ; RUN ONE SET OF TESTS
494 N ZTMP
495 S DEBUG=1
496 D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0")
497 D ZTEST^GPLUNIT(.ZTMP,WHICH)
498 Q
499 ;
500TLIST ; LIST THE TESTS
501 N ZTMP
502 D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0")
503 D TLIST^GPLUNIT(.ZTMP)
504 Q
505 ;
Note: See TracBrowser for help on using the repository browser.