- Timestamp:
- Sep 11, 2008, 4:09:14 PM (16 years ago)
- Location:
- ccr/trunk/p
- Files:
-
- 2 edited
-
CCRUTIL.m (modified) (2 diffs)
-
GPLXPATH.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
ccr/trunk/p/CCRUTIL.m
r122 r149 1 1 CCRUTIL ;CCRCCD/SMH - Various Utilites for generating the CCR/CCD;06/15/08 2 2 ;;0.1;CCRCCD;;Jun 15, 2008; 3 3 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU 4 4 ;General Public License See attached copy of the License. … … 17 17 ;with this program; if not, write to the Free Software Foundation, Inc., 18 18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 19 20 21 22 19 ; 20 W "No Entry at Top!" 21 Q 22 ; 23 23 FMDTOUTC(DATE,FORMAT) ; Convert Fileman Date to UTC Date Format; PUBLIC; Extrinsic 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 24 ; FORMAT is Format of Date. Can be either D (Day) or DT (Date and Time) 25 ; If not passed, or passed incorrectly, it's assumed that it is D. 26 ; FM Date format is "YYYMMDD.HHMMSS" HHMMSS may not be supplied. 27 ; UTC date is formatted as follows: YYYY-MM-DDThh:mm:ss_offsetfromUTC 28 ; UTC, Year, Month, Day, Hours, Minutes, Seconds, Time offset (obtained from Mailman Site Parameters) 29 N UTC,Y,M,D,H,MM,S,OFF 30 S Y=1700+$E(DATE,1,3) 31 S M=$E(DATE,4,5) 32 S D=$E(DATE,6,7) 33 S H=$E(DATE,9,10) 34 I $L(H)=1 S H="0"_H 35 S MM=$E(DATE,11,12) 36 I $L(MM)=1 S MM="0"_MM 37 S S=$E(DATE,13,14) 38 I $L(S)=1 S S="0"_S 39 S OFF=$$TZ^XLFDT ; See Kernel Manual for documentation. 40 ; If H, MM and S are empty, it means that the FM date didn't supply the time. 41 ; In this case, set H, MM and S to "00" 42 ; S:('$L(H)&'$L(MM)&'$L(S)) (H,MM,S)="00" ; IF ONLY SOME ARE MISSING? 43 S:'$L(H) H="00" 44 S:'$L(MM) MM="00" 45 S:'$L(S) S="00" 46 S UTC=Y_"-"_M_"-"_D_"T"_H_":"_MM_$S(S="":":00",1:":"_S)_OFF ; Skip's code to fix hanging colon if no seconds 47 I $L($G(FORMAT)),FORMAT="DT" Q UTC ; Date with time. 48 E Q $P(UTC,"T") 49 ; 50 50 SORTDT(V1,V2,ORDR) ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT 51 ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE 52 ; DATE AND TIME ORDER. DEFAULT IS FORWARD 53 ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT 54 ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER 55 ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER 56 ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC 57 ; BOTH V1 AND V2 ARE PASSED BY REFERENCE 58 N VSRT ; TEMP FOR HASHING DATES 59 N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 60 S ZCNT=0 ; COUNTING NUMBER OF DATES 61 S ZTMP="" ; 62 F ZI=0:0 D Q:$O(V2(ZTMP))="" ; FOR EACH DATE IN THE ARRAY 63 . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT 64 . S ZTMP=$O(V2(ZTMP)) ; NEXT DATE 65 . I $D(V2(ZTMP)) D ; IF THE DATE EXISTS 66 . . S ZP1=$P(V2(ZTMP),".",1) ; THE DATE PIECE 67 . . S ZP2=$P(V2(ZTMP),".",2) ; THE TIME PIECE 68 . . S VSRT(ZP1,ZP2_"00000"_ZCNT)=ZCNT ; HASH ON DATE AND TIME 69 . . ; S VSRT($P(V2(ZTMP),U,4)_"000000"_ZCNT)=ZCNT ; PULL DATE 70 . I DEBUG W "ZTMP=",ZTMP," " 71 S V1(0)=ZCNT ; ARRAYS ARE THE SAME SIZE 72 ; I DEBUG ZWR V2 73 ; I DEBUG ZWR VSRT 74 N ZD,ZT ; DATA AND TIME ITERATORS 75 N ZDONE ; DONE FLAG 76 S (ZD,ZT)="" 77 S ZDONE=0 78 N UORDR ; ORDER TO USE 1=FORWARD -1=REVERSE 79 S UORDR=ORDR ; DIRECTION TO SORT 80 I ORDR="" S UORDR=1 81 N ZZCNT S ZZCNT=0 ; ANOTHER COUNTER 82 F ZI=0:0 D Q:ZDONE ; VISIT THE ARRAY IN DATE ORDER 83 . S ZD=$O(VSRT(ZD),UORDR) ; NEXT DATE 84 . I ZD="" S ZDONE=1 85 . I 'ZDONE D ; MORE DATES 86 . . S ZT="" ; WANT FIRST TIME FOR THIS DATE 87 . . F ZJ=0:0 D Q:$O(VSRT(ZD,ZT),UORDR)="" ; LOOP THROUGH ALL TIMES 88 . . . S ZT=$O(VSRT(ZD,ZT),UORDR) ; NEXT TIME 89 . . . S ZZCNT=ZZCNT+1 ; INCREMENT COUNTER 90 . . . S V1(ZZCNT)=VSRT(ZD,ZT) ; PULL OUT THE INDEX 91 Q ZCNT 92 ; 51 ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE 52 ; DATE AND TIME ORDER. DEFAULT IS FORWARD 53 ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT 54 ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER 55 ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER 56 ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC 57 ; BOTH V1 AND V2 ARE PASSED BY REFERENCE 58 N VSRT ; TEMP FOR HASHING DATES 59 N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 60 S ZCNT=0 ; COUNTING NUMBER OF DATES 61 S ZTMP="" ; 62 F ZI=0:0 D Q:$O(V2(ZTMP))="" ; FOR EACH DATE IN THE ARRAY 63 . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT 64 . S ZTMP=$O(V2(ZTMP)) ; NEXT DATE 65 . I $D(V2(ZTMP)) D ; IF THE DATE EXISTS 66 . . S ZP1=$P(V2(ZTMP),".",1) ; THE DATE PIECE 67 . . S ZP2=$P(V2(ZTMP),".",2) ; THE TIME PIECE 68 . . S VSRT(ZP1,ZP2_"00000"_ZCNT)=ZCNT ; HASH ON DATE AND TIME 69 . . ; S VSRT($P(V2(ZTMP),U,4)_"000000"_ZCNT)=ZCNT ; PULL DATE 70 . I DEBUG W "ZTMP=",ZTMP," " 71 S V1(0)=ZCNT ; ARRAYS ARE THE SAME SIZE 72 ; I DEBUG ZWR V2 73 ; I DEBUG ZWR VSRT 74 N ZD,ZT ; DATA AND TIME ITERATORS 75 N ZDONE ; DONE FLAG 76 S (ZD,ZT)="" 77 S ZDONE=0 78 N UORDR ; ORDER TO USE 1=FORWARD -1=REVERSE 79 S UORDR=ORDR ; DIRECTION TO SORT 80 I ORDR="" S UORDR=1 81 N ZZCNT S ZZCNT=0 ; ANOTHER COUNTER 82 F ZI=0:0 D Q:ZDONE ; VISIT THE ARRAY IN DATE ORDER 83 . S ZD=$O(VSRT(ZD),UORDR) ; NEXT DATE 84 . I ZD="" S ZDONE=1 85 . I 'ZDONE D ; MORE DATES 86 . . S ZT="" ; WANT FIRST TIME FOR THIS DATE 87 . . F ZJ=0:0 D Q:$O(VSRT(ZD,ZT),UORDR)="" ; LOOP THROUGH ALL TIMES 88 . . . S ZT=$O(VSRT(ZD,ZT),UORDR) ; NEXT TIME 89 . . . S ZZCNT=ZZCNT+1 ; INCREMENT COUNTER 90 . . . S V1(ZZCNT)=VSRT(ZD,ZT) ; PULL OUT THE INDEX 91 Q ZCNT 92 ; 93 SORTDT2(V1,V2,ORDR) ; REWRITE TO USE 3 INSTEAD OF 2 LVLS OF INDEX 94 ; AND $Q INSTEAD OF $O 95 ; DATE SORT ARRAY AND RETURN INDEX IN V1 AND COUNT 96 ; AS EXTRINSIC ORDR IS 1 OR -1 FOR FORWARD OR REVERSE 97 ; DATE AND TIME ORDER. DEFAULT IS FORWARD 98 ; V2 IS AN ARRAY OF DATES IN FILEMAN FORMAT 99 ; V1 IS RETURNS INDIRECT INDEXES OF V2 IN REVERSE DATE ORDER 100 ; SO V2(V1(X)) WILL RETURN THE DATES IN DATE/TIME ORDER 101 ; THE COUNT OF THE DATES IS RETURNED AS AN EXTRINSIC 102 ; BOTH V1 AND V2 ARE PASSED BY REFERENCE 103 N VSRT ; TEMP FOR HASHING DATES 104 N ZI,ZJ,ZTMP,ZCNT,ZP1,ZP2 105 S ZCNT=0 ; COUNTING NUMBER OF DATES 106 S ZTMP="" ; 107 F ZI=0:0 D Q:$O(V2(ZTMP))="" ; FOR EACH DATE IN THE ARRAY 108 . S ZCNT=ZCNT+1 ; INCREMENT THE COUNT 109 . S ZTMP=$O(V2(ZTMP)) ; NEXT DATE 110 . I $D(V2(ZTMP)) D ; IF THE DATE EXISTS 111 . . S ZP1=$P(V2(ZTMP),".",1) ; THE DATE PIECE 112 . . S ZP2=$P(V2(ZTMP),".",2) ; THE TIME PIECE 113 . . S VSRT(ZP1,ZP2,ZCNT)=ZCNT ; HASH ON DATE AND TIME 114 . I DEBUG W "ZTMP=",ZTMP," " 115 S V1(0)=ZCNT ; ARRAYS ARE THE SAME SIZE 116 ; I DEBUG ZWR V2 117 ; I DEBUG ZWR VSRT 118 N ZD,ZT ; DATA AND TIME ITERATORS 119 N ZDONE ; DONE FLAG 120 S (ZD,ZT)="" 121 S ZDONE=0 122 N UORDR ; ORDER TO USE 1=FORWARD -1=REVERSE 123 S UORDR=ORDR ; DIRECTION TO SORT 124 I ORDR="" S UORDR=1 125 N ZZCNT S ZZCNT=0 ; ANOTHER COUNTER 126 F ZI=0:0 D Q:ZDONE ; VISIT THE ARRAY IN DATE ORDER 127 . S ZD=$O(VSRT(ZD),UORDR) ; NEXT DATE fix this 128 . I ZD="" S ZDONE=1 129 . I 'ZDONE D ; MORE DATES 130 . . S ZT="" ; WANT FIRST TIME FOR THIS DATE 131 . . F ZJ=0:0 D Q:$O(VSRT(ZD,ZT),UORDR)="" ; LOOP THROUGH ALL TIMES 132 . . . S ZT=$O(VSRT(ZD,ZT),UORDR) ; NEXT TIME 133 . . . S ZZCNT=ZZCNT+1 ; INCREMENT COUNTER 134 . . . S V1(ZZCNT)=VSRT(ZD,ZT) ; PULL OUT THE INDEX 135 Q ZCNT 136 ; -
ccr/trunk/p/GPLXPATH.m
r134 r149 18 18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 19 19 ; 20 21 22 23 20 W "This is an XML XPATH utility library",! 21 W ! 22 Q 23 ; 24 24 OUTPUT(OUTARY,OUTNAME,OUTDIR) ; WRITE AN ARRAY TO A FILE 25 26 27 28 29 30 31 25 ; 26 N Y 27 S Y=$$GTF^%ZISH(OUTARY,$QL(OUTARY),OUTDIR,OUTNAME) 28 I Y Q 1_U_"WROTE FILE: "_OUTNAME_" TO "_OUTDIR 29 I 'Y Q 0_U_"ERROR WRITING FILE"_OUTNAME_" TO "_OUTDIR 30 Q 31 ; 32 32 PUSH(STK,VAL) ; pushs VAL onto STK and updates STK(0) 33 34 35 36 37 38 39 33 ; VAL IS A STRING AND STK IS PASSED BY NAME 34 ; 35 I '$D(@STK@(0)) S @STK@(0)=0 ; IF THE ARRAY IS EMPTY, INITIALIZE 36 S @STK@(0)=@STK@(0)+1 ; INCREMENT ARRAY DEPTH 37 S @STK@(@STK@(0))=VAL ; PUT VAL A THE END OF THE ARRAY 38 Q 39 ; 40 40 POP(STK,VAL) ; POPS THE LAST VALUE OFF THE STK AND RETURNS IT IN VAL 41 42 43 44 45 46 47 48 49 50 51 41 ; VAL AND STK ARE PASSED BY REFERENCE 42 ; 43 I @STK@(0)<1 D ; IF ARRAY IS EMPTY 44 . S VAL="" 45 . S @STK@(0)=0 46 I @STK@(0)>0 D ; 47 . S VAL=@STK@(@STK@(0)) 48 . K @STK@(@STK@(0)) 49 . S @STK@(0)=@STK@(0)-1 ; NEW DEPTH OF THE ARRAY 50 Q 51 ; 52 52 MKMDX(STK,RTN) ; MAKES A MUMPS INDEX FROM THE ARRAY STK 53 54 55 56 57 58 59 60 61 62 53 ; RTN IS SET TO //FIRST/SECOND/THIRD" FOR THREE ARRAY ELEMENTS 54 S RTN="" 55 N I 56 ; W "STK= ",STK,! 57 I @STK@(0)>0 D ; IF THE ARRAY IS NOT EMPTY 58 . S RTN="//"_@STK@(1) ; FIRST ELEMENT NEEDS NO SEMICOLON 59 . I @STK@(0)>1 D ; SUBSEQUENT ELEMENTS NEED A SEMICOLON 60 . . F I=2:1:@STK@(0) S RTN=RTN_"/"_@STK@(I) 61 Q 62 ; 63 63 XNAME(ISTR) ; FUNCTION TO EXTRACT A NAME FROM AN XML FRAG 64 65 66 67 68 69 70 71 72 73 74 75 76 77 64 ; </NAME> AND <NAME ID=XNAME> WILL RETURN NAME 65 ; ISTR IS PASSED BY VALUE 66 N CUR,TMP 67 I ISTR?.E1"<".E D ; STRIP OFF LEFT BRACKET 68 . S TMP=$P(ISTR,"<",2) 69 I TMP?1"/".E D ; ALSO STRIP OFF SLASH IF PRESENT IE </NAME> 70 . S TMP=$P(TMP,"/",2) 71 S CUR=$P(TMP,">",1) ; EXTRACT THE NAME 72 ; W "CUR= ",CUR,! 73 I CUR?.1"_"1.A1" ".E D ; CONTAINS A BLANK IE NAME ID=TEST> 74 . S CUR=$P(CUR," ",1) ; STRIP OUT BLANK AND AFTER 75 ; W "CUR2= ",CUR,! 76 Q CUR 77 ; 78 78 INDEX(ZXML) ; parse the XML in ZXML and produce an XPATH index 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 79 ; ex. ZXML(FIRST,SECOND,THIRD,FOURTH)=FIRSTLINE^LASTLINE 80 ; WHERE FIRSTLINE AND LASTLINE ARE THE BEGINNING AND ENDING OF THE 81 ; XML SECTION 82 ; ZXML IS PASSED BY NAME 83 N I,LINE,FIRST,LAST,CUR,TMP,MDX,FOUND 84 N GPLSTK ; LEAVE OUT FOR DEBUGGING 85 I '$D(@ZXML@(0)) D ; NO XML PASSED 86 . W "ERROR IN XML FILE",! 87 S GPLSTK(0)=0 ; INITIALIZE STACK 88 F I=1:1:@ZXML@(0) D ; PROCESS THE ENTIRE ARRAY 89 . S LINE=@ZXML@(I) 90 . ;W LINE,! 91 . S FOUND=0 ; INTIALIZED FOUND FLAG 92 . I LINE?.E1"<!".E S FOUND=1 ; SKIP OVER COMMENTS 93 . I FOUND'=1 D 94 . . I (LINE?.E1"<"1.E1"</".E)!(LINE?.E1"<"1.E1"/>".E) D 95 . . . ; THIS IS THE CASE THERE SECTION BEGINS AND ENDS 96 . . . ; ON THE SAME LINE 97 . . . ; W "FOUND ",LINE,! 98 . . . S FOUND=1 ; SET FOUND FLAG 99 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 100 . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK 101 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX 102 . . . ; W "MDX=",MDX,! 103 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE 104 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 105 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE 106 . . . . S @ZXML@(MDX)=I_"^"_I ; ADD INDEX ENTRY-FIRST AND LAST 107 . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK 108 . I FOUND'=1 D ; THE LINE DOESN'T CONTAIN THE START AND END 109 . . I LINE?.E1"</"1.E D ; LINE CONTAINS END OF A SECTION 110 . . . ; W "FOUND ",LINE,! 111 . . . S FOUND=1 ; SET FOUND FLAG 112 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 113 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX 114 . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 115 . . . D POP("GPLSTK",.TMP) ; REMOVE FROM STACK 116 . . . I TMP'=CUR D ; MALFORMED XML, END MUST MATCH START 117 . . . . W "MALFORMED XML ",CUR,"LINE "_I_LINE,! 118 . . . . D PARY("GPLSTK") ; PRINT OUT THE STACK FOR DEBUGING 119 . . . . Q 120 . I FOUND'=1 D ; THE LINE MIGHT CONTAIN A SECTION BEGINNING 121 . . I (LINE?.E1"<"1.E)&(LINE'["?>") D ; BEGINNING OF A SECTION 122 . . . ; W "FOUND ",LINE,! 123 . . . S FOUND=1 ; SET FOUND FLAG 124 . . . S CUR=$$XNAME(LINE) ; EXTRACT THE NAME 125 . . . D PUSH("GPLSTK",CUR) ; ADD TO THE STACK 126 . . . D MKMDX("GPLSTK",.MDX) ; GENERATE THE M INDEX 127 . . . ; W "MDX=",MDX,! 128 . . . I $D(@ZXML@(MDX)) D ; IN THE INDEX, IS A MULTIPLE 129 . . . . S $P(@ZXML@(MDX),"^",2)=I ; UPDATE LAST LINE NUMBER 130 . . . I '$D(@ZXML@(MDX)) D ; NOT IN THE INDEX, NOT A MULTIPLE 131 . . . . S @ZXML@(MDX)=I_"^" ; INSERT INTO THE INDEX 132 S @ZXML@("INDEXED")="" 133 S @ZXML@("//")="1^"_@ZXML@(0) ; ROOT XPATH 134 Q 135 ; 136 136 QUERY(IARY,XPATH,OARY) ; RETURNS THE XML ARRAY MATCHING THE XPATH EXPRESSION 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 137 ; XPATH IS OF THE FORM "//FIRST/SECOND/THIRD" 138 ; IARY AND OARY ARE PASSED BY NAME 139 I '$D(@IARY@("INDEXED")) D ; INDEX IS NOT PRESENT IN IARY 140 . D INDEX(IARY) ; GENERATE AN INDEX FOR THE XML 141 N FIRST,LAST ; FIRST AND LAST LINES OF ARRAY TO RETURN 142 N TMP,I,J,QXPATH 143 S FIRST=1 144 S LAST=@IARY@(0) ; FIRST AND LAST DEFAULT TO ROOT 145 I XPATH'="//" D ; NOT A ROOT QUERY 146 . S TMP=@IARY@(XPATH) ; LOOK UP LINE VALUES 147 . S FIRST=$P(TMP,"^",1) 148 . S LAST=$P(TMP,"^",2) 149 K @OARY 150 S @OARY@(0)=+LAST-FIRST+1 151 S J=1 152 FOR I=FIRST:1:LAST D 153 . S @OARY@(J)=@IARY@(I) ; COPY THE LINE TO OARY 154 . S J=J+1 155 ; ZWR OARY 156 Q 157 ; 158 158 XF(IDX,XPATH) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN XPATH 159 160 161 162 159 ; INDEX WITH TWO PIECES START^FINISH 160 ; IDX IS PASSED BY NAME 161 Q $P(@IDX@(XPATH),"^",1) 162 ; 163 163 XL(IDX,XPATH) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN XPATH 164 165 166 167 164 ; INDEX WITH TWO PIECES START^FINISH 165 ; IDX IS PASSED BY NAME 166 Q $P(@IDX@(XPATH),"^",2) 167 ; 168 168 START(ISTR) ; EXTRINSIC TO RETURN THE STARTING LINE FROM AN INDEX 169 170 171 172 169 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 170 ; COMPANION TO FINISH ; IDX IS PASSED BY NAME 171 Q $P(ISTR,";",2) 172 ; 173 173 FINISH(ISTR) ; EXTRINSIC TO RETURN THE LAST LINE FROM AN INDEX 174 175 176 174 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 175 Q $P(ISTR,";",3) 176 ; 177 177 ARRAY(ISTR) ; EXTRINSIC TO RETURN THE ARRAY REFERENCE FROM AN INDEX 178 179 180 178 ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH 179 Q $P(ISTR,";",1) 180 ; 181 181 BUILD(BLIST,BDEST) ; A COPY MACHINE THAT TAKE INSTRUCTIONS IN ARRAY BLIST 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 182 ; WHICH HAVE ARRAY;START;FINISH AND COPIES THEM TO DEST 183 ; DEST IS CLEARED TO START 184 ; USES PUSH TO DO THE COPY 185 N I 186 K @BDEST 187 F I=1:1:@BLIST@(0) D ; FOR EACH INSTRUCTION IN BLIST 188 . N J,ATMP 189 . S ATMP=$$ARRAY(@BLIST@(I)) 190 . I DEBUG W "ATMP=",ATMP,! 191 . I DEBUG W @BLIST@(I),! 192 . F J=$$START(@BLIST@(I)):1:$$FINISH(@BLIST@(I)) D ; 193 . . ; FOR EACH LINE IN THIS INSTR 194 . . I DEBUG W "BDEST= ",BDEST,! 195 . . I DEBUG W "ATMP= ",@ATMP@(J),! 196 . . D PUSH(BDEST,@ATMP@(J)) 197 Q 198 ; 199 199 QUEUE(BLST,ARRAY,FIRST,LAST) ; ADD AN ENTRY TO A BLIST 200 201 202 203 204 200 ; 201 I DEBUG W "QUEUEING ",BLST,! 202 D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST) 203 Q 204 ; 205 205 CP(CPSRC,CPDEST) ; COPIES CPSRC TO CPDEST BOTH PASSED BY NAME 206 207 208 209 210 211 212 213 214 215 216 206 ; KILLS CPDEST FIRST 207 N CPINSTR 208 I DEBUG W "MADE IT TO COPY",CPSRC,CPDEST,! 209 I @CPSRC@(0)<1 D ; BAD LENGTH 210 . W "ERROR IN COPY BAD SOURCE LENGTH: ",CPSRC,! 211 . Q 212 ; I '$D(@CPDEST@(0)) S @CPDEST@(0)=0 ; IF THE DEST IS EMPTY, INIT 213 D QUEUE("CPINSTR",CPSRC,1,@CPSRC@(0)) ; BLIST FOR ENTIRE ARRAY 214 D BUILD("CPINSTR",CPDEST) 215 Q 216 ; 217 217 QOPEN(QOBLIST,QOXML,QOXPATH) ; ADD ALL BUT THE LAST LINE OF QOXML TO QOBLIST 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 218 ; WARNING NEED TO DO QCLOSE FOR SAME XML BEFORE CALLING BUILD 219 ; QOXPATH IS OPTIONAL - WILL OPEN INSIDE THE XPATH POINT 220 ; USED TO INSERT CHILDREN NODES 221 I @QOXML@(0)<1 D ; MALFORMED XML 222 . W "MALFORMED XML PASSED TO QOPEN: ",QOXML,! 223 . Q 224 I DEBUG W "DOING QOPEN",! 225 N S1,E1,QOT,QOTMP 226 S S1=1 ; OPEN FROM THE BEGINNING OF THE XML 227 I $D(QOXPATH) D ; XPATH PROVIDED 228 . D QUERY(QOXML,QOXPATH,"QOT") ; INSURE INDEX 229 . S E1=$P(@QOXML@(QOXPATH),"^",2)-1 230 I '$D(QOXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT 231 . S E1=@QOXML@(0)-1 232 D QUEUE(QOBLIST,QOXML,S1,E1) 233 ; S QOTMP=QOXML_"^"_S1_"^"_E1 234 ; D PUSH(QOBLIST,QOTMP) 235 Q 236 ; 237 237 QCLOSE(QCBLIST,QCXML,QCXPATH) ; CLOSE XML AFTER A QOPEN 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 238 ; ADDS THE LIST LINE OF QCXML TO QCBLIST 239 ; USED TO FINISH INSERTING CHILDERN NODES 240 ; QCXPATH IS OPTIONAL - IF PROVIDED, WILL CLOSE UNTIL THE END 241 ; IF QOPEN WAS CALLED WITH XPATH, QCLOSE SHOULD BE TOO 242 I @QCXML@(0)<1 D ; MALFORMED XML 243 . W "MALFORMED XML PASSED TO QCLOSE: ",QCXML,! 244 I DEBUG W "GOING TO CLOSE",! 245 N S1,E1,QCT,QCTMP 246 S E1=@QCXML@(0) ; CLOSE UNTIL THE END OF THE XML 247 I $D(QCXPATH) D ; XPATH PROVIDED 248 . D QUERY(QCXML,QCXPATH,"QCT") ; INSURE INDEX 249 . S S1=$P(@QCXML@(QCXPATH),"^",2) ; REMAINING XML 250 I '$D(QCXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT 251 . S S1=@QCXML@(0) 252 D QUEUE(QCBLIST,QCXML,S1,E1) 253 ; D PUSH(QCBLIST,QCXML_";"_S1_";"_E1) 254 Q 255 ; 256 256 INSERT(INSXML,INSNEW,INSXPATH) ; INSERT INSNEW INTO INSXML AT THE 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 257 ; INSXPATH XPATH POINT INSXPATH IS OPTIONAL - IF IT IS 258 ; OMITTED, INSERTION WILL BE AT THE ROOT 259 ; NOTE INSERT IS NON DESTRUCTIVE AND WILL ADD THE NEW 260 ; XML AT THE END OF THE XPATH POINT 261 ; INSXML AND INSNEW ARE PASSED BY NAME INSXPATH IS A VALUE 262 N INSBLD,INSTMP 263 I DEBUG W "DOING INSERT ",INSXML,INSNEW,INSXPATH,! 264 I DEBUG F G1=1:1:@INSXML@(0) W @INSXML@(G1),! 265 I '$D(@INSXML@(0)) D ; INSERT INTO AN EMPTY ARRAY 266 . D CP^GPLXPATH(INSNEW,INSXML) ; JUST COPY INTO THE OUTPUT 267 I $D(@INSXML@(0)) D ; IF ORIGINAL ARRAY IS NOT EMPTY 268 . I $D(INSXPATH) D ; XPATH PROVIDED 269 . . D QOPEN("INSBLD",INSXML,INSXPATH) ; COPY THE BEFORE 270 . . I DEBUG D PARY^GPLXPATH("INSBLD") 271 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, OPEN AT ROOT 272 . . D QOPEN("INSBLD",INSXML,"//") ; OPEN WITH ROOT XPATH 273 . D QUEUE("INSBLD",INSNEW,1,@INSNEW@(0)) ; COPY IN NEW XML 274 . I $D(INSXPATH) D ; XPATH PROVIDED 275 . . D QCLOSE("INSBLD",INSXML,INSXPATH) ; CLOSE WITH XPATH 276 . I '$D(INSXPATH) D ; NO XPATH PROVIDED, CLOSE AT ROOT 277 . . D QCLOSE("INSBLD",INSXML,"//") ; CLOSE WITH ROOT XPATH 278 . D BUILD("INSBLD","INSTMP") ; PUT RESULTS IN INDEST 279 . D CP^GPLXPATH("INSTMP",INSXML) ; COPY BUFFER TO SOURCE 280 Q 281 ; 282 282 INSINNER(INNXML,INNNEW,INNXPATH) ; INSERT THE INNER XML OF INNNEW 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 283 ; INTO INNXML AT THE INNXPATH XPATH POINT 284 ; 285 N INNBLD,UXPATH 286 N INNTBUF 287 S INNTBUF=$NA(^TMP($J,"INNTBUF")) 288 I '$D(INNXPATH) D ; XPATH NOT PASSED 289 . S UXPATH="//" ; USE ROOT XPATH 290 I $D(INNXPATH) S UXPATH=INNXPATH ; USE THE XPATH THAT'S PASSED 291 I '$D(@INNXML@(0)) D ; INNXML IS EMPTY 292 . D QUEUE^GPLXPATH("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER 293 . D BUILD("INNBLD",INNXML) 294 I @INNXML@(0)>0 D ; NOT EMPTY 295 . D QOPEN("INNBLD",INNXML,UXPATH) ; 296 . D QUEUE("INNBLD",INNNEW,2,@INNNEW@(0)-1) ; JUST INNER XML 297 . D QCLOSE("INNBLD",INNXML,UXPATH) 298 . D BUILD("INNBLD",INNTBUF) ; BUILD TO BUFFER 299 . D CP(INNTBUF,INNXML) ; COPY BUFFER TO DEST 300 Q 301 ; 302 302 INSB4(XDEST,XNEW) ; INSERT XNEW AT THE BEGINNING OF XDEST 303 304 305 306 307 308 309 310 311 312 303 ; BUT XDEST AN XNEW ARE PASSED BY NAME 304 N XBLD,XTMP 305 D QUEUE("XBLD",XDEST,1,1) ; NEED TO PRESERVE SECTION ROOT 306 D QUEUE("XBLD",XNEW,1,@XNEW@(0)) ; ALL OF NEW XML FIRST 307 D QUEUE("XBLD",XDEST,2,@XDEST@(0)) ; FOLLOWED BY THE REST OF SECTION 308 D BUILD("XBLD","XTMP") ; BUILD THE RESULT 309 D CP("XTMP",XDEST) ; COPY TO THE DESTINATION 310 I DEBUG D PARY("XDEST") 311 Q 312 ; 313 313 REPLACE(REXML,RENEW,REXPATH) ; REPLACE THE XML AT THE XPATH POINT 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 314 ; WITH RENEW - NOTE THIS WILL DELETE WHAT WAS THERE BEFORE 315 ; REXML AND RENEW ARE PASSED BY NAME XPATH IS A VALUE 316 ; THE DELETED XML IS PUT IN ^TMP($J,"REPLACE_OLD") 317 N REBLD,XFIRST,XLAST,OLD,XNODE,RETMP 318 S OLD=$NA(^TMP($J,"REPLACE_OLD")) 319 D QUERY(REXML,REXPATH,OLD) ; CREATE INDEX, TEST XPATH, MAKE OLD 320 S XNODE=@REXML@(REXPATH) ; PULL OUT FIRST AND LAST LINE PTRS 321 S XFIRST=$P(XNODE,"^",1) 322 S XLAST=$P(XNODE,"^",2) 323 I RENEW="" D ; WE ARE DELETING A SECTION, MUST SAVE THE TAG 324 . D QUEUE("REBLD",REXML,1,XFIRST) ; THE BEFORE 325 . D QUEUE("REBLD",REXML,XLAST,@REXML@(0)) ; THE REST 326 I RENEW'="" D ; NEW XML IS NOT NULL 327 . D QUEUE("REBLD",REXML,1,XFIRST-1) ; THE BEFORE 328 . D QUEUE("REBLD",RENEW,1,@RENEW@(0)) ; THE NEW 329 . D QUEUE("REBLD",REXML,XLAST+1,@REXML@(0)) ; THE REST 330 I DEBUG W "REPLACE PREBUILD",! 331 I DEBUG D PARY("REBLD") 332 D BUILD("REBLD","RTMP") 333 K @REXML ; KILL WHAT WAS THERE 334 D CP("RTMP",REXML) ; COPY IN THE RESULT 335 Q 336 ; 337 337 MISSING(IXML,OARY) ; SEARTH THROUGH INXLM AND PUT ANY @@X@@ VARS IN OARY 338 339 340 341 342 343 344 345 346 347 348 338 ; W "Reporting on the missing",! 339 ; W OARY 340 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MISSING",! Q 341 N I 342 S @OARY@(0)=0 ; INITIALIZED MISSING COUNT 343 F I=1:1:@IXML@(0) D ; LOOP THROUGH WHOLE ARRAY 344 . I @IXML@(I)?.E1"@@".E D ; MISSING VARIABLE HERE 345 . . D PUSH^GPLXPATH(OARY,$P(@IXML@(I),"@@",2)) ; ADD TO OUTARY 346 . . Q 347 Q 348 ; 349 349 MAP(IXML,INARY,OXML) ; SUBSTITUTE MULTIPLE @@X@@ VARS WITH VALUES IN INARY 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 350 ; AND PUT THE RESULTS IN OXML 351 I '$D(@IXML@(0)) W "MALFORMED XML PASSED TO MAP",! Q 352 I $O(@INARY@(""))="" W "EMPTY ARRAY PASSED TO MAP",! Q 353 N I,J,TNAM,TVAL,TSTR 354 S @OXML@(0)=@IXML@(0) ; TOTAL LINES IN OUTPUT 355 F I=1:1:@OXML@(0) D ; LOOP THROUGH WHOLE ARRAY 356 . S @OXML@(I)=@IXML@(I) ; COPY THE LINE TO OUTPUT 357 . I @OXML@(I)?.E1"@@".E D ; IS THERE A VARIABLE HERE? 358 . . S TSTR=$P(@IXML@(I),"@@",1) ; INIT TO PART BEFORE VARS 359 . . F J=2:2:10 D Q:$P(@IXML@(I),"@@",J+2)="" ; QUIT IF NO MORE VARS 360 . . . I DEBUG W "IN MAPPING LOOP: ",TSTR,! 361 . . . S TNAM=$P(@OXML@(I),"@@",J) ; EXTRACT THE VARIABLE NAME 362 . . . S TVAL="@@"_$P(@IXML@(I),"@@",J)_"@@" ; DEFAULT UNCHANGED 363 . . . I $D(@INARY@(TNAM)) D ; IS THE VARIABLE IN THE MAP? 364 . . . . S TVAL=@INARY@(TNAM) ; PULL OUT MAPPED VALUE 365 . . . S TSTR=TSTR_TVAL_$P(@IXML@(I),"@@",J+1) ; ADD VAR AND PART AFTER 366 . . S @OXML@(I)=TSTR ; COPY LINE WITH MAPPED VALUES 367 . . I DEBUG W TSTR 368 I DEBUG W "MAPPED",! 369 Q 370 ; 371 371 TRIM(THEXML) ; TAKES OUT ALL NULL ELEMENTS 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 372 ; THEXML IS PASSED BY NAME 373 N I,J,TMPXML,DEL,FOUND,INTXT 374 S FOUND=0 375 S INTXT=0 376 I DEBUG W "DELETING EMPTY ELEMENTS",! 377 F I=1:1:(@THEXML@(0)-1) D ; LOOP THROUGH ENTIRE ARRAY 378 . S J=@THEXML@(I) 379 . I J["<text>" D 380 . . S INTXT=1 ; IN HTML SECTION, DON'T TRIM 381 . . I DEBUG W "IN HTML SECTION",! 382 . N JM,JP,JPX ; JMINUS AND JPLUS 383 . S JM=@THEXML@(I-1) ; LINE BEFORE 384 . I JM["</text>" S INTXT=0 ; LEFT HTML SECTION,START TRIM 385 . S JP=@THEXML@(I+1) ; LINE AFTER 386 . I INTXT=0 D ; IF NOT IN AN HTML SECTION 387 . . S JPX=$TR(JP,"/","") ; REMOVE THE SLASH 388 . . I J=JPX D ; AN EMPTY ELEMENT ON TWO LINES 389 . . . I DEBUG W I,J,JP,! 390 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED 391 . . . S DEL(I)="" ; SET LINE TO DELETE 392 . . . S DEL(I+1)="" ; SET NEXT LINE TO DELETE 393 . . I J["><" D ; AN EMPTY ELEMENT ON ONE LINE 394 . . . I DEBUG W I,J,! 395 . . . S FOUND=1 ; FOUND SOMETHING TO BE DELETED 396 . . . S DEL(I)="" ; SET THE EMPTY LINE UP TO BE DELETED 397 . . . I JM=JPX D ; 398 . . . . I DEBUG W I,JM_J_JPX,! 399 . . . . S DEL(I-1)="" 400 . . . . S DEL(I+1)="" ; SET THE SURROUNDING LINES FOR DEL 401 ; . I J'["><" D PUSH("TMPXML",J) 402 I FOUND D ; NEED TO DELETE THINGS 403 . F I=1:1:@THEXML@(0) D ; COPY ARRAY LEAVING OUT DELELTED LINES 404 . . I '$D(DEL(I)) D ; IF THE LINE IS NOT DELETED 405 . . . D PUSH("TMPXML",@THEXML@(I)) ; COPY TO TMPXML ARRAY 406 . D CP("TMPXML",THEXML) ; REPLACE THE XML WITH THE COPY 407 Q FOUND 408 ; 409 409 UNMARK(XSEC) ; REMOVE MARKUP FROM FIRST AND LAST LINE OF XML 410 411 412 413 414 415 416 410 ; XSEC IS A SECTION PASSED BY NAME 411 N XBLD,XTMP 412 D QUEUE("XBLD",XSEC,2,@XSEC@(0)-1) ; BUILD LIST FOR INNER XML 413 D BUILD("XBLD","XTMP") ; BUILD THE RESULT 414 D CP("XTMP",XSEC) ; REPLACE PASSED XML 415 Q 416 ; 417 417 PARY(GLO) ;PRINT AN ARRAY 418 419 420 421 418 N I 419 F I=1:1:@GLO@(0) W I_" "_@GLO@(I),! 420 Q 421 ; 422 422 TEST ; Run all the test cases 423 424 425 423 D TESTALL^GPLUNIT("GPLXPAT0") 424 Q 425 ; 426 426 ZTEST(WHICH) ; RUN ONE SET OF TESTS 427 428 429 430 431 432 427 N ZTMP 428 S DEBUG=1 429 D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") 430 D ZTEST^GPLUNIT(.ZTMP,WHICH) 431 Q 432 ; 433 433 TLIST ; LIST THE TESTS 434 435 436 437 438 434 N ZTMP 435 D ZLOAD^GPLUNIT("ZTMP","GPLXPAT0") 436 D TLIST^GPLUNIT(.ZTMP) 437 Q 438 ;
Note:
See TracChangeset
for help on using the changeset viewer.
