Changeset 38 for ccr/trunk/p


Ignore:
Timestamp:
Jul 3, 2008, 8:26:40 PM (16 years ago)
Author:
George Lilly
Message:

Cleaned up leading spaces

Location:
ccr/trunk/p
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • ccr/trunk/p/GPLCCR.m

    r36 r38  
    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;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP($J,DFN,""PROBLEMS"")")
    75                       D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITALS;//ContinuityOfCareRecord/Body/VitalSigns;^TMP($J,DFN,""VITALS"")")
    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                       S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$FMTHL7^XLFDT($$NOW^XLFDT),"DT")
    82                       I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
    83                       . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
    84                       . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - ???
    85                       . S @VMAP@("ACTORFROM2")="ACTORPROVIDER_"_DUZ ; NEED BETTER WAY
    86                       . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES,
    87                       . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
    88                       I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
    89                       . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
    90                       N CTMP
    91                       D MAP^GPLXPATH(CXML,VMAP,"CTMP")
    92                       D CP^GPLXPATH("CTMP",CXML)
    93                       Q
    94                       ;
    95 ACTLST(AXML,ACTRTN)         ; RETURN THE ACTOR LIST FOR THE XML IN AXML
    96                       ; AXML AND ACTRTN ARE PASSED BY NAME
    97                       ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
    98                       ; P1= OBJECTID - ACTORPATIENT_2
    99                       ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
    100                       ;     OR INSTITUTION
    101                       ;     OR PERSON(IN PATIENT FILE IE NOK)
    102                       ; P3= IEN RECORD NUMBER FOR ACTOR - 2
    103                       N I,J,K,L
    104                       K @ACTRTN ; CLEAR RETURN ARRAY
    105                       F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
    106                       . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
    107                       . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
    108                       . . W "<ActorID>=>",J,!
    109                       . . I J'="" S K(J)="" ; HASHING ACTOR
    110                       . . ;  TO GET RID OF DUPLICATES
    111                       S I="" ; GOING TO $O THROUGH THE HASH
    112                       F J=0:0 D  Q:$O(K(I))=""
    113                       . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
    114                       . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
    115                       . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
    116                       . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
    117                       . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
    118                       Q
    119                       ;
    120 TEST         ; RUN ALL THE TEST CASES
    121                     D TESTALL^GPLUNIT("GPLCCR")
    122                     Q
    123                     ;
    124 ZTEST(WHICH)       ; RUN ONE SET OF TESTS
    125                     N ZTMP
    126                     D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
    127                     D ZTEST^GPLUNIT(.ZTMP,WHICH)
    128                     Q
    129                     ;
    130 TLIST     ; LIST THE TESTS
    131                     N ZTMP
    132                     D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
    133                     D TLIST^GPLUNIT(.ZTMP)
    134                     Q
    135                     ;
    136 ;;><TEST>       
    137 ;;><PROBLEMS>   
    138 ;;>>>K  GPL S GPL=""
    139 ;;>>>D  CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","")
    140 ;;>>?@GPL@(@GPL@(0))["</Problems>"     
    141 ;;><VITALS>     
    142 ;;>>>K  GPL S GPL=""
    143 ;;>>>D  CCRRPC^GPLCCR(.GPL,"2","VITALS","","","")
    144 ;;>>?@GPL@(@GPL@(0))["</VitalSigns>"   
    145 ;;><CCR>       
    146 ;;>>>K  GPL S GPL=""
    147 ;;>>>D  CCRRPC^GPLCCR(.GPL,"2","CCR","","","")
    148 ;;>>?@GPL@(@GPL@(0))["</ContinuityOfCareRecord>"       
    149 ;;><ACTLST>     
    150 ;;>>>K  GPL S GPL=""
    151 ;;>>>D  CCRRPC^GPLCCR(.GPL,"2","CCR","","","")
    152 ;;>>>D  ACTLST^GPLCCR(GPL,"ACTTEST")
    153 ;;></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;GPLPROBS;//ContinuityOfCareRecord/Body/Problems;^TMP($J,DFN,""PROBLEMS"")")
     75            D PUSH^GPLXPATH(TAB,"EXTRACT;GPLVITALS;//ContinuityOfCareRecord/Body/VitalSigns;^TMP($J,DFN,""VITALS"")")
     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            S @VMAP@("DATETIME")=$$FMDTOUTC^CCRUTIL($$FMTHL7^XLFDT($$NOW^XLFDT),"DT")
     82            I IHDR="" D  ; HEADER ARRAY IS NOT PROVIDED, USE DEFAULTS
     83            . S @VMAP@("ACTORPATIENT")="ACTORPATIENT_"_DFN
     84            . S @VMAP@("ACTORFROM")="ACTORPROVIDER_"_DUZ ; FROM DUZ - ???
     85            . S @VMAP@("ACTORFROM2")="ACTORPROVIDER_"_DUZ ; NEED BETTER WAY
     86            . S @VMAP@("ACTORTO")="ACTORPATIENT_"_DFN  ; FOR TEST PURPOSES,
     87            . ; THIS IS THE USE CASE FOR THE PHR WHERE "TO" IS THE PATIENT
     88            I IHDR'="" D  ; HEADER VALUES ARE PROVIDED
     89            . D CP^GPLXPATH(IHDR,VMAP) ; COPY HEADER VARIABLES TO MAP ARRAY
     90            N CTMP
     91            D MAP^GPLXPATH(CXML,VMAP,"CTMP")
     92            D CP^GPLXPATH("CTMP",CXML)
     93            Q
     94            ;
     95ACTLST(AXML,ACTRTN)         ; RETURN THE ACTOR LIST FOR THE XML IN AXML
     96            ; AXML AND ACTRTN ARE PASSED BY NAME
     97            ; EACH ACTOR RECORD HAS 3 PARTS - IE IF OBJECTID=ACTORPATIENT_2
     98            ; P1= OBJECTID - ACTORPATIENT_2
     99            ; P2= OBJECT TYPE - PATIENT OR PROVIDER OR SOFTWARE
     100            ;     OR INSTITUTION
     101            ;     OR PERSON(IN PATIENT FILE IE NOK)
     102            ; P3= IEN RECORD NUMBER FOR ACTOR - 2
     103            N I,J,K,L
     104            K @ACTRTN ; CLEAR RETURN ARRAY
     105            F I=1:1:@AXML@(0) D  ; SCAN ALL LINES
     106            . I @AXML@(I)?.E1"<ActorID>".E D  ; THERE IS AN ACTOR THIS LINE
     107            . . S J=$P($P(@AXML@(I),"<ActorID>",2),"</ActorID>",1)
     108            . . W "<ActorID>=>",J,!
     109            . . I J'="" S K(J)="" ; HASHING ACTOR
     110            . . ;  TO GET RID OF DUPLICATES
     111            S I="" ; GOING TO $O THROUGH THE HASH
     112            F J=0:0 D  Q:$O(K(I))=""
     113            . S I=$O(K(I)) ; WALK THROUGH THE HASH OF ACTORS
     114            . S $P(L,U,1)=I ; FIRST PIECE IS THE OBJECT ID
     115            . S $P(L,U,2)=$P($P(I,"ACTOR",2),"_",1) ; ACTOR TYPE
     116            . S $P(L,U,3)=$P(I,"_",2) ; IEN RECORD NUMBER FOR ACTOR
     117            . D PUSH^GPLXPATH(ACTRTN,L) ; ADD THE ACTOR TO THE RETURN ARRAY
     118            Q
     119            ;
     120TEST    ; RUN ALL THE TEST CASES
     121          D TESTALL^GPLUNIT("GPLCCR")
     122          Q
     123          ;
     124ZTEST(WHICH)       ; RUN ONE SET OF TESTS
     125          N ZTMP
     126          D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
     127          D ZTEST^GPLUNIT(.ZTMP,WHICH)
     128          Q
     129          ;
     130TLIST     ; LIST THE TESTS
     131          N ZTMP
     132          D ZLOAD^GPLUNIT("ZTMP","GPLCCR")
     133          D TLIST^GPLUNIT(.ZTMP)
     134          Q
     135          ;
     136;;><TEST>
     137;;><PROBLEMS>
     138;;>>>K GPL S GPL=""
     139;;>>>D CCRRPC^GPLCCR(.GPL,"2","PROBLEMS","","","")
     140;;>>?@GPL@(@GPL@(0))["</Problems>"
     141;;><VITALS>
     142;;>>>K GPL S GPL=""
     143;;>>>D CCRRPC^GPLCCR(.GPL,"2","VITALS","","","")
     144;;>>?@GPL@(@GPL@(0))["</VitalSigns>"
     145;;><CCR>
     146;;>>>K GPL S GPL=""
     147;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","")
     148;;>>?@GPL@(@GPL@(0))["</ContinuityOfCareRecord>"
     149;;><ACTLST>
     150;;>>>K GPL S GPL=""
     151;;>>>D CCRRPC^GPLCCR(.GPL,"2","CCR","","","")
     152;;>>>D ACTLST^GPLCCR(GPL,"ACTTEST")
     153;;></TEST>

  • ccr/trunk/p/GPLXPATH.m

    r35 r38  
    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                ;
     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          ;
    77OUTPUT(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                ;
     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          ;
    1515PUSH(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                ;
     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          ;
    2323POP(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                ;
     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          ;
    3333MKMDX(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                ;
     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          ;
    4444XNAME(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                ;
     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          ;
    5959INDEX(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                ;
     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          ;
    116116QUERY(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               ;
     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         ;
    138138XF(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               ;
     139         ; INDEX WITH TWO PIECES START^FINISH
     140         ; IDX IS PASSED BY NAME
     141         Q $P(@IDX@(XPATH),"^",1)
     142         ;
    143143XL(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               ;
     144         ; INDEX WITH TWO PIECES START^FINISH
     145         ; IDX IS PASSED BY NAME
     146         Q $P(@IDX@(XPATH),"^",2)
     147         ;
    148148START(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               ;
     149         ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     150         ; COMPANION TO FINISH ; IDX IS PASSED BY NAME
     151         Q $P(ISTR,";",2)
     152         ;
    153153FINISH(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               ;
     154         ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     155         Q $P(ISTR,";",3)
     156         ;
    157157ARRAY(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               ;
     158         ; TYPE STRING WITH THREE PIECES ARRAY;START;FINISH
     159         Q $P(ISTR,";",1)
     160         ;
    161161BUILD(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               ;
     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         ;
    179179QUEUE(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               ;
     180         ;
     181         I DEBUG W "QUEUEING ",BLST,!
     182         D PUSH(BLST,ARRAY_";"_FIRST_";"_LAST)
     183         Q
     184         ;
    185185CP(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               ;
     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         ;
    197197QOPEN(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               ;
     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         ;
    217217QCLOSE(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               ;
     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         ;
    236236INSERT(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               ;
     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         ;
    262262INSINNER(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               ;
     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         ;
    282282REPLACE(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               ;
     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         ;
    303303MISSING(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               ;
     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         ;
    315315MAP(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               ;
     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         ;
    331331PARY(GLO)       ;PRINT AN ARRAY
    332              N I
    333              F I=1:1:@GLO@(0) W @GLO@(I),!
    334              Q
    335              ;
     332        N I
     333        F I=1:1:@GLO@(0) W @GLO@(I),!
     334        Q
     335        ;
    336336TEST     ; Run all the test cases
    337              D TESTALL^GPLUNIT("GPLXPATH")
    338              Q
    339              ;
     337        D TESTALL^GPLUNIT("GPLXPATH")
     338        Q
     339        ;
    340340OLDTEST   ; 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                ;
     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        ;
    351351ZTEST(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                ;
     352          N ZTMP
     353          S DEBUG=1
     354          D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     355          D ZTEST^GPLUNIT(.ZTMP,WHICH)
     356          Q
     357          ;
    358358TLIST   ; LIST THE TESTS
    359              N ZTMP
    360              D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
    361              D TLIST^GPLUNIT(.ZTMP)
    362              Q
    363              ;
     359        N ZTMP
     360        D ZLOAD^GPLUNIT("ZTMP","GPLXPATH")
     361        D TLIST^GPLUNIT(.ZTMP)
     362        Q
     363        ;
    364364;;><TEST>
    365365;;><INIT>
Note: See TracChangeset for help on using the changeset viewer.