Changeset 1537 for smart/trunk


Ignore:
Timestamp:
Sep 26, 2012, 12:26:15 PM (12 years ago)
Author:
Sam Habiel
Message:

Updated C0SXPATH

File:
1 edited

Legend:

Unmodified
Added
Removed
  • smart/trunk/p/C0SXPATH.m

    r1526 r1537  
    1  C0SXPATH   ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
    2  ;;1.0;C0S;;May 19, 2009;Build 2
    3  ;Copyright 2008-2012 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  ;
     1C0SXPATH   ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 ; 9/26/12 10:45am
     2        ;;1.0;C0S;;May 19, 2009;Build 2
     3        ;Copyright 2008-2012 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        ;
     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,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        ;
     72XNAME(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        ;
     87XVAL(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        ;
     93VDX2VDV(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        ;
     108VDX2XPG(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        ;
     129XML2XPG(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        ;
     137DO     
     138        D XPG2XML("^GPL2B","^GPL2A")
     139        Q
     140        ;
     141T1      ; 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        ;
     149XPG2XML(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        ;
     190ZXO(WHAT)       
     191        D PUSH("GA",WHAT)
     192        D PUSH(OUTXML,"<"_WHAT_">")
     193        Q
     194        ;
     195ZXC(WHAT)       
     196        D POP("GA",.TMP)
     197        D PUSH(OUTXML,"</"_WHAT_">")
     198        Q
     199        ;
     200ZXVAL(WHAT,VAL) 
     201        D PUSH(OUTXML,"<"_WHAT_">"_VAL_"</"_WHAT_">")
     202        Q
     203        ;
     204INDEX(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        ;
     300MKLASD(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        ;
     326CLEAN(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        ;
     336QUERY(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        ;
     360XF(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        ;
     365XL(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        ;
     370START(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        ;
     375FINISH(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        ;
     379ARRAY(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        ;
     383BUILD(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        ;
     401QUEUE(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        ;
     407CP(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        ;
     419QOPEN(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        ;
     439QCLOSE(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        ;
     458INSERT(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        ;
     486INSINNER(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        ;
     506INSB4(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        ;
     517REPLACE(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        ;
     541DELETE(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        ;
     557MISSING(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        ;
     569MAP(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        ;
     599DOFLD   ; PROCESS A FILEMAN FIELD REFERENCED BY A VARIABLE
     600        ;
     601        Q
     602        ;
     603TRIM(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        ;
     641UNMARK(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        ;
     649PARY(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        ;
     657H2ARY(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        ;
     683XVARS(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        ;
     694DXVARS(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        ;
     710TEST        ; Run all the test cases
     711        D TESTALL^C0CUNIT("C0CXPAT0")
     712        Q
     713        ;
     714ZTEST(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        ;
     721TLIST     ; 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.