- Timestamp:
- Jul 3, 2008, 10:37:05 AM (16 years ago)
- Location:
- ccr/trunk/p
- Files:
-
- 2 edited
-
GPLCCR.m (modified) (1 diff)
-
GPLXPATH.m (modified) (1 diff)
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> 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 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 ; 71 INITSTPS(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 ; 78 HDRMAP(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 ; 94 ACTLST(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 ; 119 TEST ; RUN ALL THE TEST CASES 120 D TESTALL^GPLUNIT("GPLCCR") 121 Q 122 ; 123 ZTEST(WHICH) ; RUN ONE SET OF TESTS 124 N ZTMP 125 D ZLOAD^GPLUNIT("ZTMP","GPLCCR") 126 D ZTEST^GPLUNIT(.ZTMP,WHICH) 127 Q 128 ; 129 TLIST ; 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> 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 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 ; 116 QUERY(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 ; 138 XF(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 ; 143 XL(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 ; 148 START(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 ; 153 FINISH(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 ; 157 ARRAY(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 ; 161 BUILD(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 ; 179 QUEUE(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 ; 185 CP(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 ; 197 QOPEN(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 ; 217 QCLOSE(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 ; 236 INSERT(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 ; 262 INSINNER(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 ; 282 REPLACE(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 ; 303 MISSING(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 ; 315 MAP(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 ; 331 PARY(GLO) ;PRINT AN ARRAY 332 N I 333 F I=1:1:@GLO@(0) W @GLO@(I),! 334 Q 335 ; 336 TEST ; Run all the test cases 337 D TESTALL^GPLUNIT("GPLXPATH") 338 Q 339 ; 340 OLDTEST ; 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 ; 351 ZTEST(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 ; 358 TLIST ; 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.
