Changeset 35 for ccr/trunk/p


Ignore:
Timestamp:
Jul 3, 2008, 10:37:05 AM (16 years ago)
Author:
George Lilly
Message:

fixed CCR unit test cases - TESTGPLCCR for all

Location:
ccr/trunk/p
Files:
2 edited

Legend:

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

    r34 r35  
    1 GPLCCR  ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
    2         ;;0.1;CCDCCR;nopatch;noreleasedate
    3         ;
    4         ; EXPORT A CCR
    5         ;
    6 EXPORT  ; EXPORT ENTRY POINT FOR CCR
    7                ; Select a patient.
    8                S DIC=2,DIC(0)="AEMQ" D ^DIC
    9                I Y<1 Q ; EXIT
    10                S DFN=$P(Y,U,1) ; SET THE PATIENT
    11                N CCRGLO
    12                D CCRRPC(.CCRGLO,DFN,"CCR","","","")
    13                S OARY=$NA(^TMP($J,DFN,"CCR",1))
    14                S ONAM="PAT_"_DFN_"_CCR_V1.xml"
    15                S ODIR="/home/glilly/CCROUT"
    16                ;S ODIR="/home/cedwards/"
    17                D OUTPUT^GPLXPATH(OARY,ONAM,ODIR)
    18                Q
    19                ;
    20 CCRRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY)  ; RPC ENTRY POINT FOR CCR OUTPUT
    21                ; CCRGRTN IS RETURN ARRAY PASSED BY NAME
    22                ; DFN IS PATIENT IEN
    23                ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART OF THE
    24                ;        CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
    25                ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL
    26                ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME - NULL MEANS NOW
    27                ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND "TO" VARIABLES
    28                ;    IF NULL WILL DEFAULT TO "FROM" DUZ AND "TO" DFN
    29                S DEBUG=0
    30                S TGLOBAL=$NA(^TMP($J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
    31                S CCRGLO=$NA(^TMP($J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
    32                S ACTGLO=$NA(^TMP($J,DFN,"ACTORS")); GLOBAL FOR ALL ACTORS IN CCR
    33                ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
    34                S CCRGRTN=$NA(^TMP($J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL OF CCR
    35                D LOAD^GPLCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
    36                D CP^GPLXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO THE CCR GLOBAL
    37                ;
    38                ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM THE CCR GLOBAL
    39                ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH PROCESSING ROUTINES
    40                D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body")
    41                D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
    42                D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
    43                I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
    44                ;
    45                D HDRMAP(CCRGLO,DFN,HDRARY) ; MAP HEADER VARIABLES
    46                ;
    47                K ^TMP($J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
    48                S CCRXTAB="^TMP($J,""CCRSTEP"")" ; GLOBAL TO STORE CCR PROCESSING STEPS
    49                D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
    50                N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
    51                F I=1:1:@CCRXTAB@(0)  D  ; PROCESS THE CCR BODY SECTIONS
    52                . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE
    53                . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
    54                . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
    55                . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
    56                . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
    57                . S IXML="INXML"
    58                . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
    59                . ; W OXML,!
    60                . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
    61                . W "RUNNING ",CALL,!
    62                . X CALL
    63                . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
    64                . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")
    65                . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),!
    66                D ACTLST^GPLCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST
    67                Q
    68                ;
    69 INITSTPS(TAB)     ; INITIALIZE CCR PROCESSING STEPS
    70                ; TAB IS PASSED BY NAME
    71                ; W "TAB= ",TAB,!
    72                D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITALS;//ContinuityOfCareRecord/Body/VitalSigns;^TMP($J,DFN,""VITALS"")")
    73                D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP($J,DFN,""PROBLEMS"")")
    74                Q
    75                 ;
    76 HDRMAP(CXML,DFN,IHDR)   ; MAP HEADER VARIABLES: FROM, TO ECT
    77                N VMAP S VMAP=$NA(^TMP($J,DFN,"HEADER"))
    78                ; K @VMAP
    79                I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
    80                . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
    81                . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - ???
    82                . S @VMAP@("ACTORFROM2")="ACTORPROVIDER_"_DUZ ; NEED A BETTER WAY
    83                . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES,
    84                . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
    85                I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
    86                . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
    87                N CTMP
    88                D MAP^GPLXPATH(CXML,VMAP,"CTMP")
    89                D CP^GPLXPATH("CTMP",CXML)
    90                Q
    91                ;
    92 ACTLST(AXML,ACTRTN)     ; RETURN THE ACTOR LIST FOR THE XML IN AXML
    93                ; AXML AND ACTRTN ARE PASSED BY NAME
    94                ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
    95                ; P1= OBJECTID - ACTORPATIENT_2
    96                ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE OR INSTITUTION
    97                ;     OR PERSON(IN PATIENT FILE IE NOK)
    98                ; P3= IEN RECORD NUMBER FOR ACTOR - 2
    99                N I,J,K,L
    100                K @ACTRTN ; CLEAR RETURN ARRAY
    101                F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
    102                . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR ON THIS LINE
    103                . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
    104                . . ;W "<ActorID>=>",J,!
    105                . . S K(J)="" ; HASHING ACTOR TO GET RID OF DUPLICATES
    106                S I="" ; GOING TO $O THROUGH THE HASH
    107                F J=0:0 D  Q:$O(K(I))=""
    108                . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
    109                . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
    110                . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE: PATIENT/PROVIDER
    111                . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
    112                . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
    113                Q
    114                ;
    115 TEST      ; RUN ALL THE TEST CASES
    116              ;D TESTALL^GPLUNIT("GPLCCR")
    117              D ZTEST^GPLCCR("PROBLEMS")
    118              W "TESTING RETURNED FROM PROBLMES",!
    119              D ZTEST^GPLCCR("CCR")
    120              Q
    121              ;
    122 ZTEST(WHICH)    ; RUN ONE SET OF TESTS
    123              N ZTMP
    124              D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
    125              D ZTEST^GPLUNIT(.ZTMP,WHICH)
    126              Q
    127              ;
    128 TLIST   ; LIST THE TESTS
    129              N ZTMP
    130              D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
    131              D TLIST^GPLUNIT(.ZTMP)
    132              Q
    133              ;
    134 ;;><TEST>       
    135 ;;><PROBLEMS>   
    136 ;;>>>K  GPL S GPL=""
    137 ;;>>>D  CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","")
    138 ;;>>?@GPL@(@GPL@(0))="</Problems>"     
    139 ;;><CCR>       
    140 ;;>>>D  ^%ZTER
    141 ;;>>>K  GPL S GPL=""
    142 ;;>>>D  CCRRPC^GPLCCR(.GPL,"2","CCR","","","")
    143 ;;>>?@GPL@(@GPL@(0))="</ContinutiyOfCareRecord>"       
    144 ;;><ACTLST>     
    145 ;;>>>N  TCCR
    146 ;;>>>D  CCRRPC^GPLCCR(.TCCR,"2","CCR","","","")
    147 ;;>>>D  ACTLST^GPLCCR("TCCR","ACTTEST")
    148 ;;></TEST>     
     1GPLCCR  ; CCDCCR/GPL - CCR MAIN PROCESSING; 6/6/08
     2        ;;0.1;CCDCCR;nopatch;noreleasedate
     3        ;
     4        ; EXPORT A CCR
     5        ;
     6EXPORT  ; EXPORT ENTRY POINT FOR CCR
     7               ; Select a patient.
     8               S DIC=2,DIC(0)="AEMQ" D ^DIC
     9               I Y<1 Q ; EXIT
     10               S DFN=$P(Y,U,1) ; SET THE PATIENT
     11               N CCRGLO
     12               D CCRRPC(.CCRGLO,DFN,"CCR","","","")
     13               S OARY=$NA(^TMP($J,DFN,"CCR",1))
     14               S ONAM="PAT_"_DFN_"_CCR_V1.xml"
     15               S ODIR="/home/glilly/CCROUT"
     16               ;S ODIR="/home/cedwards/"
     17               D OUTPUT^GPLXPATH(OARY,ONAM,ODIR)
     18               Q
     19               ;
     20CCRRPC(CCRGRTN,DFN,CCRPART,TIME1,TIME2,HDRARY) ;RPC ENTRY POINT FOR CCR OUTPUT
     21               ; CCRGRTN IS RETURN ARRAY PASSED BY NAME
     22               ; DFN IS PATIENT IEN
     23               ; CCRPART IS "CCR" FOR ENTIRE CCR, OR SECTION NAME FOR A PART
     24               ;   OF THE CCR BODY.. PARTS INCLUDE "PROBLEMS" "VITALS" ETC
     25               ; TIME1 IS STARTING TIME TO INCLUDE - NULL MEANS ALL
     26               ; TIME2 IS ENDING TIME TO INCLUDE TIME IS FILEMAN TIME
     27               ; - NULL MEANS NOW
     28               ; HDRARY IS THE HEADER ARRAY DEFINING THE "FROM" AND
     29               ;    "TO" VARIABLES
     30               ;    IF NULL WILL DEFAULT TO "FROM" DUZ AND "TO" DFN
     31               S DEBUG=0
     32               S TGLOBAL=$NA(^TMP($J,"TEMPLATE")) ; GLOBAL FOR STORING TEMPLATE
     33               S CCRGLO=$NA(^TMP($J,DFN,"CCR")) ; GLOBAL FOR BUILDING THE CCR
     34               S ACTGLO=$NA(^TMP($J,DFN,"ACTORS")); GLOBAL FOR ALL ACTORS
     35               ; TO GET PART OF THE CCR RETURNED, PASS CCRPART="PROBLEMS" ETC
     36               S CCRGRTN=$NA(^TMP($J,DFN,CCRPART)) ; RTN GLO NM OF PART OR ALL
     37               D LOAD^GPLCCR0(TGLOBAL)  ; LOAD THE CCR TEMPLATE
     38               D CP^GPLXPATH(TGLOBAL,CCRGLO) ; COPY THE TEMPLATE TO CCR GLOBAL
     39               ;
     40               ; DELETE THE BODY, ACTORS AND SIGNATURES SECTIONS FROM GLOBAL
     41               ; THESE WILL BE POPULATED AFTER CALLS TO THE XPATH ROUTINES
     42               D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body")
     43               D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors")
     44               D REPLACE^GPLXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures")
     45               I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),!
     46               ;
     47               D HDRMAP(CCRGLO,DFN,HDRARY) ; MAP HEADER VARIABLES
     48               ;
     49               K ^TMP($J,"CCRSTEP") ; KILL GLOBAL PRIOR TO ADDING TO IT
     50               S CCRXTAB="^TMP($J,""CCRSTEP"")" ; GLOBAL TO STORE CCR STEPS
     51               D INITSTPS(CCRXTAB) ; INITIALIZED CCR PROCESSING STEPS
     52               N I,XI,TAG,RTN,CALL,XPATH,IXML,OXML,INXML,CCRBLD
     53               F I=1:1:@CCRXTAB@(0)  D  ; PROCESS THE CCR BODY SECTIONS
     54               . S XI=@CCRXTAB@(I) ; CALL COPONENTS TO PARSE
     55               . S RTN=$P(XI,";",2) ; NAME OF ROUTINE TO CALL
     56               . S TAG=$P(XI,";",1) ; LABEL INSIDE ROUTINE TO CALL
     57               . S XPATH=$P(XI,";",3) ; XPATH TO XML TO PASS TO ROUTINE
     58               . D QUERY^GPLXPATH(TGLOBAL,XPATH,"INXML") ; EXTRACT XML TO PASS
     59               . S IXML="INXML"
     60               . S OXML=$P(XI,";",4) ; ARRAY FOR SECTION VALUES
     61               . ; W OXML,!
     62               . S CALL="D "_TAG_"^"_RTN_"(IXML,DFN,OXML)" ; SETUP THE CALL
     63               . W "RUNNING ",CALL,!
     64               . X CALL
     65               . ; NOW INSERT THE RESULTS IN THE CCR BUFFER
     66               . D INSERT^GPLXPATH(CCRGLO,OXML,"//ContinuityOfCareRecord/Body")
     67               . I DEBUG F GPLI=1:1:@OXML@(0) W @OXML@(GPLI),!
     68               D ACTLST^GPLCCR(CCRGLO,ACTGLO) ; GEN THE ACTOR LIST
     69               Q
     70               ;
     71INITSTPS(TAB)     ; INITIALIZE CCR PROCESSING STEPS
     72               ; TAB IS PASSED BY NAME
     73               ; W "TAB= ",TAB,!
     74               D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITALS;//ContinuityOfCareRecord/Body/VitalSigns;^TMP($J,DFN,""VITALS"")")
     75               D PUSH^GPLXPATH(TAB,"EXTRACT;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP($J,DFN,""PROBLEMS"")")
     76               Q
     77                ;
     78HDRMAP(CXML,DFN,IHDR)   ; MAP HEADER VARIABLES: FROM, TO ECT
     79               N VMAP S VMAP=$NA(^TMP($J,DFN,"HEADER"))
     80               ; K @VMAP
     81               I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
     82               . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
     83               . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - ???
     84               . S @VMAP@("ACTORFROM2")="ACTORPROVIDER_"_DUZ ; NEED BETTER WAY
     85               . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES,
     86               . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
     87               I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
     88               . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
     89               N CTMP
     90               D MAP^GPLXPATH(CXML,VMAP,"CTMP")
     91               D CP^GPLXPATH("CTMP",CXML)
     92               Q
     93               ;
     94ACTLST(AXML,ACTRTN)     ; RETURN THE ACTOR LIST FOR THE XML IN AXML
     95               ; AXML AND ACTRTN ARE PASSED BY NAME
     96               ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
     97               ; P1= OBJECTID - ACTORPATIENT_2
     98               ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
     99               ;     OR INSTITUTION
     100               ;     OR PERSON(IN PATIENT FILE IE NOK)
     101               ; P3= IEN RECORD NUMBER FOR ACTOR - 2
     102               N I,J,K,L
     103               K @ACTRTN ; CLEAR RETURN ARRAY
     104               F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
     105               . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
     106               . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
     107               . . W "<ActorID>=>",J,!
     108               . . I J'="" S K(J)="" ; HASHING ACTOR
     109               . . ;  TO GET RID OF DUPLICATES
     110               S I="" ; GOING TO $O THROUGH THE HASH
     111               F J=0:0 D  Q:$O(K(I))=""
     112               . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
     113               . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
     114               . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
     115               . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
     116               . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
     117               Q
     118               ;
     119TEST      ; RUN ALL THE TEST CASES
     120             D TESTALL^GPLUNIT("GPLCCR")
     121             Q
     122             ;
     123ZTEST(WHICH)    ; RUN ONE SET OF TESTS
     124             N ZTMP
     125             D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
     126             D ZTEST^GPLUNIT(.ZTMP,WHICH)
     127             Q
     128             ;
     129TLIST   ; LIST THE TESTS
     130             N ZTMP
     131             D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
     132             D TLIST^GPLUNIT(.ZTMP)
     133             Q
     134             ;
     135;;><TEST>
     136;;><PROBLEMS>
     137;;>>>K GPL S GPL=""
     138;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","")
     139;;>>?@GPL@(@GPL@(0))["</Problems>"
     140;;><VITALS>
     141;;>>>K GPL S GPL=""
     142;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","")
     143;;>>?@GPL@(@GPL@(0))["</VitalSigns>"
     144;;><CCR>
     145;;>>>K GPL S GPL=""
     146;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","")
     147;;>>?@GPL@(@GPL@(0))["</ContinuityOfCareRecord>"
     148;;><ACTLST>
     149;;>>>K GPL S GPL=""
     150;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","")
     151;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST")
     152;;></TEST>
  • ccr/trunk/p/GPLXPATH.m

    r34 r35  
    1 GPLXPATH        ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
    2                ;;0.2;CCDCCR;nopatch;noreleasedate
    3                W "This is an XML XPATH utility library",!
    4                W !
    5                Q
    6                ;
    7 OUTPUT(OUTARY,OUTNAME,OUTDIR)   ; WRITE AN ARRAY TO A FILE
    8                ;
    9                N Y
    10                S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME)
    11                I Y W "WROTE FILE: ",OUTNAME," TO ",OUTDIR,!
    12                ; $NA(^TMP(14216,"FILE",0)),3,"/home/wvehr3","test.xml")
    13                Q
    14                ;
    15 PUSH(STK,VAL)   ; pushs VAL onto STK and updates STK(0)
    16                ;  VAL IS A STRING AND STK IS PASSED BY NAME
    17                ;
    18                I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE
    19                S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH
    20                S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY
    21                Q
    22                ;
    23 POP(STK,VAL)    ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL
    24                ; VAL AND STK ARE PASSED BY REFERENCE
    25                ;
    26                I @STK@(0)<1 S VAL="",@STK@(0)=0 Q ; IF ARRAY IS EMPTY
    27                I @STK@(0)>0  D
    28                . S VAL=@STK@(@STK@(0))
    29                . K @STK@(@STK@(0))
    30                . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY
    31                Q
    32                ;
    33 MKMDX(STK,RTN)  ; MAKES A MUMPS INDEX FROM THE ARRAY STK
    34                ; RTN IS SET TO //FIRST/SECOND/THIRD" FOR THREE ARRAY ELEMENTS
    35                S RTN=""
    36                N I
    37                ; W "STK= ",STK,!
    38                I @STK@(0)>0  D  ; IF THE ARRAY IS NOT EMPTY
    39                . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
    40                . I @STK@(0)>1  D  ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
    41                . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
    42                Q
    43                ;
    44 XNAME(ISTR)     ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
    45                ;  </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
    46                ; ISTR IS PASSED BY VALUE
    47                N CUR,TMP
    48                I ISTR?.E1"<".E  D  ; STRIP OFF LEFT BRACKET
    49                . S TMP=$P(ISTR,"<",2)
    50                I TMP?1"/".E  D  ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
    51                . S TMP=$P(TMP,"/",2)
    52                S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
    53                ; W "CUR= ",CUR,!
    54                I CUR?.1"_"1.A1" ".E  D  ; CONTAINS A BLANK IE NAME ID=TEST>
    55                 . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
    56                ; W "CUR2= ",CUR,!
    57                Q CUR
    58                ;
    59 INDEX(ZXML)     ; parse the XML in ZXML and produce an XPATH index
    60                ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE
    61                ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
    62                ; XML SECTION
    63                ; ZXML IS PASSED BY NAME
    64                N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND
    65                N GPLSTK ; LEAVE OUT FOR DEBUGGING
    66                I '$D(@ZXML@(0))  D  ; NO XML PASSED
    67                . W "ERROR IN XML FILE",!
    68                S GPLSTK(0)=0 ; INITIALIZE STACK
    69                F I=1:1:@ZXML@(0)  D  ; PROCESS THE ENTIRE ARRAY
    70                . S LINE=@ZXML@(I)
    71                . ;W LINE,!
    72                . S FOUND=0  ; INTIALIZED FOUND FLAG
    73                . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
    74                . I FOUND'=1  D
    75                . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E)  D
    76                . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS ON THE SAME LINE
    77                . . . ; W "FOUND ",LINE,!
    78                . . . S FOUND=1  ; SET FOUND FLAG
    79                . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    80                . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
    81                . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
    82                . . . ; W "MDX=",MDX,!
    83                . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
    84                . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    85                . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, IS NOT A MULTIPLE
    86                . . . . S @ZXML@(MDX)=I_"^"_I  ; ADD INDEX ENTRY-FIRST AND LAST LINE
    87                . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
    88                . I FOUND'=1  D  ; THE LINE DOESN'T CONTAIN THE START AND END OF A SEC
    89                . . I LINE?.E1"</"1.E  D  ; LINE CONTAINS END OF A SECTION
    90                . . . ; W "FOUND ",LINE,!
    91                . . . S FOUND=1  ; SET FOUND FLAG
    92                . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    93                . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
    94                . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    95                . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
    96                . . . I TMP'=CUR  D  ; MALFORMED XML, END MUST MATCH START
    97                . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
    98                . . . . Q
    99                . I FOUND'=1  D  ; THE LINE MIGHT CONTAIN THE BEGINNING OF A SECTION
    100                . . I (LINE?.E1"<"1.E)&(LINE'["?>")  D  ; BEGINNING OF A SECTION
    101                . . . ; W "FOUND ",LINE,!
    102                . . . S FOUND=1  ; SET FOUND FLAG
    103                . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
    104                . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
    105                . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
    106                . . . ; W "MDX=",MDX,!
    107                . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
    108                . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
    109                . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, IS NOT A MULTIPLE
    110                . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
    111                S @ZXML@("INDEXED")=""
    112                S @ZXML@("//")="1^"_@ZXML@(0) ; ROOT XPATH
    113                Q
    114                ;
    115 QUERY(IARY,XPATH,OARY)  ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
    116               ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
    117               ; IARY AND OARY ARE PASSED BY NAME
    118               I '$D(@IARY@("INDEXED"))  D  ; INDEX IS NOT PRESENT IN IARY
    119               . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
    120               N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
    121               N TMP,I,J,QXPATH
    122               S FIRST=1
    123               S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
    124               I XPATH'="//" D  ; NOT A ROOT QUERY
    125               . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
    126               . S FIRST=$P(TMP,"^",1)
    127               . S LAST=$P(TMP,"^",2)
    128               K @OARY
    129               S @OARY@(0)=+LAST-FIRST+1
    130               S J=1
    131               FOR I=FIRST:1:LAST  D
    132               . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
    133               . S J=J+1
    134               ; ZWR OARY
    135               Q
    136               ;
    137 XF(IDX,XPATH)   ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
    138               ; INDEX WITH TWO PIECES START^FINISH
    139               ; IDX IS PASSED BY NAME
    140               Q $P(@IDX@(XPATH),"^",1)
    141               ;
    142 XL(IDX,XPATH)   ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
    143               ; INDEX WITH TWO PIECES START^FINISH
    144               ; IDX IS PASSED BY NAME
    145               Q $P(@IDX@(XPATH),"^",2)
    146               ;
    147 START(ISTR)     ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
    148               ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    149               ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
    150               Q $P(ISTR,";",2)
    151               ;
    152 FINISH(ISTR)    ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
    153               ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    154               Q $P(ISTR,";",3)
    155               ;
    156 ARRAY(ISTR)     ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
    157               ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
    158               Q $P(ISTR,";",1)
    159               ;
    160 BUILD(BLIST,BDEST)      ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
    161               ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
    162               ; DEST IS CLEARED TO START
    163               ; USES PUSH TO DO THE COPY
    164               N I
    165               K @BDEST
    166               F I=1:1:@BLIST@(0) D  ; FOR EACH INSTRUCTION IN BLIST
    167               . N J,ATMP
    168               . S ATMP=$$ARRAY(@BLIST@(I))
    169               . I DEBUG W "ATMP=",ATMP,!
    170               . I DEBUG W @BLIST@(I),!
    171               . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D  ;
    172               . . ; FOR EACH LINE IN THIS INSTR
    173               . . I DEBUG W "BDEST= ",BDEST,!
    174               . . I DEBUG W "ATMP= ",@ATMP@(J),!
    175               . . D PUSH(BDEST,@ATMP@(J))
    176               Q
    177               ;
    178 QUEUE(BLST,ARRAY,FIRST,LAST)    ; ADD AN ENTRY TO A BLIST
    179               ;
    180               I DEBUG W "QUEUEING ",BLST,!
    181               D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
    182               Q
    183               ;
    184 CP(CPSRC,CPDEST)        ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
    185               ; KILLS CPDEST FIRST
    186               N CPINSTR
    187               I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,!
    188               I @CPSRC@(0)<1 D  ; BAD LENGTH
    189               . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
    190               . Q
    191               ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INITIALIZE
    192               D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
    193               D BUILD("CPINSTR",CPDEST)
    194               Q
    195               ;
    196 QOPEN(QOBLIST,QOXML,QOXPATH)    ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
    197               ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
    198               ; QOXPATH IS OPTIONAL - IF PROVIDED, WILL OPEN INSIDE THE XPATH POINT
    199               ; USED TO INSERT CHILDREN NODES
    200               I @QOXML@(0)<1 D  ; MALFORMED XML
    201               . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
    202               . Q
    203               I DEBUG W "DOING QOPEN",!
    204               N S1,E1,QOT,QOTMP
    205               S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
    206               I $D(QOXPATH) D  ; XPATH PROVIDED
    207               . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
    208               . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
    209               I '$D(QOXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
    210               . S E1=@QOXML@(0)-1
    211               D QUEUE(QOBLIST,QOXML,S1,E1)
    212               ; S QOTMP=QOXML_"^"_S1_"^"_E1
    213               ; D PUSH(QOBLIST,QOTMP)
    214               Q
    215               ;
    216 QCLOSE(QCBLIST,QCXML,QCXPATH)   ; CLOSE XML AFTER A QOPEN
    217               ; ADDS THE LIST LINE OF QCXML TO QCBLIST
    218               ; USED TO FINISH INSERTING CHILDERN NODES
    219               ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
    220               ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
    221               I @QCXML@(0)<1 D  ; MALFORMED XML
    222               . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
    223               I DEBUG W "GOING TO CLOSE",!
    224               N S1,E1,QCT,QCTMP
    225               S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
    226               I $D(QCXPATH) D  ; XPATH PROVIDED
    227               . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
    228               . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
    229               I '$D(QCXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
    230               . S S1=@QCXML@(0)
    231               D QUEUE(QCBLIST,QCXML,S1,E1)
    232               ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
    233               Q
    234               ;
    235 INSERT(INSXML,INSNEW,INSXPATH)  ; INSERT INSNEW INTO INSXML AT THE
    236               ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
    237               ; OMITTED, INSERTION WILL BE AT THE ROOT
    238               ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
    239               ; XML AT THE END OF THE XPATH POINT
    240               ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
    241               N INSBLD,INSTMP
    242               I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
    243               I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
    244               I '$D(@INSXML@(0)) D  Q ; INSERT INTO AN EMPTY ARRAY
    245               . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
    246               I $D(@INSXML@(0)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
    247               . I $D(INSXPATH) D  ; XPATH PROVIDED
    248               . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
    249               . . I DEBUG ZWR INSBLD
    250               . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
    251               . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
    252               . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
    253               . I $D(INSXPATH) D  ; XPATH PROVIDED
    254               . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
    255               . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
    256               . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
    257               . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
    258               . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
    259               Q
    260               ;
    261 INSINNER(INNXML,INNNEW,INNXPATH)        ; INSERT THE INNER XML OF INNNEW
    262               ; INTO INNXML AT THE INNXPATH XPATH POINT
    263               ;
    264               N INNBLD,UXPATH
    265               N INNTBUF
    266               S INNTBUF=$NA(^TMP($J,"INNTBUF"))
    267               I '$D(INNXPATH) D  ; XPATH NOT PASSED
    268               . S UXPATH="//" ; USE ROOT XPATH
    269               I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
    270               I '$D(@INNXML@(0)) D  ; INNXML IS EMPTY
    271               . D QUEUE^GPLXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
    272               . D BUILD("INNBLD",INNXML)
    273               I @INNXML@(0)>0  D  ; NOT EMPTY
    274               . D QOPEN("INNBLD",INNXML,UXPATH) ;
    275               . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
    276               . D QCLOSE("INNBLD",INNXML,UXPATH)
    277               . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
    278               . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
    279               Q
    280               ;
    281 REPLACE(REXML,RENEW,REXPATH)    ; REPLACE THE XML AT THE XPATH POINT
    282               ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
    283               ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
    284               ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
    285               N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
    286               S OLD=$NA(^TMP($J,"REPLACE_OLD"))
    287               D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
    288               S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
    289               S XFIRST=$P(XNODE,"^",1)
    290               S XLAST=$P(XNODE,"^",2)
    291               D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
    292               I RENEW'="" D  ; NEW XML IS NOT NULL
    293               . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
    294               D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
    295               I DEBUG W "REPALCE PREBUILD",!
    296               I DEBUG ZWR REBLD
    297               D BUILD("REBLD","RTMP")
    298               K @REXML ; KILL WHAT WAS THERE
    299               D CP("RTMP",REXML) ; COPY IN THE RESULT
    300               Q
    301               ;
    302 MISSING(IXML,OARY)      ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
    303               ; W "Reporting on the missing",!
    304               ; W OARY
    305               I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
    306               N I
    307               S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
    308               F I=1:1:@IXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
    309               . I @IXML@(I)?.E1"@@".E D  ; MISSING VARIABLE HERE
    310               . . D PUSH^GPLXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
    311               . . Q
    312               Q
    313               ;
    314 MAP(IXML,INARY,OXML)    ; SUBSTITUTE @@X@@ VARS IN IXML WITH VALUES IN INARY
    315                ; AND PUT THE RESULTS IN OXML
    316               I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q
    317               I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
    318               N I,TNAM,TVAL
    319               S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT
    320               F I=1:1:@OXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
    321               . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
    322               . I @OXML@(I)?.E1"@@".E D  ; IS THERE A VARIABLE HERE?
    323               . . S TNAM=$P(@OXML@(I),"@@",2) ; EXTRACT THE VARIABLE NAME
    324               . . I $D(@INARY@(TNAM))  D  ; IS THE VARIABLE IN THE MAP?
    325               . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
    326               . . . S @OXML@(I)=$P(@OXML@(I),"@@",1)_TVAL_$P(@OXML@(I),"@@",3) ;MAPIT
    327               W "MAPPED",!
    328               Q
    329               ;
    330 PARY(GLO)       ;PRINT AN ARRAY
    331              N I
    332              F I=1:1:@GLO@(0) W @GLO@(I),!
    333              Q
    334              ;
    335 TEST     ; Run all the test cases
    336              D TESTALL^GPLUNIT("GPLXPATH")
    337              Q
    338              ;
    339 OLDTEST   ; RUN ALL THE TEST CASES
    340                N ZTMP
    341                D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    342                D ZTEST^GPLUNIT(.ZTMP,"ALL")
    343                W "PASSED: ",TPASSED,!
    344                W "FAILED: ",TFAILED,!
    345                W !
    346                ; W "THE TESTS!",!
    347                ; ZWR ZTMP
    348                Q
    349                ;
    350 ZTEST(WHICH)    ; RUN ONE SET OF TESTS
    351                N ZTMP
    352                S DEBUG=1
    353                D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    354                D ZTEST^GPLUNIT(.ZTMP,WHICH)
    355                Q
    356                ;
    357 TLIST   ; LIST THE TESTS
    358              N ZTMP
    359              D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    360              D TLIST^GPLUNIT(.ZTMP)
    361              Q
    362              ;
    363 ;;><TEST>       
    364 ;;><INIT>       
    365 ;;>>>K  GPL S GPL=""
    366 ;;>>>D  PUSH^GPLXPATH("GPL","FIRST")
    367 ;;>>>D  PUSH^GPLXPATH("GPL","SECOND")
    368 ;;>>>D  PUSH^GPLXPATH("GPL","THIRD")
    369 ;;>>>D  PUSH^GPLXPATH("GPL","FOURTH")
    370 ;;>>?GPL(0)=4   
    371 ;;><INITXML>   
    372 ;;>>>K  GXML S GXML=""
    373 ;;>>>D  PUSH^GPLXPATH("GXML","<FIRST>")
    374 ;;>>>D  PUSH^GPLXPATH("GXML","<SECOND>")
    375 ;;>>>D  PUSH^GPLXPATH("GXML","<THIRD>")
    376 ;;>>>D  PUSH^GPLXPATH("GXML","<FOURTH>@@DATA1@@</FOURTH>")
    377 ;;>>>D  PUSH^GPLXPATH("GXML","<FIFTH>")
    378 ;;>>>D  PUSH^GPLXPATH("GXML","@@DATA2@@")
    379 ;;>>>D  PUSH^GPLXPATH("GXML","</FIFTH>")
    380 ;;>>>D  PUSH^GPLXPATH("GXML","<SIXTH ID=""SELF"" />")
    381 ;;>>>D  PUSH^GPLXPATH("GXML","</THIRD>")
    382 ;;>>>D  PUSH^GPLXPATH("GXML","<SECOND>")
    383 ;;>>>D  PUSH^GPLXPATH("GXML","</SECOND>")
    384 ;;>>>D  PUSH^GPLXPATH("GXML","</SECOND>")
    385 ;;>>>D  PUSH^GPLXPATH("GXML","</FIRST>")
    386 ;;><INITXML2>   
    387 ;;>>>K  GXML S GXML=""
    388 ;;>>>D  PUSH^GPLXPATH("GXML","<FIRST>")
    389 ;;>>>D  PUSH^GPLXPATH("GXML","<SECOND>")
    390 ;;>>>D  PUSH^GPLXPATH("GXML","<THIRD>")
    391 ;;>>>D  PUSH^GPLXPATH("GXML","<FOURTH>DATA1</FOURTH>")
    392 ;;>>>D  PUSH^GPLXPATH("GXML","<FOURTH>")
    393 ;;>>>D  PUSH^GPLXPATH("GXML","DATA2")
    394 ;;>>>D  PUSH^GPLXPATH("GXML","</FOURTH>")
    395 ;;>>>D  PUSH^GPLXPATH("GXML","</THIRD>")
    396 ;;>>>D  PUSH^GPLXPATH("GXML","<_SECOND>")
    397 ;;>>>D  PUSH^GPLXPATH("GXML","<FOURTH>DATA3</FOURTH>")
    398 ;;>>>D  PUSH^GPLXPATH("GXML","</_SECOND>")
    399 ;;>>>D  PUSH^GPLXPATH("GXML","</SECOND>")
    400 ;;>>>D  PUSH^GPLXPATH("GXML","</FIRST>")
    401 ;;><PUSHPOP>   
    402 ;;>>>D  ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    403 ;;>>>D  ZTEST^GPLUNIT(.ZTMP,"INIT")
    404 ;;>>?GPL(GPL(0))="FOURTH"       
    405 ;;>>>D  POP^GPLXPATH("GPL",.GX)
    406 ;;>>?GX="FOURTH"       
    407 ;;>>?GPL(GPL(0))="THIRD"       
    408 ;;>>>D  POP^GPLXPATH("GPL",.GX)
    409 ;;>>?GX="THIRD"
    410 ;;>>?GPL(GPL(0))="SECOND"       
    411 ;;><MKMDX>     
    412 ;;>>>D  ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    413 ;;>>>D  ZTEST^GPLUNIT(.ZTMP,"INIT")
    414 ;;>>>S  GX=""
    415 ;;>>>D  MKMDX^GPLXPATH("GPL",.GX)
    416 ;;>>?GX="//FIRST/SECOND/THIRD/FOURTH"   
    417 ;;><XNAME>     
    418 ;;>>?$$XNAME^GPLXPATH("<FOURTH>DATA1</FOURTH>")="FOURTH"       
    419 ;;>>?$$XNAME^GPLXPATH("<SIXTH   ID=""SELF"" />")="SIXTH"
    420 ;;>>?$$XNAME^GPLXPATH("</THIRD>")="THIRD"       
    421 ;;><INDEX>     
    422 ;;>>>D  ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    423 ;;>>>D  ZTEST^GPLUNIT(.ZTMP,"INITXML")
    424 ;;>>>D  INDEX^GPLXPATH("GXML")
    425 ;;>>?GXML("//FIRST/SECOND")="2^12"     
    426 ;;>>?GXML("//FIRST/SECOND/THIRD")="3^9"
    427 ;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7"   
    428 ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4" 
    429 ;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8"   
    430 ;;>>?GXML("//FIRST/SECOND")="2^12"     
    431 ;;>>?GXML("//FIRST")="1^13"     
    432 ;;><INDEX2>     
    433 ;;>>>D  ZTEST^GPLXPATH("INITXML2")
    434 ;;>>>D  INDEX^GPLXPATH("GXML")
    435 ;;>>?GXML("//FIRST/SECOND")="2^12"     
    436 ;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11"     
    437 ;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10"     
    438 ;;>>?GXML("//FIRST/SECOND/THIRD")="3^8"
    439 ;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^7" 
    440 ;;>>?GXML("//FIRST")="1^13"     
    441 ;;><MISSING>   
    442 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    443 ;;>>>S  OUTARY="^TMP($J,""MISSINGTEST"")"
    444 ;;>>>D  MISSING^GPLXPATH("GXML",OUTARY)
    445 ;;>>?@OUTARY@(1)="DATA1"       
    446 ;;>>?@OUTARY@(2)="DATA2"       
    447 ;;><MAP>       
    448 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    449 ;;>>>S  MAPARY="^TMP($J,""MAPVALUES"")"
    450 ;;>>>S  OUTARY="^TMP($J,""MAPTEST"")"
    451 ;;>>>S  @MAPARY@("DATA2")="VALUE2"
    452 ;;>>>D  MAP^GPLXPATH("GXML",MAPARY,OUTARY)
    453 ;;>>?@OUTARY@(6)="VALUE2"       
    454 ;;><QUEUE>     
    455 ;;>>>D  QUEUE^GPLXPATH("BTLIST","GXML",2,3)
    456 ;;>>>D  QUEUE^GPLXPATH("BTLIST","GXML",4,5)
    457 ;;>>?$P(BTLIST(2),";",2)=4     
    458 ;;><BUILD>     
    459 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    460 ;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2")
    461 ;;>>>D  ZTEST^GPLXPATH("QUEUE")
    462 ;;>>>D  BUILD^GPLXPATH("BTLIST","G3")
    463 ;;><CP>
    464 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    465 ;;>>>D  CP^GPLXPATH("GXML","G2")
    466 ;;>>?G2(0)=13   
    467 ;;><QOPEN>     
    468 ;;>>>K  G2,GBL
    469 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    470 ;;>>>D  QOPEN^GPLXPATH("GBL","GXML")
    471 ;;>>?$P(GBL(1),";",3)=12       
    472 ;;>>>D  BUILD^GPLXPATH("GBL","G2")
    473 ;;>>?G2(G2(0))="</SECOND>"     
    474 ;;><QOPEN2>     
    475 ;;>>>K  G2,GBL
    476 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    477 ;;>>>D  QOPEN^GPLXPATH("GBL","GXML","//FIRST/SECOND")
    478 ;;>>?$P(GBL(1),";",3)=11       
    479 ;;>>>D  BUILD^GPLXPATH("GBL","G2")
    480 ;;>>?G2(G2(0))="</SECOND>"     
    481 ;;><QCLOSE>     
    482 ;;>>>K  G2,GBL
    483 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    484 ;;>>>D  QCLOSE^GPLXPATH("GBL","GXML")
    485 ;;>>?$P(GBL(1),";",3)=13       
    486 ;;>>>D  BUILD^GPLXPATH("GBL","G2")
    487 ;;>>?G2(G2(0))="</FIRST>"       
    488 ;;><QCLOSE2>   
    489 ;;>>>K  G2,GBL
    490 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    491 ;;>>>D  QCLOSE^GPLXPATH("GBL","GXML","//FIRST/SECOND/THIRD")
    492 ;;>>?$P(GBL(1),";",3)=13       
    493 ;;>>>D  BUILD^GPLXPATH("GBL","G2")
    494 ;;>>?G2(G2(0))="</FIRST>"       
    495 ;;>>?G2(1)="</THIRD>"   
    496 ;;><INSERT>     
    497 ;;>>>K  G2,GBL,G3,G4
    498 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    499 ;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
    500 ;;>>>D  INSERT^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD")
    501 ;;>>>D  INSERT^GPLXPATH("G3","G2","//")
    502 ;;>>?G2(1)=GXML(9)     
    503 ;;><REPLACE>   
    504 ;;>>>K  G2,GBL,G3
    505 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    506 ;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
    507 ;;>>>D  REPLACE^GPLXPATH("GXML","G2","//FIRST/SECOND")
    508 ;;>>?GXML(3)="<FIFTH>" 
    509 ;;><INSINNER>   
    510 ;;>>>K  GXML,G2,GBL,G3
    511 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    512 ;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2")
    513 ;;>>>D  INSINNER^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD")
    514 ;;>>?GXML(10)="<FIFTH>"
    515 ;;><INSINNER2> 
    516 ;;>>>K  GXML,G2,GBL,G3
    517 ;;>>>D  ZTEST^GPLXPATH("INITXML")
    518 ;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2")
    519 ;;>>>D  INSINNER^GPLXPATH("G2","G2")
    520 ;;>>?G2(8)="<FIFTH>"   
    521 ;;></TEST>     
     1GPLXPATH        ; CCDCCR/GPL - XPATH XML manipulation utilities; 6/1/08
     2               ;;0.2;CCDCCR;nopatch;noreleasedate
     3               W "This is an XML XPATH utility library",!
     4               W !
     5               Q
     6               ;
     7OUTPUT(OUTARY,OUTNAME,OUTDIR)   ; WRITE AN ARRAY TO A FILE
     8               ;
     9               N Y
     10               S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME)
     11               I Y W "WROTE FILE: ",OUTNAME," TO ",OUTDIR,!
     12               ; $NA(^TMP(14216,"FILE",0)),3,"/home/wvehr3","test.xml")
     13               Q
     14               ;
     15PUSH(STK,VAL)   ; pushs VAL onto STK and updates STK(0)
     16               ;  VAL IS A STRING AND STK IS PASSED BY NAME
     17               ;
     18               I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE
     19               S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH
     20               S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY
     21               Q
     22               ;
     23POP(STK,VAL)    ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL
     24               ; VAL AND STK ARE PASSED BY REFERENCE
     25               ;
     26               I @STK@(0)<1 S VAL="",@STK@(0)=0 Q ; IF ARRAY IS EMPTY
     27               I @STK@(0)>0  D
     28               . S VAL=@STK@(@STK@(0))
     29               . K @STK@(@STK@(0))
     30               . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY
     31               Q
     32               ;
     33MKMDX(STK,RTN)  ; MAKES A MUMPS INDEX FROM THE ARRAY STK
     34               ; RTN IS SET TO //FIRST/SECOND/THIRD" FOR THREE ARRAY ELEMENTS
     35               S RTN=""
     36               N I
     37               ; W "STK= ",STK,!
     38               I @STK@(0)>0  D  ; IF THE ARRAY IS NOT EMPTY
     39               . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON
     40               . I @STK@(0)>1  D  ; SUBSEQUENT ELEMENTS NEED A SEMICOLON
     41               . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I)
     42               Q
     43               ;
     44XNAME(ISTR)     ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG
     45               ;  </NAME> AND <NAME ID=XNAME> WILL RETURN NAME
     46               ; ISTR IS PASSED BY VALUE
     47               N CUR,TMP
     48               I ISTR?.E1"<".E  D  ; STRIP OFF LEFT BRACKET
     49               . S TMP=$P(ISTR,"<",2)
     50               I TMP?1"/".E  D  ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME>
     51               . S TMP=$P(TMP,"/",2)
     52               S CUR=$P(TMP,">",1) ; EXTRACT THE NAME
     53               ; W "CUR= ",CUR,!
     54               I CUR?.1"_"1.A1" ".E  D  ; CONTAINS A BLANK IE NAME ID=TEST>
     55                . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER
     56               ; W "CUR2= ",CUR,!
     57               Q CUR
     58               ;
     59INDEX(ZXML)     ; parse the XML in ZXML and produce an XPATH index
     60               ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE
     61               ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE
     62               ; XML SECTION
     63               ; ZXML IS PASSED BY NAME
     64               N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND
     65               N GPLSTK ; LEAVE OUT FOR DEBUGGING
     66               I '$D(@ZXML@(0))  D  ; NO XML PASSED
     67               . W "ERROR IN XML FILE",!
     68               S GPLSTK(0)=0 ; INITIALIZE STACK
     69               F I=1:1:@ZXML@(0)  D  ; PROCESS THE ENTIRE ARRAY
     70               . S LINE=@ZXML@(I)
     71               . ;W LINE,!
     72               . S FOUND=0  ; INTIALIZED FOUND FLAG
     73               . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS
     74               . I FOUND'=1  D
     75               . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E)  D
     76               . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS
     77               . . . ; ON THE SAME LINE
     78               . . . ; W "FOUND ",LINE,!
     79               . . . S FOUND=1  ; SET FOUND FLAG
     80               . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     81               . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
     82               . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
     83               . . . ; W "MDX=",MDX,!
     84               . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
     85               . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     86               . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
     87               . . . . S @ZXML@(MDX)=I_"^"_I  ; ADD INDEX ENTRY-FIRST AND LAST
     88               . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
     89               . I FOUND'=1  D  ; THE LINE DOESN'T CONTAIN THE START AND END
     90               . . I LINE?.E1"</"1.E  D  ; LINE CONTAINS END OF A SECTION
     91               . . . ; W "FOUND ",LINE,!
     92               . . . S FOUND=1  ; SET FOUND FLAG
     93               . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     94               . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
     95               . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     96               . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK
     97               . . . I TMP'=CUR  D  ; MALFORMED XML, END MUST MATCH START
     98               . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,!
     99               . . . . Q
     100               . I FOUND'=1  D  ; THE LINE MIGHT CONTAIN A SECTION BEGINNING
     101               . . I (LINE?.E1"<"1.E)&(LINE'["?>")  D  ; BEGINNING OF A SECTION
     102               . . . ; W "FOUND ",LINE,!
     103               . . . S FOUND=1  ; SET FOUND FLAG
     104               . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME
     105               . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK
     106               . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX
     107               . . . ; W "MDX=",MDX,!
     108               . . . I $D(@ZXML@(MDX))  D  ; IN THE INDEX, IS A MULTIPLE
     109               . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER
     110               . . . I '$D(@ZXML@(MDX))  D  ; NOT IN THE INDEX, NOT A MULTIPLE
     111               . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX
     112               S @ZXML@("INDEXED")=""
     113               S @ZXML@("//")="1^"_@ZXML@(0) ; ROOT XPATH
     114               Q
     115               ;
     116QUERY(IARY,XPATH,OARY)  ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION
     117              ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD"
     118              ; IARY AND OARY ARE PASSED BY NAME
     119              I '$D(@IARY@("INDEXED"))  D  ; INDEX IS NOT PRESENT IN IARY
     120              . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML
     121              N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN
     122              N TMP,I,J,QXPATH
     123              S FIRST=1
     124              S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT
     125              I XPATH'="//" D  ; NOT A ROOT QUERY
     126              . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES
     127              . S FIRST=$P(TMP,"^",1)
     128              . S LAST=$P(TMP,"^",2)
     129              K @OARY
     130              S @OARY@(0)=+LAST-FIRST+1
     131              S J=1
     132              FOR I=FIRST:1:LAST  D
     133              . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY
     134              . S J=J+1
     135              ; ZWR OARY
     136              Q
     137              ;
     138XF(IDX,XPATH)   ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH
     139              ; INDEX WITH TWO PIECES START^FINISH
     140              ; IDX IS PASSED BY NAME
     141              Q $P(@IDX@(XPATH),"^",1)
     142              ;
     143XL(IDX,XPATH)   ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH
     144              ; INDEX WITH TWO PIECES START^FINISH
     145              ; IDX IS PASSED BY NAME
     146              Q $P(@IDX@(XPATH),"^",2)
     147              ;
     148START(ISTR)     ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX
     149              ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     150              ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
     151              Q $P(ISTR,";",2)
     152              ;
     153FINISH(ISTR)    ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX
     154              ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     155              Q $P(ISTR,";",3)
     156              ;
     157ARRAY(ISTR)     ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX
     158              ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     159              Q $P(ISTR,";",1)
     160              ;
     161BUILD(BLIST,BDEST)      ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST
     162              ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST
     163              ; DEST IS CLEARED TO START
     164              ; USES PUSH TO DO THE COPY
     165              N I
     166              K @BDEST
     167              F I=1:1:@BLIST@(0) D  ; FOR EACH INSTRUCTION IN BLIST
     168              . N J,ATMP
     169              . S ATMP=$$ARRAY(@BLIST@(I))
     170              . I DEBUG W "ATMP=",ATMP,!
     171              . I DEBUG W @BLIST@(I),!
     172              . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D  ;
     173              . . ; FOR EACH LINE IN THIS INSTR
     174              . . I DEBUG W "BDEST= ",BDEST,!
     175              . . I DEBUG W "ATMP= ",@ATMP@(J),!
     176              . . D PUSH(BDEST,@ATMP@(J))
     177              Q
     178              ;
     179QUEUE(BLST,ARRAY,FIRST,LAST)    ; ADD AN ENTRY TO A BLIST
     180              ;
     181              I DEBUG W "QUEUEING ",BLST,!
     182              D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
     183              Q
     184              ;
     185CP(CPSRC,CPDEST)        ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME
     186              ; KILLS CPDEST FIRST
     187              N CPINSTR
     188              I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,!
     189              I @CPSRC@(0)<1 D  ; BAD LENGTH
     190              . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,!
     191              . Q
     192              ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT
     193              D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY
     194              D BUILD("CPINSTR",CPDEST)
     195              Q
     196              ;
     197QOPEN(QOBLIST,QOXML,QOXPATH)    ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST
     198              ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD
     199              ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT
     200              ; USED TO INSERT CHILDREN NODES
     201              I @QOXML@(0)<1 D  ; MALFORMED XML
     202              . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,!
     203              . Q
     204              I DEBUG W "DOING QOPEN",!
     205              N S1,E1,QOT,QOTMP
     206              S S1=1 ; OPEN FROM THE BEGINNING OF THE XML
     207              I $D(QOXPATH) D  ; XPATH PROVIDED
     208              . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX
     209              . S E1=$P(@QOXML@(QOXPATH),"^",2)-1
     210              I '$D(QOXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
     211              . S E1=@QOXML@(0)-1
     212              D QUEUE(QOBLIST,QOXML,S1,E1)
     213              ; S QOTMP=QOXML_"^"_S1_"^"_E1
     214              ; D PUSH(QOBLIST,QOTMP)
     215              Q
     216              ;
     217QCLOSE(QCBLIST,QCXML,QCXPATH)   ; CLOSE XML AFTER A QOPEN
     218              ; ADDS THE LIST LINE OF QCXML TO QCBLIST
     219              ; USED TO FINISH INSERTING CHILDERN NODES
     220              ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END
     221              ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO
     222              I @QCXML@(0)<1 D  ; MALFORMED XML
     223              . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,!
     224              I DEBUG W "GOING TO CLOSE",!
     225              N S1,E1,QCT,QCTMP
     226              S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML
     227              I $D(QCXPATH) D  ; XPATH PROVIDED
     228              . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX
     229              . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML
     230              I '$D(QCXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
     231              . S S1=@QCXML@(0)
     232              D QUEUE(QCBLIST,QCXML,S1,E1)
     233              ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1)
     234              Q
     235              ;
     236INSERT(INSXML,INSNEW,INSXPATH)  ; INSERT INSNEW INTO INSXML AT THE
     237              ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS
     238              ; OMITTED, INSERTION WILL BE AT THE ROOT
     239              ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW
     240              ; XML AT THE END OF THE XPATH POINT
     241              ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE
     242              N INSBLD,INSTMP
     243              I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,!
     244              I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),!
     245              I '$D(@INSXML@(0)) D  Q ; INSERT INTO AN EMPTY ARRAY
     246              . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT
     247              I $D(@INSXML@(0)) D  ; IF ORIGINAL ARRAY IS NOT EMPTY
     248              . I $D(INSXPATH) D  ; XPATH PROVIDED
     249              . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE
     250              . . I DEBUG ZWR INSBLD
     251              . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, OPEN AT ROOT
     252              . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH
     253              . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML
     254              . I $D(INSXPATH) D  ; XPATH PROVIDED
     255              . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH
     256              . I '$D(INSXPATH) D  ; NO XPATH PROVIDED, CLOSE AT ROOT
     257              . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH
     258              . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST
     259              . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE
     260              Q
     261              ;
     262INSINNER(INNXML,INNNEW,INNXPATH)        ; INSERT THE INNER XML OF INNNEW
     263              ; INTO INNXML AT THE INNXPATH XPATH POINT
     264              ;
     265              N INNBLD,UXPATH
     266              N INNTBUF
     267              S INNTBUF=$NA(^TMP($J,"INNTBUF"))
     268              I '$D(INNXPATH) D  ; XPATH NOT PASSED
     269              . S UXPATH="//" ; USE ROOT XPATH
     270              I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED
     271              I '$D(@INNXML@(0)) D  ; INNXML IS EMPTY
     272              . D QUEUE^GPLXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER
     273              . D BUILD("INNBLD",INNXML)
     274              I @INNXML@(0)>0  D  ; NOT EMPTY
     275              . D QOPEN("INNBLD",INNXML,UXPATH) ;
     276              . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML
     277              . D QCLOSE("INNBLD",INNXML,UXPATH)
     278              . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER
     279              . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST
     280              Q
     281              ;
     282REPLACE(REXML,RENEW,REXPATH)    ; REPLACE THE XML AT THE XPATH POINT
     283              ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE
     284              ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE
     285              ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD")
     286              N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP
     287              S OLD=$NA(^TMP($J,"REPLACE_OLD"))
     288              D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD
     289              S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS
     290              S XFIRST=$P(XNODE,"^",1)
     291              S XLAST=$P(XNODE,"^",2)
     292              D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE
     293              I RENEW'="" D  ; NEW XML IS NOT NULL
     294              . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW
     295              D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST
     296              I DEBUG W "REPALCE PREBUILD",!
     297              I DEBUG ZWR REBLD
     298              D BUILD("REBLD","RTMP")
     299              K @REXML ; KILL WHAT WAS THERE
     300              D CP("RTMP",REXML) ; COPY IN THE RESULT
     301              Q
     302              ;
     303MISSING(IXML,OARY)      ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY
     304              ; W "Reporting on the missing",!
     305              ; W OARY
     306              I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q
     307              N I
     308              S @OARY@(0)=0 ; INITIALIZED MISSING COUNT
     309              F I=1:1:@IXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
     310              . I @IXML@(I)?.E1"@@".E D  ; MISSING VARIABLE HERE
     311              . . D PUSH^GPLXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY
     312              . . Q
     313              Q
     314              ;
     315MAP(IXML,INARY,OXML)    ; SUBSTITUTE @@X@@ VARS IN IXML WITH VALUES IN INARY
     316               ; AND PUT THE RESULTS IN OXML
     317              I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q
     318              I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q
     319              N I,TNAM,TVAL
     320              S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT
     321              F I=1:1:@OXML@(0)  D   ; LOOP THROUGH WHOLE ARRAY
     322              . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT
     323              . I @OXML@(I)?.E1"@@".E D  ; IS THERE A VARIABLE HERE?
     324              . . S TNAM=$P(@OXML@(I),"@@",2) ; EXTRACT THE VARIABLE NAME
     325              . . I $D(@INARY@(TNAM))  D  ; IS THE VARIABLE IN THE MAP?
     326              . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE
     327              . . . S @OXML@(I)=$P(@OXML@(I),"@@",1)_TVAL_$P(@OXML@(I),"@@",3)
     328              W "MAPPED",!
     329              Q
     330              ;
     331PARY(GLO)       ;PRINT AN ARRAY
     332             N I
     333             F I=1:1:@GLO@(0) W @GLO@(I),!
     334             Q
     335             ;
     336TEST     ; Run all the test cases
     337             D TESTALL^GPLUNIT("GPLXPATH")
     338             Q
     339             ;
     340OLDTEST   ; RUN ALL THE TEST CASES
     341               N ZTMP
     342               D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     343               D ZTEST^GPLUNIT(.ZTMP,"ALL")
     344               W "PASSED: ",TPASSED,!
     345               W "FAILED: ",TFAILED,!
     346               W !
     347               ; W "THE TESTS!",!
     348               ; ZWR ZTMP
     349               Q
     350               ;
     351ZTEST(WHICH)    ; RUN ONE SET OF TESTS
     352               N ZTMP
     353               S DEBUG=1
     354               D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     355               D ZTEST^GPLUNIT(.ZTMP,WHICH)
     356               Q
     357               ;
     358TLIST   ; LIST THE TESTS
     359             N ZTMP
     360             D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     361             D TLIST^GPLUNIT(.ZTMP)
     362             Q
     363             ;
     364;;><TEST>
     365;;><INIT>
     366;;>>>K  GPL S GPL=""
     367;;>>>D  PUSH^GPLXPATH("GPL","FIRST")
     368;;>>>D  PUSH^GPLXPATH("GPL","SECOND")
     369;;>>>D  PUSH^GPLXPATH("GPL","THIRD")
     370;;>>>D  PUSH^GPLXPATH("GPL","FOURTH")
     371;;>>?GPL(0)=4
     372;;><INITXML>
     373;;>>>K  GXML S GXML=""
     374;;>>>D  PUSH^GPLXPATH("GXML","<FIRST>")
     375;;>>>D  PUSH^GPLXPATH("GXML","<SECOND>")
     376;;>>>D  PUSH^GPLXPATH("GXML","<THIRD>")
     377;;>>>D  PUSH^GPLXPATH("GXML","<FOURTH>@@DATA1@@</FOURTH>")
     378;;>>>D  PUSH^GPLXPATH("GXML","<FIFTH>")
     379;;>>>D  PUSH^GPLXPATH("GXML","@@DATA2@@")
     380;;>>>D  PUSH^GPLXPATH("GXML","</FIFTH>")
     381;;>>>D  PUSH^GPLXPATH("GXML","<SIXTH ID=""SELF"" />")
     382;;>>>D  PUSH^GPLXPATH("GXML","</THIRD>")
     383;;>>>D  PUSH^GPLXPATH("GXML","<SECOND>")
     384;;>>>D  PUSH^GPLXPATH("GXML","</SECOND>")
     385;;>>>D  PUSH^GPLXPATH("GXML","</SECOND>")
     386;;>>>D  PUSH^GPLXPATH("GXML","</FIRST>")
     387;;><INITXML2>
     388;;>>>K  GXML S GXML=""
     389;;>>>D  PUSH^GPLXPATH("GXML","<FIRST>")
     390;;>>>D  PUSH^GPLXPATH("GXML","<SECOND>")
     391;;>>>D  PUSH^GPLXPATH("GXML","<THIRD>")
     392;;>>>D  PUSH^GPLXPATH("GXML","<FOURTH>DATA1</FOURTH>")
     393;;>>>D  PUSH^GPLXPATH("GXML","<FOURTH>")
     394;;>>>D  PUSH^GPLXPATH("GXML","DATA2")
     395;;>>>D  PUSH^GPLXPATH("GXML","</FOURTH>")
     396;;>>>D  PUSH^GPLXPATH("GXML","</THIRD>")
     397;;>>>D  PUSH^GPLXPATH("GXML","<_SECOND>")
     398;;>>>D  PUSH^GPLXPATH("GXML","<FOURTH>DATA3</FOURTH>")
     399;;>>>D  PUSH^GPLXPATH("GXML","</_SECOND>")
     400;;>>>D  PUSH^GPLXPATH("GXML","</SECOND>")
     401;;>>>D  PUSH^GPLXPATH("GXML","</FIRST>")
     402;;><PUSHPOP>
     403;;>>>D  ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     404;;>>>D  ZTEST^GPLUNIT(.ZTMP,"INIT")
     405;;>>?GPL(GPL(0))="FOURTH"
     406;;>>>D  POP^GPLXPATH("GPL",.GX)
     407;;>>?GX="FOURTH"
     408;;>>?GPL(GPL(0))="THIRD"
     409;;>>>D  POP^GPLXPATH("GPL",.GX)
     410;;>>?GX="THIRD"
     411;;>>?GPL(GPL(0))="SECOND"
     412;;><MKMDX>
     413;;>>>D  ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     414;;>>>D  ZTEST^GPLUNIT(.ZTMP,"INIT")
     415;;>>>S  GX=""
     416;;>>>D  MKMDX^GPLXPATH("GPL",.GX)
     417;;>>?GX="//FIRST/SECOND/THIRD/FOURTH"
     418;;><XNAME>
     419;;>>?$$XNAME^GPLXPATH("<FOURTH>DATA1</FOURTH>")="FOURTH"
     420;;>>?$$XNAME^GPLXPATH("<SIXTH   ID=""SELF"" />")="SIXTH"
     421;;>>?$$XNAME^GPLXPATH("</THIRD>")="THIRD"
     422;;><INDEX>
     423;;>>>D  ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     424;;>>>D  ZTEST^GPLUNIT(.ZTMP,"INITXML")
     425;;>>>D  INDEX^GPLXPATH("GXML")
     426;;>>?GXML("//FIRST/SECOND")="2^12"
     427;;>>?GXML("//FIRST/SECOND/THIRD")="3^9"
     428;;>>?GXML("//FIRST/SECOND/THIRD/FIFTH")="5^7"
     429;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^4"
     430;;>>?GXML("//FIRST/SECOND/THIRD/SIXTH")="8^8"
     431;;>>?GXML("//FIRST/SECOND")="2^12"
     432;;>>?GXML("//FIRST")="1^13"
     433;;><INDEX2>
     434;;>>>D  ZTEST^GPLXPATH("INITXML2")
     435;;>>>D  INDEX^GPLXPATH("GXML")
     436;;>>?GXML("//FIRST/SECOND")="2^12"
     437;;>>?GXML("//FIRST/SECOND/_SECOND")="9^11"
     438;;>>?GXML("//FIRST/SECOND/_SECOND/FOURTH")="10^10"
     439;;>>?GXML("//FIRST/SECOND/THIRD")="3^8"
     440;;>>?GXML("//FIRST/SECOND/THIRD/FOURTH")="4^7"
     441;;>>?GXML("//FIRST")="1^13"
     442;;><MISSING>
     443;;>>>D  ZTEST^GPLXPATH("INITXML")
     444;;>>>S  OUTARY="^TMP($J,""MISSINGTEST"")"
     445;;>>>D  MISSING^GPLXPATH("GXML",OUTARY)
     446;;>>?@OUTARY@(1)="DATA1"
     447;;>>?@OUTARY@(2)="DATA2"
     448;;><MAP>
     449;;>>>D  ZTEST^GPLXPATH("INITXML")
     450;;>>>S  MAPARY="^TMP($J,""MAPVALUES"")"
     451;;>>>S  OUTARY="^TMP($J,""MAPTEST"")"
     452;;>>>S  @MAPARY@("DATA2")="VALUE2"
     453;;>>>D  MAP^GPLXPATH("GXML",MAPARY,OUTARY)
     454;;>>?@OUTARY@(6)="VALUE2"
     455;;><QUEUE>
     456;;>>>D  QUEUE^GPLXPATH("BTLIST","GXML",2,3)
     457;;>>>D  QUEUE^GPLXPATH("BTLIST","GXML",4,5)
     458;;>>?$P(BTLIST(2),";",2)=4
     459;;><BUILD>
     460;;>>>D  ZTEST^GPLXPATH("INITXML")
     461;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FOURTH","G2")
     462;;>>>D  ZTEST^GPLXPATH("QUEUE")
     463;;>>>D  BUILD^GPLXPATH("BTLIST","G3")
     464;;><CP>
     465;;>>>D  ZTEST^GPLXPATH("INITXML")
     466;;>>>D  CP^GPLXPATH("GXML","G2")
     467;;>>?G2(0)=13
     468;;><QOPEN>
     469;;>>>K  G2,GBL
     470;;>>>D  ZTEST^GPLXPATH("INITXML")
     471;;>>>D  QOPEN^GPLXPATH("GBL","GXML")
     472;;>>?$P(GBL(1),";",3)=12
     473;;>>>D  BUILD^GPLXPATH("GBL","G2")
     474;;>>?G2(G2(0))="</SECOND>"
     475;;><QOPEN2>
     476;;>>>K  G2,GBL
     477;;>>>D  ZTEST^GPLXPATH("INITXML")
     478;;>>>D  QOPEN^GPLXPATH("GBL","GXML","//FIRST/SECOND")
     479;;>>?$P(GBL(1),";",3)=11
     480;;>>>D  BUILD^GPLXPATH("GBL","G2")
     481;;>>?G2(G2(0))="</SECOND>"
     482;;><QCLOSE>
     483;;>>>K  G2,GBL
     484;;>>>D  ZTEST^GPLXPATH("INITXML")
     485;;>>>D  QCLOSE^GPLXPATH("GBL","GXML")
     486;;>>?$P(GBL(1),";",3)=13
     487;;>>>D  BUILD^GPLXPATH("GBL","G2")
     488;;>>?G2(G2(0))="</FIRST>"
     489;;><QCLOSE2>
     490;;>>>K  G2,GBL
     491;;>>>D  ZTEST^GPLXPATH("INITXML")
     492;;>>>D  QCLOSE^GPLXPATH("GBL","GXML","//FIRST/SECOND/THIRD")
     493;;>>?$P(GBL(1),";",3)=13
     494;;>>>D  BUILD^GPLXPATH("GBL","G2")
     495;;>>?G2(G2(0))="</FIRST>"
     496;;>>?G2(1)="</THIRD>"
     497;;><INSERT>
     498;;>>>K  G2,GBL,G3,G4
     499;;>>>D  ZTEST^GPLXPATH("INITXML")
     500;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
     501;;>>>D  INSERT^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD")
     502;;>>>D  INSERT^GPLXPATH("G3","G2","//")
     503;;>>?G2(1)=GXML(9)
     504;;><REPLACE>
     505;;>>>K  G2,GBL,G3
     506;;>>>D  ZTEST^GPLXPATH("INITXML")
     507;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD/FIFTH","G2")
     508;;>>>D  REPLACE^GPLXPATH("GXML","G2","//FIRST/SECOND")
     509;;>>?GXML(3)="<FIFTH>"
     510;;><INSINNER>
     511;;>>>K  GXML,G2,GBL,G3
     512;;>>>D  ZTEST^GPLXPATH("INITXML")
     513;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2")
     514;;>>>D  INSINNER^GPLXPATH("GXML","G2","//FIRST/SECOND/THIRD")
     515;;>>?GXML(10)="<FIFTH>"
     516;;><INSINNER2>
     517;;>>>K  GXML,G2,GBL,G3
     518;;>>>D  ZTEST^GPLXPATH("INITXML")
     519;;>>>D  QUERY^GPLXPATH("GXML","//FIRST/SECOND/THIRD","G2")
     520;;>>>D  INSINNER^GPLXPATH("G2","G2")
     521;;>>?G2(8)="<FIFTH>"
     522;;></TEST>
Note: See TracChangeset for help on using the changeset viewer.