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