Ignore:
Timestamp:
Oct 11, 2012, 1:42:56 PM (12 years ago)
Author:
George Lilly
Message:

fix to lab units of measure not found situation

File:
1 edited

Legend:

Unmodified
Added
Removed

  • smart/trunk/p/C0SXPATH.m

    r1540 r1569  
    1 C0SXPATH          ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08 ; 9/26/12 10:45am
    2         ;;1.0;VISTA SMART CONTAINER;;Sep 26, 2012;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
     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.