Changeset 149 for ccr/trunk/p


Ignore:
Timestamp:
Sep 11, 2008, 4:09:14 PM (16 years ago)
Author:
George Lilly
Message:

removed extra spaces at the beginning of lines

Location:
ccr/trunk/p
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • ccr/trunk/p/CCRUTIL.m

    r122 r149  
    11CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08
    2           ;;0.1;CCRCCD;;Jun 15, 2008;
     2 ;;0.1;CCRCCD;;Jun 15, 2008;
    33 ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
    44 ;General Public License See attached copy of the License.
     
    1717 ;with this program; if not, write to the Free Software Foundation, Inc.,
    1818 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    19     ;
    20           W "No Entry at Top!"
    21           Q
    22           ;
     19 ;
     20 W "No Entry at Top!"
     21 Q
     22 ;
    2323FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic
    24           ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
    25           ; If not passed, or passed incorrectly, it's assumed that it is D.
    26           ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
    27           ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
    28           ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
    29           N UTC,Y,M,D,H,MM,S,OFF
    30           S Y=1700+$E(DATE,1,3)
    31           S M=$E(DATE,4,5)
    32           S D=$E(DATE,6,7)
    33           S H=$E(DATE,9,10)
    34           I $L(H)=1 S H="0"_H
    35           S MM=$E(DATE,11,12)
    36           I $L(MM)=1 S MM="0"_MM
    37           S S=$E(DATE,13,14)
    38           I $L(S)=1 S S="0"_S
    39           S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
    40           ; If H, MM and S are empty, it means that the FM date didn't supply the time.
    41           ; In this case, set H, MM and S to "00"
    42           ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING?
    43           S:'$L(H) H="00"
    44           S:'$L(MM) MM="00"
    45           S:'$L(S) S="00"
    46           S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
    47           I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
    48           E  Q $P(UTC,"T")
    49           ;
     24 ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time)
     25 ; If not passed, or passed incorrectly, it's assumed that it is D.
     26 ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied.
     27 ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC
     28 ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters)
     29 N UTC,Y,M,D,H,MM,S,OFF
     30 S Y=1700+$E(DATE,1,3)
     31 S M=$E(DATE,4,5)
     32 S D=$E(DATE,6,7)
     33 S H=$E(DATE,9,10)
     34 I $L(H)=1 S H="0"_H
     35 S MM=$E(DATE,11,12)
     36 I $L(MM)=1 S MM="0"_MM
     37 S S=$E(DATE,13,14)
     38 I $L(S)=1 S S="0"_S
     39 S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation.
     40 ; If H, MM and S are empty, it means that the FM date didn't supply the time.
     41 ; In this case, set H, MM and S to "00"
     42 ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING?
     43 S:'$L(H) H="00"
     44 S:'$L(MM) MM="00"
     45 S:'$L(S) S="00"
     46 S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds
     47 I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time.
     48 E  Q $P(UTC,"T")
     49 ;
    5050SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT
    51                ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
    52                ; DATE AND TIME ORDER. DEFAULT IS FORWARD
    53                ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
    54                ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
    55                ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
    56                ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
    57                ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
    58           N VSRT ; TEMP FOR HASHING DATES
    59           N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
    60           S ZCNT=0 ; COUNTING NUMBER OF DATES
    61           S ZTMP="" ;
    62           F ZI=0:0 D  Q:$O(V2(ZTMP))=""  ; FOR EACH DATE IN THE ARRAY
    63           . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT
    64           . S ZTMP=$O(V2(ZTMP)) ; NEXT DATE
    65           . I $D(V2(ZTMP)) D  ; IF THE DATE EXISTS
    66           . . S ZP1=$P(V2(ZTMP),".",1) ; THE DATE PIECE
    67           . . S ZP2=$P(V2(ZTMP),".",2) ; THE TIME PIECE
    68           . . S VSRT(ZP1,ZP2_"00000"_ZCNT)=ZCNT ; HASH ON DATE AND TIME
    69           . . ; S VSRT($P(V2(ZTMP),U,4)_"000000"_ZCNT)=ZCNT ; PULL DATE
    70           . I DEBUG W "ZTMP=",ZTMP," "
    71           S V1(0)=ZCNT ; ARRAYS ARE THE SAME SIZE
    72           ; I DEBUG ZWR V2
    73           ; I DEBUG ZWR VSRT
    74           N ZD,ZT ; DATA AND TIME ITERATORS
    75           N ZDONE ; DONE FLAG
    76           S (ZD,ZT)=""
    77           S ZDONE=0
    78           N UORDR ; ORDER TO USE 1=FORWARD -1=REVERSE
    79           S UORDR=ORDR ; DIRECTION TO SORT
    80           I ORDR="" S UORDR=1
    81           N ZZCNT S ZZCNT=0 ; ANOTHER COUNTER
    82           F ZI=0:0 D  Q:ZDONE  ; VISIT THE ARRAY IN DATE ORDER
    83           . S ZD=$O(VSRT(ZD),UORDR) ; NEXT DATE
    84           . I ZD="" S ZDONE=1
    85           . I 'ZDONE D  ; MORE DATES
    86           . . S ZT="" ; WANT FIRST TIME FOR THIS DATE
    87           . . F ZJ=0:0 D  Q:$O(VSRT(ZD,ZT),UORDR)=""  ; LOOP THROUGH ALL TIMES
    88           . . . S ZT=$O(VSRT(ZD,ZT),UORDR) ; NEXT TIME
    89           . . . S ZZCNT=ZZCNT+1 ; INCREMENT COUNTER
    90           . . . S V1(ZZCNT)=VSRT(ZD,ZT) ; PULL OUT THE INDEX
    91           Q ZCNT
    92           ;
     51 ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
     52 ; DATE AND TIME ORDER. DEFAULT IS FORWARD
     53 ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
     54 ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
     55 ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
     56 ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
     57 ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
     58 N VSRT ; TEMP FOR HASHING DATES
     59 N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
     60 S ZCNT=0 ; COUNTING NUMBER OF DATES
     61 S ZTMP="" ;
     62 F ZI=0:0 D  Q:$O(V2(ZTMP))=""  ; FOR EACH DATE IN THE ARRAY
     63 . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT
     64 . S ZTMP=$O(V2(ZTMP)) ; NEXT DATE
     65 . I $D(V2(ZTMP)) D  ; IF THE DATE EXISTS
     66 . . S ZP1=$P(V2(ZTMP),".",1) ; THE DATE PIECE
     67 . . S ZP2=$P(V2(ZTMP),".",2) ; THE TIME PIECE
     68 . . S VSRT(ZP1,ZP2_"00000"_ZCNT)=ZCNT ; HASH ON DATE AND TIME
     69 . . ; S VSRT($P(V2(ZTMP),U,4)_"000000"_ZCNT)=ZCNT ; PULL DATE
     70 . I DEBUG W "ZTMP=",ZTMP," "
     71 S V1(0)=ZCNT ; ARRAYS ARE THE SAME SIZE
     72 ; I DEBUG ZWR V2
     73 ; I DEBUG ZWR VSRT
     74 N ZD,ZT ; DATA AND TIME ITERATORS
     75 N ZDONE ; DONE FLAG
     76 S (ZD,ZT)=""
     77 S ZDONE=0
     78 N UORDR ; ORDER TO USE 1=FORWARD -1=REVERSE
     79 S UORDR=ORDR ; DIRECTION TO SORT
     80 I ORDR="" S UORDR=1
     81 N ZZCNT S ZZCNT=0 ; ANOTHER COUNTER
     82 F ZI=0:0 D  Q:ZDONE  ; VISIT THE ARRAY IN DATE ORDER
     83 . S ZD=$O(VSRT(ZD),UORDR) ; NEXT DATE
     84 . I ZD="" S ZDONE=1
     85 . I 'ZDONE D  ; MORE DATES
     86 . . S ZT="" ; WANT FIRST TIME FOR THIS DATE
     87 . . F ZJ=0:0 D  Q:$O(VSRT(ZD,ZT),UORDR)=""  ; LOOP THROUGH ALL TIMES
     88 . . . S ZT=$O(VSRT(ZD,ZT),UORDR) ; NEXT TIME
     89 . . . S ZZCNT=ZZCNT+1 ; INCREMENT COUNTER
     90 . . . S V1(ZZCNT)=VSRT(ZD,ZT) ; PULL OUT THE INDEX
     91 Q ZCNT
     92 ;
     93SORTDT2(V1,V2,ORDR) ; REWRITE TO USE 3 INSTEAD OF 2 LVLS OF INDEX
     94 ; AND $Q INSTEAD OF $O
     95 ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT
     96 ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE
     97 ; DATE AND TIME ORDER. DEFAULT IS FORWARD
     98 ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT
     99 ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER
     100 ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER
     101 ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC
     102 ; BOTH V1 AND V2 ARE PASSED BY REFERENCE
     103 N VSRT ; TEMP FOR HASHING DATES
     104 N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2
     105 S ZCNT=0 ; COUNTING NUMBER OF DATES
     106 S ZTMP="" ;
     107 F ZI=0:0 D  Q:$O(V2(ZTMP))=""  ; FOR EACH DATE IN THE ARRAY
     108 . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT
     109 . S ZTMP=$O(V2(ZTMP)) ; NEXT DATE
     110 . I $D(V2(ZTMP)) D  ; IF THE DATE EXISTS
     111 . . S ZP1=$P(V2(ZTMP),".",1) ; THE DATE PIECE
     112 . . S ZP2=$P(V2(ZTMP),".",2) ; THE TIME PIECE
     113 . . S VSRT(ZP1,ZP2,ZCNT)=ZCNT ; HASH ON DATE AND TIME
     114 . I DEBUG W "ZTMP=",ZTMP," "
     115 S V1(0)=ZCNT ; ARRAYS ARE THE SAME SIZE
     116 ; I DEBUG ZWR V2
     117 ; I DEBUG ZWR VSRT
     118 N ZD,ZT ; DATA AND TIME ITERATORS
     119 N ZDONE ; DONE FLAG
     120 S (ZD,ZT)=""
     121 S ZDONE=0
     122 N UORDR ; ORDER TO USE 1=FORWARD -1=REVERSE
     123 S UORDR=ORDR ; DIRECTION TO SORT
     124 I ORDR="" S UORDR=1
     125 N ZZCNT S ZZCNT=0 ; ANOTHER COUNTER
     126 F ZI=0:0 D  Q:ZDONE  ; VISIT THE ARRAY IN DATE ORDER
     127 . S ZD=$O(VSRT(ZD),UORDR) ; NEXT DATE fix this
     128 . I ZD="" S ZDONE=1
     129 . I 'ZDONE D  ; MORE DATES
     130 . . S ZT="" ; WANT FIRST TIME FOR THIS DATE
     131 . . F ZJ=0:0 D  Q:$O(VSRT(ZD,ZT),UORDR)=""  ; LOOP THROUGH ALL TIMES
     132 . . . S ZT=$O(VSRT(ZD,ZT),UORDR) ; NEXT TIME
     133 . . . S ZZCNT=ZZCNT+1 ; INCREMENT COUNTER
     134 . . . S V1(ZZCNT)=VSRT(ZD,ZT) ; PULL OUT THE INDEX
     135 Q ZCNT
     136 ;
  • ccr/trunk/p/GPLXPATH.m

    r134 r149  
    1818 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    1919 ;
    20           W "This is an XML XPATH utility library",!
    21           W !
    22           Q
    23           ;
     20 W "This is an XML XPATH utility library",!
     21 W !
     22 Q
     23 ;
    2424OUTPUT(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           ;
     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 ;
    3232PUSH(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           ;
     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 ;
    4040POP(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           ;
     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 ;
    5252MKMDX(STK,RTN)  ; MAKES A MUMPS INDEX FROM THE ARRAY STK
    53           ; RTN IS SET TO //FIRST/SECOND/THIRD" FOR THREE ARRAY ELEMENTS
    54           S RTN=""
    55           N I
    56           ; W "STK= ",STK,!
    57           I @STK@(0)>0  D  ; IF THE ARRAY IS NOT EMPTY
    58           . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
    59           . I @STK@(0)>1  D  ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
    60           . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
    61           Q
    62           ;
     53 ; RTN IS SET TO //FIRST/SECOND/THIRD" FOR THREE ARRAY ELEMENTS
     54 S RTN=""
     55 N I
     56 ; W "STK= ",STK,!
     57 I @STK@(0)>0  D  ; IF THE ARRAY IS NOT EMPTY
     58 . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
     59 . I @STK@(0)>1  D  ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
     60 . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
     61 Q
     62 ;
    6363XNAME(ISTR)     ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
    64           ;  </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
    65           ; ISTR IS PASSED BY VALUE
    66           N CUR,TMP
    67           I ISTR?.E1"<".E  D  ; STRIP OFF LEFT BRACKET
    68           . S TMP=$P(ISTR,"<",2)
    69           I TMP?1"/".E  D  ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
    70           . S TMP=$P(TMP,"/",2)
    71           S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
    72           ; W "CUR= ",CUR,!
    73           I CUR?.1"_"1.A1" ".E  D  ; CONTAINS A BLANK IE NAME ID=TEST>
    74            . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
    75           ; W "CUR2= ",CUR,!
    76           Q CUR
    77           ;
     64 ;  </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
     65 ; ISTR IS PASSED BY VALUE
     66 N CUR,TMP
     67 I ISTR?.E1"<".E  D  ; STRIP OFF LEFT BRACKET
     68 . S TMP=$P(ISTR,"<",2)
     69 I TMP?1"/".E  D  ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
     70 . S TMP=$P(TMP,"/",2)
     71 S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
     72 ; W "CUR= ",CUR,!
     73 I CUR?.1"_"1.A1" ".E  D  ; CONTAINS A BLANK IE NAME ID=TEST>
     74 . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
     75 ; W "CUR2= ",CUR,!
     76 Q CUR
     77 ;
    7878INDEX(ZXML)     ; parse the XML in ZXML and produce an XPATH index
    79           ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE
    80           ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
    81           ; XML SECTION
    82           ; ZXML IS PASSED BY NAME
    83           N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND
    84           N GPLSTK ; LEAVE OUT FOR DEBUGGING
    85           I '$D(@ZXML@(0))  D  ; NO XML PASSED
    86           . W "ERROR IN XML FILE",!
    87           S GPLSTK(0)=0 ; INITIALIZE STACK
    88           F I=1:1:@ZXML@(0)  D  ; PROCESS THE ENTIRE ARRAY
    89           . S LINE=@ZXML@(I)
    90           . ;W LINE,!
    91           . S FOUND=0  ; INTIALIZED FOUND FLAG
    92           . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
    93           . I FOUND'=1  D
    94           . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E)  D
    95           . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
    96           . . . ; ON THE SAME LINE
    97           . . . ; W "FOUND ",LINE,!
    98           . . . S FOUND=1  ; SET FOUND FLAG
    99           . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    100           . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
    101           . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
    102           . . . ; W "MDX=",MDX,!
    103           . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
    104           . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    105           . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
    106           . . . . S @ZXML@(MDX)=I_"^"_I  ; ADD INDEX ENTRY-FIRST AND LAST
    107           . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
    108           . I FOUND'=1  D  ; THE LINE DOESN'T CONTAIN THE START AND END
    109           . . I LINE?.E1"</"1.E  D  ; LINE CONTAINS END OF A SECTION
    110           . . . ; W "FOUND ",LINE,!
    111           . . . S FOUND=1  ; SET FOUND FLAG
    112           . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    113           . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
    114           . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    115           . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
    116           . . . I TMP'=CUR  D  ; MALFORMED XML, END MUST MATCH START
    117           . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
    118           . . . . D PARY("GPLSTK") ; PRINT OUT THE STACK FOR DEBUGING
    119           . . . . Q
    120           . I FOUND'=1  D  ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
    121           . . I (LINE?.E1"<"1.E)&(LINE'["?>")  D  ; BEGINNING OF A SECTION
    122           . . . ; W "FOUND ",LINE,!
    123           . . . S FOUND=1  ; SET FOUND FLAG
    124           . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    125           . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
    126           . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
    127           . . . ; W "MDX=",MDX,!
    128           . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
    129           . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    130           . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
    131           . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
    132           S @ZXML@("INDEXED")=""
    133           S @ZXML@("//")="1^"_@ZXML@(0) ; ROOT XPATH
    134           Q
    135           ;
     79 ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE
     80 ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
     81 ; XML SECTION
     82 ; ZXML IS PASSED BY NAME
     83 N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND
     84 N GPLSTK ; LEAVE OUT FOR DEBUGGING
     85 I '$D(@ZXML@(0))  D  ; NO XML PASSED
     86 . W "ERROR IN XML FILE",!
     87 S GPLSTK(0)=0 ; INITIALIZE STACK
     88 F I=1:1:@ZXML@(0)  D  ; PROCESS THE ENTIRE ARRAY
     89 . S LINE=@ZXML@(I)
     90 . ;W LINE,!
     91 . S FOUND=0  ; INTIALIZED FOUND FLAG
     92 . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
     93 . I FOUND'=1  D
     94 . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E)  D
     95 . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
     96 . . . ; ON THE SAME LINE
     97 . . . ; W "FOUND ",LINE,!
     98 . . . S FOUND=1  ; SET FOUND FLAG
     99 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     100 . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
     101 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
     102 . . . ; W "MDX=",MDX,!
     103 . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
     104 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     105 . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
     106 . . . . S @ZXML@(MDX)=I_"^"_I  ; ADD INDEX ENTRY-FIRST AND LAST
     107 . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
     108 . I FOUND'=1  D  ; THE LINE DOESN'T CONTAIN THE START AND END
     109 . . I LINE?.E1"</"1.E  D  ; LINE CONTAINS END OF A SECTION
     110 . . . ; W "FOUND ",LINE,!
     111 . . . S FOUND=1  ; SET FOUND FLAG
     112 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     113 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
     114 . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     115 . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
     116 . . . I TMP'=CUR  D  ; MALFORMED XML, END MUST MATCH START
     117 . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
     118 . . . . D PARY("GPLSTK") ; PRINT OUT THE STACK FOR DEBUGING
     119 . . . . Q
     120 . I FOUND'=1  D  ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
     121 . . I (LINE?.E1"<"1.E)&(LINE'["?>")  D  ; BEGINNING OF A SECTION
     122 . . . ; W "FOUND ",LINE,!
     123 . . . S FOUND=1  ; SET FOUND FLAG
     124 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     125 . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
     126 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
     127 . . . ; W "MDX=",MDX,!
     128 . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
     129 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     130 . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
     131 . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
     132 S @ZXML@("INDEXED")=""
     133 S @ZXML@("//")="1^"_@ZXML@(0) ; ROOT XPATH
     134 Q
     135 ;
    136136QUERY(IARY,XPATH,OARY)  ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
    137          ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
    138          ; IARY AND OARY ARE PASSED BY NAME
    139          I '$D(@IARY@("INDEXED"))  D  ; INDEX IS NOT PRESENT IN IARY
    140          . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
    141          N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
    142          N TMP,I,J,QXPATH
    143          S FIRST=1
    144          S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
    145          I XPATH'="//" D  ; NOT A ROOT QUERY
    146          . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
    147          . S FIRST=$P(TMP,"^",1)
    148          . S LAST=$P(TMP,"^",2)
    149          K @OARY
    150          S @OARY@(0)=+LAST-FIRST+1
    151          S J=1
    152          FOR I=FIRST:1:LAST  D
    153          . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
    154          . S J=J+1
    155          ; ZWR OARY
    156          Q
    157          ;
     137 ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
     138 ; IARY AND OARY ARE PASSED BY NAME
     139 I '$D(@IARY@("INDEXED"))  D  ; INDEX IS NOT PRESENT IN IARY
     140 . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
     141 N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
     142 N TMP,I,J,QXPATH
     143 S FIRST=1
     144 S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
     145 I XPATH'="//" D  ; NOT A ROOT QUERY
     146 . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
     147 . S FIRST=$P(TMP,"^",1)
     148 . S LAST=$P(TMP,"^",2)
     149 K @OARY
     150 S @OARY@(0)=+LAST-FIRST+1
     151 S J=1
     152 FOR I=FIRST:1:LAST  D
     153 . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
     154 . S J=J+1
     155 ; ZWR OARY
     156 Q
     157 ;
    158158XF(IDX,XPATH)   ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
    159          ; INDEX WITH TWO PIECES START^FINISH
    160          ; IDX IS PASSED BY NAME
    161          Q $P(@IDX@(XPATH),"^",1)
    162          ;
     159 ; INDEX WITH TWO PIECES START^FINISH
     160 ; IDX IS PASSED BY NAME
     161 Q $P(@IDX@(XPATH),"^",1)
     162 ;
    163163XL(IDX,XPATH)   ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
    164          ; INDEX WITH TWO PIECES START^FINISH
    165          ; IDX IS PASSED BY NAME
    166          Q $P(@IDX@(XPATH),"^",2)
    167          ;
     164 ; INDEX WITH TWO PIECES START^FINISH
     165 ; IDX IS PASSED BY NAME
     166 Q $P(@IDX@(XPATH),"^",2)
     167 ;
    168168START(ISTR)     ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
    169          ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    170          ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
    171          Q $P(ISTR,";",2)
    172          ;
     169 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     170 ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
     171 Q $P(ISTR,";",2)
     172 ;
    173173FINISH(ISTR)    ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
    174          ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    175          Q $P(ISTR,";",3)
    176          ;
     174 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     175 Q $P(ISTR,";",3)
     176 ;
    177177ARRAY(ISTR)     ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
    178          ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    179          Q $P(ISTR,";",1)
    180          ;
     178 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     179 Q $P(ISTR,";",1)
     180 ;
    181181BUILD(BLIST,BDEST)      ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
    182          ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
    183          ; DEST IS CLEARED TO START
    184          ; USES PUSH TO DO THE COPY
    185          N I
    186          K @BDEST
    187          F I=1:1:@BLIST@(0) D  ; FOR EACH INSTRUCTION IN BLIST
    188          . N J,ATMP
    189          . S ATMP=$$ARRAY(@BLIST@(I))
    190          . I DEBUG W "ATMP=",ATMP,!
    191          . I DEBUG W @BLIST@(I),!
    192          . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D  ;
    193          . . ; FOR EACH LINE IN THIS INSTR
    194          . . I DEBUG W "BDEST= ",BDEST,!
    195          . . I DEBUG W "ATMP= ",@ATMP@(J),!
    196          . . D PUSH(BDEST,@ATMP@(J))
    197          Q
    198          ;
     182 ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
     183 ; DEST IS CLEARED TO START
     184 ; USES PUSH TO DO THE COPY
     185 N I
     186 K @BDEST
     187 F I=1:1:@BLIST@(0) D  ; FOR EACH INSTRUCTION IN BLIST
     188 . N J,ATMP
     189 . S ATMP=$$ARRAY(@BLIST@(I))
     190 . I DEBUG W "ATMP=",ATMP,!
     191 . I DEBUG W @BLIST@(I),!
     192 . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D  ;
     193 . . ; FOR EACH LINE IN THIS INSTR
     194 . . I DEBUG W "BDEST= ",BDEST,!
     195 . . I DEBUG W "ATMP= ",@ATMP@(J),!
     196 . . D PUSH(BDEST,@ATMP@(J))
     197 Q
     198 ;
    199199QUEUE(BLST,ARRAY,FIRST,LAST)    ; ADD AN ENTRY TO A BLIST
    200          ;
    201          I DEBUG W "QUEUEING ",BLST,!
    202          D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
    203          Q
    204          ;
     200 ;
     201 I DEBUG W "QUEUEING ",BLST,!
     202 D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
     203 Q
     204 ;
    205205CP(CPSRC,CPDEST)        ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
    206          ; KILLS CPDEST FIRST
    207          N CPINSTR
    208          I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,!
    209          I @CPSRC@(0)<1 D  ; BAD LENGTH
    210          . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
    211          . Q
    212          ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
    213          D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
    214          D BUILD("CPINSTR",CPDEST)
    215          Q
    216          ;
     206 ; KILLS CPDEST FIRST
     207 N CPINSTR
     208 I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,!
     209 I @CPSRC@(0)<1 D  ; BAD LENGTH
     210 . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
     211 . Q
     212 ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
     213 D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
     214 D BUILD("CPINSTR",CPDEST)
     215 Q
     216 ;
    217217QOPEN(QOBLIST,QOXML,QOXPATH)    ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
    218          ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
    219          ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
    220          ; USED TO INSERT CHILDREN NODES
    221          I @QOXML@(0)<1 D  ; MALFORMED XML
    222          . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
    223          . Q
    224          I DEBUG W "DOING QOPEN",!
    225          N S1,E1,QOT,QOTMP
    226          S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
    227          I $D(QOXPATH) D  ; XPATH PROVIDED
    228          . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
    229          . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
    230          I '$D(QOXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
    231          . S E1=@QOXML@(0)-1
    232          D QUEUE(QOBLIST,QOXML,S1,E1)
    233          ; S QOTMP=QOXML_"^"_S1_"^"_E1
    234          ; D PUSH(QOBLIST,QOTMP)
    235          Q
    236          ;
     218 ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
     219 ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
     220 ; USED TO INSERT CHILDREN NODES
     221 I @QOXML@(0)<1 D  ; MALFORMED XML
     222 . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
     223 . Q
     224 I DEBUG W "DOING QOPEN",!
     225 N S1,E1,QOT,QOTMP
     226 S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
     227 I $D(QOXPATH) D  ; XPATH PROVIDED
     228 . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
     229 . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
     230 I '$D(QOXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
     231 . S E1=@QOXML@(0)-1
     232 D QUEUE(QOBLIST,QOXML,S1,E1)
     233 ; S QOTMP=QOXML_"^"_S1_"^"_E1
     234 ; D PUSH(QOBLIST,QOTMP)
     235 Q
     236 ;
    237237QCLOSE(QCBLIST,QCXML,QCXPATH)   ; CLOSE XML AFTER A QOPEN
    238          ; ADDS THE LIST LINE OF QCXML TO QCBLIST
    239          ; USED TO FINISH INSERTING CHILDERN NODES
    240          ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
    241          ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
    242          I @QCXML@(0)<1 D  ; MALFORMED XML
    243          . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
    244          I DEBUG W "GOING TO CLOSE",!
    245          N S1,E1,QCT,QCTMP
    246          S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
    247          I $D(QCXPATH) D  ; XPATH PROVIDED
    248          . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
    249          . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
    250          I '$D(QCXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
    251          . S S1=@QCXML@(0)
    252          D QUEUE(QCBLIST,QCXML,S1,E1)
    253          ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
    254          Q
    255          ;
     238 ; ADDS THE LIST LINE OF QCXML TO QCBLIST
     239 ; USED TO FINISH INSERTING CHILDERN NODES
     240 ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
     241 ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
     242 I @QCXML@(0)<1 D  ; MALFORMED XML
     243 . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
     244 I DEBUG W "GOING TO CLOSE",!
     245 N S1,E1,QCT,QCTMP
     246 S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
     247 I $D(QCXPATH) D  ; XPATH PROVIDED
     248 . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
     249 . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
     250 I '$D(QCXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
     251 . S S1=@QCXML@(0)
     252 D QUEUE(QCBLIST,QCXML,S1,E1)
     253 ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
     254 Q
     255 ;
    256256INSERT(INSXML,INSNEW,INSXPATH)  ; INSERT INSNEW INTO INSXML AT THE
    257          ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
    258          ; OMITTED, INSERTION WILL BE AT THE ROOT
    259          ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
    260          ; XML AT THE END OF THE XPATH POINT
    261          ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
    262          N INSBLD,INSTMP
    263          I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
    264          I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
    265          I '$D(@INSXML@(0)) D  ; INSERT INTO AN EMPTY ARRAY
    266          . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
    267          I $D(@INSXML@(0)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
    268          . I $D(INSXPATH) D  ; XPATH PROVIDED
    269          . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
    270          . . I DEBUG D PARY^GPLXPATH("INSBLD")
    271          . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
    272          . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
    273          . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
    274          . I $D(INSXPATH) D  ; XPATH PROVIDED
    275          . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
    276          . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
    277          . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
    278          . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
    279          . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
    280          Q
    281          ;
     257 ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
     258 ; OMITTED, INSERTION WILL BE AT THE ROOT
     259 ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
     260 ; XML AT THE END OF THE XPATH POINT
     261 ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
     262 N INSBLD,INSTMP
     263 I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
     264 I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
     265 I '$D(@INSXML@(0)) D  ; INSERT INTO AN EMPTY ARRAY
     266 . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
     267 I $D(@INSXML@(0)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
     268 . I $D(INSXPATH) D  ; XPATH PROVIDED
     269 . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
     270 . . I DEBUG D PARY^GPLXPATH("INSBLD")
     271 . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
     272 . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
     273 . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
     274 . I $D(INSXPATH) D  ; XPATH PROVIDED
     275 . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
     276 . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
     277 . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
     278 . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
     279 . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
     280 Q
     281 ;
    282282INSINNER(INNXML,INNNEW,INNXPATH)        ; INSERT THE INNER XML OF INNNEW
    283          ; INTO INNXML AT THE INNXPATH XPATH POINT
    284          ;
    285          N INNBLD,UXPATH
    286          N INNTBUF
    287          S INNTBUF=$NA(^TMP($J,"INNTBUF"))
    288          I '$D(INNXPATH) D  ; XPATH NOT PASSED
    289          . S UXPATH="//" ; USE ROOT XPATH
    290          I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
    291          I '$D(@INNXML@(0)) D  ; INNXML IS EMPTY
    292          . D QUEUE^GPLXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
    293          . D BUILD("INNBLD",INNXML)
    294          I @INNXML@(0)>0  D  ; NOT EMPTY
    295          . D QOPEN("INNBLD",INNXML,UXPATH) ;
    296          . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
    297          . D QCLOSE("INNBLD",INNXML,UXPATH)
    298          . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
    299          . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
    300          Q
    301          ;
     283 ; INTO INNXML AT THE INNXPATH XPATH POINT
     284 ;
     285 N INNBLD,UXPATH
     286 N INNTBUF
     287 S INNTBUF=$NA(^TMP($J,"INNTBUF"))
     288 I '$D(INNXPATH) D  ; XPATH NOT PASSED
     289 . S UXPATH="//" ; USE ROOT XPATH
     290 I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
     291 I '$D(@INNXML@(0)) D  ; INNXML IS EMPTY
     292 . D QUEUE^GPLXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
     293 . D BUILD("INNBLD",INNXML)
     294 I @INNXML@(0)>0  D  ; NOT EMPTY
     295 . D QOPEN("INNBLD",INNXML,UXPATH) ;
     296 . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
     297 . D QCLOSE("INNBLD",INNXML,UXPATH)
     298 . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
     299 . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
     300 Q
     301 ;
    302302INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST
    303         ; BUT XDEST AN XNEW ARE PASSED BY NAME
    304         N XBLD,XTMP
    305         D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT
    306         D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST
    307         D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION
    308         D BUILD("XBLD","XTMP") ; BUILD THE RESULT
    309         D CP("XTMP",XDEST) ; COPY TO THE DESTINATION
    310         I DEBUG D PARY("XDEST")
    311         Q
    312         ;
     303 ; BUT XDEST AN XNEW ARE PASSED BY NAME
     304 N XBLD,XTMP
     305 D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT
     306 D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST
     307 D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION
     308 D BUILD("XBLD","XTMP") ; BUILD THE RESULT
     309 D CP("XTMP",XDEST) ; COPY TO THE DESTINATION
     310 I DEBUG D PARY("XDEST")
     311 Q
     312 ;
    313313REPLACE(REXML,RENEW,REXPATH)    ; REPLACE THE XML AT THE XPATH POINT
    314          ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
    315          ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
    316          ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
    317          N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
    318          S OLD=$NA(^TMP($J,"REPLACE_OLD"))
    319          D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
    320          S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
    321          S XFIRST=$P(XNODE,"^",1)
    322          S XLAST=$P(XNODE,"^",2)
    323          I RENEW="" D  ; WE ARE DELETING A SECTION, MUST SAVE THE TAG
    324          . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
    325          . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
    326          I RENEW'="" D  ; NEW XML IS NOT NULL
    327          . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
    328          . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
    329          . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
    330          I DEBUG W "REPLACE PREBUILD",!
    331          I DEBUG D PARY("REBLD")
    332          D BUILD("REBLD","RTMP")
    333          K @REXML ; KILL WHAT WAS THERE
    334          D CP("RTMP",REXML) ; COPY IN THE RESULT
    335          Q
    336          ;
     314 ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
     315 ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
     316 ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
     317 N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
     318 S OLD=$NA(^TMP($J,"REPLACE_OLD"))
     319 D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
     320 S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
     321 S XFIRST=$P(XNODE,"^",1)
     322 S XLAST=$P(XNODE,"^",2)
     323 I RENEW="" D  ; WE ARE DELETING A SECTION, MUST SAVE THE TAG
     324 . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
     325 . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
     326 I RENEW'="" D  ; NEW XML IS NOT NULL
     327 . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE
     328 . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
     329 . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST
     330 I DEBUG W "REPLACE PREBUILD",!
     331 I DEBUG D PARY("REBLD")
     332 D BUILD("REBLD","RTMP")
     333 K @REXML ; KILL WHAT WAS THERE
     334 D CP("RTMP",REXML) ; COPY IN THE RESULT
     335 Q
     336 ;
    337337MISSING(IXML,OARY)      ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
    338          ; W "Reporting on the missing",!
    339          ; W OARY
    340          I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
    341          N I
    342          S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
    343          F I=1:1:@IXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
    344          . I @IXML@(I)?.E1"@@".E D  ; MISSING VARIABLE HERE
    345          . . D PUSH^GPLXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
    346          . . Q
    347          Q
    348          ;
     338 ; W "Reporting on the missing",!
     339 ; W OARY
     340 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
     341 N I
     342 S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
     343 F I=1:1:@IXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
     344 . I @IXML@(I)?.E1"@@".E D  ; MISSING VARIABLE HERE
     345 . . D PUSH^GPLXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
     346 . . Q
     347 Q
     348 ;
    349349MAP(IXML,INARY,OXML)    ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY
    350      ; AND PUT THE RESULTS IN OXML
    351          I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q
    352          I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
    353          N I,J,TNAM,TVAL,TSTR
    354          S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT
    355          F I=1:1:@OXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
    356          . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
    357          . I @OXML@(I)?.E1"@@".E D  ; IS THERE A VARIABLE HERE?
    358          . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS
    359          . . F J=2:2:10  D  Q:$P(@IXML@(I),"@@",J+2)=""  ; QUIT IF NO MORE VARS
    360          . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,!
    361          . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME
    362          . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED
    363          . . . I $D(@INARY@(TNAM))  D  ; IS THE VARIABLE IN THE MAP?
    364          . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
    365          . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER
    366          . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES
    367          . . I DEBUG W TSTR
    368          I DEBUG W "MAPPED",!
    369          Q
    370          ;
     350 ; AND PUT THE RESULTS IN OXML
     351 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q
     352 I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
     353 N I,J,TNAM,TVAL,TSTR
     354 S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT
     355 F I=1:1:@OXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
     356 . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
     357 . I @OXML@(I)?.E1"@@".E D  ; IS THERE A VARIABLE HERE?
     358 . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS
     359 . . F J=2:2:10  D  Q:$P(@IXML@(I),"@@",J+2)=""  ; QUIT IF NO MORE VARS
     360 . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,!
     361 . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME
     362 . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED
     363 . . . I $D(@INARY@(TNAM))  D  ; IS THE VARIABLE IN THE MAP?
     364 . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
     365 . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER
     366 . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES
     367 . . I DEBUG W TSTR
     368 I DEBUG W "MAPPED",!
     369 Q
     370 ;
    371371TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS
    372        ; THEXML IS PASSED BY NAME
    373        N I,J,TMPXML,DEL,FOUND,INTXT
    374        S FOUND=0
    375        S INTXT=0
    376        I DEBUG W "DELETING EMPTY ELEMENTS",!
    377        F I=1:1:(@THEXML@(0)-1) D  ; LOOP THROUGH ENTIRE ARRAY
    378        . S J=@THEXML@(I)
    379        . I J["<text>" D
    380        . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM
    381        . . I DEBUG W "IN HTML SECTION",!
    382        . N JM,JP,JPX ; JMINUS AND JPLUS
    383        . S JM=@THEXML@(I-1) ; LINE BEFORE
    384        . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM
    385        . S JP=@THEXML@(I+1) ; LINE AFTER
    386        . I INTXT=0 D  ; IF NOT IN AN HTML SECTION
    387        . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH
    388        . . I J=JPX D  ; AN EMPTY ELEMENT ON TWO LINES
    389        . . . I DEBUG W I,J,JP,!
    390        . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
    391        . . . S DEL(I)="" ; SET LINE TO DELETE
    392        . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE
    393        . . I J["><" D  ; AN EMPTY ELEMENT ON ONE LINE
    394        . . . I DEBUG W I,J,!
    395        . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
    396        . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED
    397        . . . I JM=JPX D  ;
    398        . . . . I DEBUG W I,JM_J_JPX,!
    399        . . . . S DEL(I-1)=""
    400        . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL
    401        ; . I J'["><" D PUSH("TMPXML",J)
    402        I FOUND D  ; NEED TO DELETE THINGS
    403        . F I=1:1:@THEXML@(0) D  ; COPY ARRAY LEAVING OUT DELELTED LINES
    404        . . I '$D(DEL(I)) D  ; IF THE LINE IS NOT DELETED
    405        . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY
    406        . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY
    407        Q FOUND
    408        ;
     372 ; THEXML IS PASSED BY NAME
     373 N I,J,TMPXML,DEL,FOUND,INTXT
     374 S FOUND=0
     375 S INTXT=0
     376 I DEBUG W "DELETING EMPTY ELEMENTS",!
     377 F I=1:1:(@THEXML@(0)-1) D  ; LOOP THROUGH ENTIRE ARRAY
     378 . S J=@THEXML@(I)
     379 . I J["<text>" D
     380 . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM
     381 . . I DEBUG W "IN HTML SECTION",!
     382 . N JM,JP,JPX ; JMINUS AND JPLUS
     383 . S JM=@THEXML@(I-1) ; LINE BEFORE
     384 . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM
     385 . S JP=@THEXML@(I+1) ; LINE AFTER
     386 . I INTXT=0 D  ; IF NOT IN AN HTML SECTION
     387 . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH
     388 . . I J=JPX D  ; AN EMPTY ELEMENT ON TWO LINES
     389 . . . I DEBUG W I,J,JP,!
     390 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
     391 . . . S DEL(I)="" ; SET LINE TO DELETE
     392 . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE
     393 . . I J["><" D  ; AN EMPTY ELEMENT ON ONE LINE
     394 . . . I DEBUG W I,J,!
     395 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED
     396 . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED
     397 . . . I JM=JPX D  ;
     398 . . . . I DEBUG W I,JM_J_JPX,!
     399 . . . . S DEL(I-1)=""
     400 . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL
     401 ; . I J'["><" D PUSH("TMPXML",J)
     402 I FOUND D  ; NEED TO DELETE THINGS
     403 . F I=1:1:@THEXML@(0) D  ; COPY ARRAY LEAVING OUT DELELTED LINES
     404 . . I '$D(DEL(I)) D  ; IF THE LINE IS NOT DELETED
     405 . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY
     406 . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY
     407 Q FOUND
     408 ;
    409409UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML
    410         ; XSEC IS A SECTION PASSED BY NAME
    411         N XBLD,XTMP
    412         D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML
    413         D BUILD("XBLD","XTMP") ; BUILD THE RESULT
    414         D CP("XTMP",XSEC) ; REPLACE PASSED XML
    415         Q
    416         ;
     410 ; XSEC IS A SECTION PASSED BY NAME
     411 N XBLD,XTMP
     412 D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML
     413 D BUILD("XBLD","XTMP") ; BUILD THE RESULT
     414 D CP("XTMP",XSEC) ; REPLACE PASSED XML
     415 Q
     416 ;
    417417PARY(GLO)       ;PRINT AN ARRAY
    418         N I
    419         F I=1:1:@GLO@(0) W I_" "_@GLO@(I),!
    420         Q
    421         ;
     418 N I
     419 F I=1:1:@GLO@(0) W I_" "_@GLO@(I),!
     420 Q
     421 ;
    422422TEST     ; Run all the test cases
    423         D TESTALL^GPLUNIT("GPLXPAT0")
    424         Q
    425         ;
     423 D TESTALL^GPLUNIT("GPLXPAT0")
     424 Q
     425 ;
    426426ZTEST(WHICH)    ; RUN ONE SET OF TESTS
    427           N ZTMP
    428           S DEBUG=1
    429           D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0")
    430           D ZTEST^GPLUNIT(.ZTMP,WHICH)
    431           Q
    432           ;
     427 N ZTMP
     428 S DEBUG=1
     429 D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0")
     430 D ZTEST^GPLUNIT(.ZTMP,WHICH)
     431 Q
     432 ;
    433433TLIST   ; LIST THE TESTS
    434         N ZTMP
    435         D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0")
    436         D TLIST^GPLUNIT(.ZTMP)
    437         Q
    438         ;
     434 N ZTMP
     435 D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0")
     436 D TLIST^GPLUNIT(.ZTMP)
     437 Q
     438 ;
Note: See TracChangeset for help on using the changeset viewer.