MXMLPRS0 ;SAIC/DKM - XML Parser ;03/09/2005 12:57
;;7.3;TOOLKIT;**58,89,136**;Apr 25, 1995;Build 5
;Per VHA Directive 6402, this routine should not be modified
;=================================================================
; State 0: Prolog
0 N ATTR
S ST=1
D WS()
I '$$NEXT("<?xml") D ERROR(31) Q
D WS(1),ATTRIBS("?xml",.ATTR),WS()
I $$NEXT("?>",3)
D:$G(ATTR("version"))'="1.0" ERROR(10,$G(ATTR("version")))
Q
; State 1: Document type declaration
1 N PUB,SYS
D WS()
Q:$$COMMENT
S ST=2
I '$$NEXT("<!DOCTYPE") D ERROR(32) Q
D WS(1)
S LVL(0)=$$NAME(2),DTD=""
D WS(),SYSPUB(.SYS,.PUB)
I OPTION["V",$L(SYS)!$L(PUB) D
.S DTD=$$EXTRNL(SYS,PUB)
D WS(),CBK("DOCTYPE",LVL(0),PUB,SYS)
I $$NEXT("[") S ST=5
E S:$$NEXT(">",3) ST=6
Q
; State 2: Non-markup text
2 N TXT,CHR
D:'LVL WS()
S TXT=""
F S CHR=$E(XML,CPOS) Q:"<"[CHR!EOD D
.I $$NEXT("&") S TXT=TXT_$$ENTITY
.E S TXT=TXT_CHR,CPOS=CPOS+1
.D:(LLEN-CPOS)<50 READ ;P136
S:CHR="<" ST=3
I $L(TXT) D
.I 'LVL D ERROR(6) Q
.I '$$ISCHILD(LVL(LVL),"#PCDATA",1) D:$L($TR(TXT,WS)) ERROR(27) Q
.D CBK("CHARACTERS",TXT)
Q
; State 3: Markup text
3 N END,ENAME,ATTR
S ST=2
Q:$$COMMENT
Q:$$CDATA
Q:$$PI
Q:'$$NEXT("<",3)
S END=$$NEXT("/"),ENAME=$$NAME(2)
Q:'$L(ENAME)
I 'END D
.S:LVL LVL(LVL,"N")=$$ISCHILD(LVL(LVL),ENAME,LVL(LVL,"N"))
.D:'LVL(LVL,"N") ERROR(24,ENAME)
.D ATTRIBS(ENAME,.ATTR),CBK("STARTELEMENT",ENAME,.ATTR),WS()
.D READ ;*89 Check for more data
.S END=$$NEXT("/"),LVL=LVL+1
.M LVL(LVL)=ERR
.S LVL(LVL)=ENAME,LVL(LVL,"N")=1
.I LVL=1 D
..I $D(LVL(0))#2,LVL(0)'=ENAME D ERROR(15,ENAME) Q
..I '$D(LVL(-1)) S LVL(-1)=""
..E D ERROR(45,ENAME)
I END D
.I LVL>0,$G(LVL(LVL))=ENAME D
..D:'$$ISCHILD(ENAME,"*",LVL(LVL,"N")) ERROR(25)
..D CBK("ENDELEMENT",ENAME)
..K LVL(LVL)
..S LVL=LVL-1
.E D ERROR(5,ENAME)
I $$NEXT(">",3)
Q
; State 5: Internal or external DTD
5 N X,Y
D DOPARAM
Q:$$COMMENT
I CS,$$NEXT("]]>") S CS=CS-1 Q
I $$NEXT("]") D Q
.S ST=6
.D WS()
.I $$NEXT(">",3)
Q:'$$NEXT("<!",3)
S X=$S($$NEXT("["):"[",1:$$NAME(2))
Q:'$L(X)
I $G(DTD(X)) S ST=$$WS(X'="["),ST=DTD(X)
E D ERROR(16,X)
Q
; State 6: Check for external DTD
6 S ST=2
Q:OPTION'["V"
I $G(DTD)'="" D Q
.D OPNDOC(DTD,,"]>"),0
.S ST=5,DTD=""
D:CS ERROR(42)
Q
; State 8: End of DTD declaration
8 D WS()
I $$NEXT(">",3)
S ST=5
Q
; State 20: DTD ENTITY declaration
20 N SYS,PUB,ENAME,TYP,DUP,Z
I $$NEXT("%"),$$WS(1) S TYP=2
E S TYP=1
S ENAME=$$NAME(2)
Q:'$L(ENAME)
S ST=8,ENAME=$S(TYP=2:"%",1:"")_ENAME,DUP=$D(^TMP(ID,$J,"ENT",ENAME))
D NOFWD("UNP",ENAME),ERROR(18,ENAME):DUP,WS(1)
I $$SYSPUB(.SYS,.PUB) D
.D WS()
.I TYP=1,$$NEXT("NDATA") D
..D WS(1)
..S Z=$$NAME(2)
..Q:'$L(Z)
..D FWD("NOT",Z)
..S:'DUP ^TMP(ID,$J,"ENT",ENAME)="",^TMP(ID,$J,"UNP",ENAME)=Z
.E D:'DUP
..S Z=$$EXTRNL(SYS,PUB)
..S:$L(Z) ^TMP(ID,$J,"ENT",ENAME)=Z
E D
.S Z=$$VALUE(1,TYP)
.D:'DUP SETENT(ENAME,Z)
Q
; State 30: DTD ELEMENT declaration
; Builds a parse tree for child elements
30 N STK,ELEMENT,CHILD,START,END,MIXED,X,Z
D DOPARAM
S ELEMENT=$$NAME(2),ST=8
Q:'$L(ELEMENT)
Q:'$$WS(1)
I $D(^TMP(ID,$J,"ELE",ELEMENT)) D ERROR(20,ELEMENT) Q
D NOFWD("ELE",ELEMENT)
S Z=$S($$NEXT("EMPTY"):1,$$NEXT("ANY"):2,1:0),^TMP(ID,$J,"ELE",ELEMENT)=Z
Q:Z
S STK=0,MIXED=0,START=1,END=2
; Check for opening parenthesis
LPAREN D DOPARAM
I MIXED<2 D
.F D WS() Q:'$$NEXT("(",$S(STK:0,1:3)) S STK(STK)=START,STK=STK+1
; Element name, parameter entity, or #PCDATA
D DOPARAM
I 'MIXED,$$NEXT("#PCDATA") S CHILD="#PCDATA",MIXED=2
E S CHILD=$$NAME(2),MIXED=$S('MIXED:1,MIXED=2:3,1:MIXED) Q:'$L(CHILD) D FWD("ELE",CHILD)
I $D(STK(-1,CHILD)) D ERROR(23,CHILD) Q
S STK(-1,CHILD)="",^TMP(ID,$J,"ELE",ELEMENT,START,CHILD)=END
S:CHILD="#PCDATA" ^(END)=""
G:MIXED>1 SEQOPR
; Check for repetition modifier
REPMOD S X=$S($$NEXT("*",$S(MIXED=3:3,1:0)):2,MIXED>1:0,$$NEXT("+"):1,$$NEXT("?"):3,1:0)
S:X=1 ^TMP(ID,$J,"ELE",ELEMENT,END,START)=""
S:X=2 ^TMP(ID,$J,"ELE",ELEMENT,END,START)="",^TMP(ID,$J,"ELE",ELEMENT,START,END)=""
S:X=3 ^TMP(ID,$J,"ELE",ELEMENT,START,END)=""
; Check for sequence operator
SEQOPR D WS()
S X=$S($$NEXT("|"):2,MIXED=2:0,$$NEXT(","):1,1:0)
I X D G LPAREN
.S:'$D(STK(STK,0)) STK(STK,0)=X
.D:STK(STK,0)'=X ERROR(22,$E(",|",X))
.S:X=1 START=END,END=END+1
D WS()
I '$$NEXT(")",$S(STK:3,1:0)) D Q
.S ^TMP(ID,$J,"ELE",ELEMENT,END,"*")=-1
I 'STK D ERROR(21) Q
K STK(STK)
S STK=STK-1,START=STK(STK)
G REPMOD
; State 40: DTD ATTLIST declaration
40 N ELEMENT,ATTRIB,TYPE,DFLT,DUP,X,Y
D DOPARAM
S ELEMENT=$$NAME(2)
Q:'$L(ELEMENT)
Q:'$$WS(1)
D FWD("ELE",ELEMENT)
; Attribute name
ATTNAME D DOPARAM
S ATTRIB=$$NAME(2)
Q:'$L(ATTRIB)
S DUP=$D(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB))
D ERROR(4,ATTRIB):DUP,WS(1)
; Attribute type
S TYPE=$$FNDTKN("TYP")
I 'TYPE D ERROR(33) Q
S:'DUP ^TMP(ID,$J,"ATT",ELEMENT,ATTRIB)=TYPE
D WS(TYPE'=1),NOTN:TYPE=8,ENUM:TYPE=1,WS()
; Default modifier
S DFLT=$$FNDTKN("MOD")
S:'DUP $P(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB),"^",2)=DFLT,Y=$G(^("#ID"))
I TYPE=5 D ; If ID type
.D:DFLT=3 ERROR(34)
.I '$L(Y) S:'DUP ^TMP(ID,$J,"ATT",ELEMENT,"#ID")=ATTRIB
.E D ERROR(35,Y)
; Default value
I DFLT=3!'DFLT D
.D:DFLT WS(1)
.S X=$$VALUE(1)
.Q:DUP
.S $P(^TMP(ID,$J,"ATT",ELEMENT,ATTRIB),"^",3)=X
.D CHKVAL(ELEMENT,ATTRIB,X)
; Next attribute or end of declaration
D WS()
G:'$$NEXT(">") ATTNAME
S ST=5
Q
; Search for a token of the specified group
; GRP=Group id
; Returns token id within group or 0 if none found
FNDTKN(GRP) ;
N TKN
S TKN=""
F S TKN=$O(^TMP(ID,$J,GRP,TKN),-1) Q:$$NEXT(TKN)
Q $S($L(TKN):^TMP(ID,$J,GRP,TKN),1:0)
; Enumerated attribute type
ENUM F D WS() S X=$$NAMETKN(3) Q:'$L(X) D Q:'$$NEXT("|")
.D:TYPE=8 FWD("NOT",X)
.S ^TMP(ID,$J,"ATT",ELEMENT,ATTRIB,X)=""
.D WS()
I $$NEXT(")",3)
Q
; NOTATION attribute type
NOTN D ENUM:$$NEXT("(",3)
Q
; State 50: DTD NOTATION declaration
50 N NAME,SYS,PUB,DUP
S NAME=$$NAME(3),ST=8
Q:'$L(NAME)
Q:'$$WS(1)
S DUP=$D(^TMP(ID,$J,"NOT",NAME))
D NOFWD("NOT",NAME),ERROR(48,NAME):DUP
I '$$SYSPUB(.SYS,.PUB,1) D ERROR(39) Q
Q:DUP
S ^TMP(ID,$J,"NOT",NAME,1)=SYS,^(2)=PUB
D CBK("NOTATION",NAME,SYS,PUB)
Q
; State 60: Conditional sections
60 N CSTYPE,CSCNT,DLM
D DOPARAM
S CSTYPE=$S($$NEXT("INCLUDE"):1,$$NEXT("IGNORE"):2,1:0),ST=5
I 'CSTYPE D ERROR(41) Q
I DOCSTK=1 D ERROR(44) Q
D WS()
Q:'$$NEXT("[",3)
I CSTYPE=1 S CS=CS+1 Q
S CSCNT=1,DLM=""
F D Q:'CSCNT!EOD
.I $L(DLM),$$NEXT(DLM) S DLM=""
.E I $L(DLM) S CPOS=CPOS+1
.E I $$NEXT(QT) S DLM=QT
.E I $$NEXT("'") S DLM="'"
.E I $$NEXT("<![") S CSCNT=CSCNT+1
.E I $$NEXT("]]>") S CSCNT=CSCNT-1
.E S CPOS=CPOS+1
.D:CPOS>LLEN READ
D:CSCNT ERROR(42)
Q
;Local Functions moved from MXMLPRSE
; Execute event callback (if defined)
; EVT=Event name
; Pn=Parameters
CBK(EVT,P1,P2,P3,P4) ;
Q:EOD<0
N EN,PNUM
S EN=$G(CBK(EVT))
Q:EN=""
S PNUM=^TMP(ID,$J,"CBK",EVT)
D @(EN_$P("(.P1,.P2,.P3,.P4",",",1,PNUM)_$S('PNUM:"",1:")"))
Q
; Save current document location for error reporting
; See EPOS^MXMLPRSE
EPOS S ERR("XML")=XML,ERR("POS")=CPOS,ERR("LIN")=LPOS
Q
; Check next characters
; SEQ=character sequence
; ERN=Error to signal if not found (optional)
NEXT(SEQ,ERN) ;
I SEQ=$E(XML,CPOS,CPOS+$L(SEQ)-1) S CPOS=CPOS+$L(SEQ) Q 1
D:$G(ERN) EPOS^MXMLPRSE,ERROR(ERN,SEQ)
Q 0
; Skip whitespace
; ERN=Error to signal if not found (optional)
; Optional return value =1 if whitespace found, 0 if not.
WS(ERN) N CHR,FND
D EPOS^MXMLPRSE
S FND=0
F D:CPOS>LLEN READ S CHR=$E(XML,CPOS) Q:WS'[CHR!EOD D
.S ERN=0,CPOS=CPOS+1,FND=1
D:$G(ERN) ERROR(ERN)
Q:$Q FND
Q
; Shortcuts to functions/procedures defined elsewhere
ATTRIBS(X,Y) D ATTRIBS^MXMLPRSE(.X,.Y) Q
CDATA() Q $$CDATA^MXMLPRSE
CHKVAL(X,Y,Z) D CHKVAL^MXMLPRS1(.X,.Y,.Z) Q
DOPARAM G DOPARAM^MXMLPRSE
ENTITY(X) Q $$ENTITY^MXMLPRSE(.X)
ERROR(X,Y) D ERROR^MXMLPRSE(.X,.Y) Q
EXTRNL(X,Y,Z) Q $$EXTRNL^MXMLPRSE(.X,.Y,.Z)
FWD(X,Y) D FWD^MXMLPRS1(.X,.Y) Q
ISCHILD(X,Y,Z) Q $$ISCHILD^MXMLPRS1(.X,.Y,.Z)
NAME(X) Q $$NAME^MXMLPRSE(.X)
NAMETKN(X) Q $$NAMETKN^MXMLPRSE(.X)
NOFWD(X,Y) D NOFWD^MXMLPRS1(.X,.Y) Q
OPNDOC(X,Y,Z) D OPNDOC^MXMLPRSE(.X,.Y,.Z) Q
PI() Q $$PI^MXMLPRSE
SETENT(X,Y) D SETENT^MXMLPRSE(.X,.Y) Q
SYSPUB(X,Y,Z) Q:$Q $$SYSPUB^MXMLPRSE(.X,.Y,.Z)
D SYSPUB^MXMLPRSE(.X,.Y) Q
READ G READ^MXMLPRSE
VALUE(X,Y) Q $$VALUE^MXMLPRSE(.X,.Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMXMLPRS0 8707 printed Jan 18, 2025@03:11:33 Page 2
MXMLPRS0 ;SAIC/DKM - XML Parser ;03/09/2005 12:57
+1 ;;7.3;TOOLKIT;**58,89,136**;Apr 25, 1995;Build 5
+2 ;Per VHA Directive 6402, this routine should not be modified
+3 ;=================================================================
+4 ; State 0: Prolog
0 NEW ATTR
+1 SET ST=1
+2 DO WS()
+3 IF '$$NEXT("<?xml")
DO ERROR(31)
QUIT
+4 DO WS(1)
DO ATTRIBS("?xml",.ATTR)
DO WS()
+5 IF $$NEXT("?>",3)
+6 if $GET(ATTR("version"))'="1.0"
DO ERROR(10,$GET(ATTR("version")))
+7 QUIT
+8 ; State 1: Document type declaration
1 NEW PUB,SYS
+1 DO WS()
+2 if $$COMMENT
QUIT
+3 SET ST=2
+4 IF '$$NEXT("<!DOCTYPE")
DO ERROR(32)
QUIT
+5 DO WS(1)
+6 SET LVL(0)=$$NAME(2)
SET DTD=""
+7 DO WS()
DO SYSPUB(.SYS,.PUB)
+8 IF OPTION["V"
IF $LENGTH(SYS)!$LENGTH(PUB)
Begin DoDot:1
+9 SET DTD=$$EXTRNL(SYS,PUB)
End DoDot:1
+10 DO WS()
DO CBK("DOCTYPE",LVL(0),PUB,SYS)
+11 IF $$NEXT("[")
SET ST=5
+12 IF '$TEST
if $$NEXT(">",3)
SET ST=6
+13 QUIT
+14 ; State 2: Non-markup text
2 NEW TXT,CHR
+1 if 'LVL
DO WS()
+2 SET TXT=""
+3 FOR
SET CHR=$EXTRACT(XML,CPOS)
if "<"[CHR!EOD
QUIT
Begin DoDot:1
+4 IF $$NEXT("&")
SET TXT=TXT_$$ENTITY
+5 IF '$TEST
SET TXT=TXT_CHR
SET CPOS=CPOS+1
+6 ;P136
if (LLEN-CPOS)<50
DO READ
End DoDot:1
+7 if CHR="<"
SET ST=3
+8 IF $LENGTH(TXT)
Begin DoDot:1
+9 IF 'LVL
DO ERROR(6)
QUIT
+10 IF '$$ISCHILD(LVL(LVL),"#PCDATA",1)
if $LENGTH($TRANSLATE(TXT,WS))
DO ERROR(27)
QUIT
+11 DO CBK("CHARACTERS",TXT)
End DoDot:1
+12 QUIT
+13 ; State 3: Markup text
3 NEW END,ENAME,ATTR
+1 SET ST=2
+2 if $$COMMENT
QUIT
+3 if $$CDATA
QUIT
+4 if $$PI
QUIT
+5 if '$$NEXT("<",3)
QUIT
+6 SET END=$$NEXT("/")
SET ENAME=$$NAME(2)
+7 if '$LENGTH(ENAME)
QUIT
+8 IF 'END
Begin DoDot:1
+9 if LVL
SET LVL(LVL,"N")=$$ISCHILD(LVL(LVL),ENAME,LVL(LVL,"N"))
+10 if 'LVL(LVL,"N")
DO ERROR(24,ENAME)
+11 DO ATTRIBS(ENAME,.ATTR)
DO CBK("STARTELEMENT",ENAME,.ATTR)
DO WS()
+12 ;*89 Check for more data
DO READ
+13 SET END=$$NEXT("/")
SET LVL=LVL+1
+14 MERGE LVL(LVL)=ERR
+15 SET LVL(LVL)=ENAME
SET LVL(LVL,"N")=1
+16 IF LVL=1
Begin DoDot:2
+17 IF $DATA(LVL(0))#2
IF LVL(0)'=ENAME
DO ERROR(15,ENAME)
QUIT
+18 IF '$DATA(LVL(-1))
SET LVL(-1)=""
+19 IF '$TEST
DO ERROR(45,ENAME)
End DoDot:2
End DoDot:1
+20 IF END
Begin DoDot:1
+21 IF LVL>0
IF $GET(LVL(LVL))=ENAME
Begin DoDot:2
+22 if '$$ISCHILD(ENAME,"*",LVL(LVL,"N"))
DO ERROR(25)
+23 DO CBK("ENDELEMENT",ENAME)
+24 KILL LVL(LVL)
+25 SET LVL=LVL-1
End DoDot:2
+26 IF '$TEST
DO ERROR(5,ENAME)
End DoDot:1
+27 IF $$NEXT(">",3)
+28 QUIT
+29 ; State 5: Internal or external DTD
5 NEW X,Y
+1 DO DOPARAM
+2 if $$COMMENT
QUIT
+3 IF CS
IF $$NEXT("]]>")
SET CS=CS-1
QUIT
+4 IF $$NEXT("]")
Begin DoDot:1
+5 SET ST=6
+6 DO WS()
+7 IF $$NEXT(">",3)
End DoDot:1
QUIT
+8 if '$$NEXT("<!",3)
QUIT
+9 SET X=$SELECT($$NEXT("["):"[",1:$$NAME(2))
+10 if '$LENGTH(X)
QUIT
+11 IF $GET(DTD(X))
SET ST=$$WS(X'="[")
SET ST=DTD(X)
+12 IF '$TEST
DO ERROR(16,X)
+13 QUIT
+14 ; State 6: Check for external DTD
6 SET ST=2
+1 if OPTION'["V"
QUIT
+2 IF $GET(DTD)'=""
Begin DoDot:1
+3 DO OPNDOC(DTD,,"]>")
DO 0
+4 SET ST=5
SET DTD=""
End DoDot:1
QUIT
+5 if CS
DO ERROR(42)
+6 QUIT
+7 ; State 8: End of DTD declaration
8 DO WS()
+1 IF $$NEXT(">",3)
+2 SET ST=5
+3 QUIT
+4 ; State 20: DTD ENTITY declaration
20 NEW SYS,PUB,ENAME,TYP,DUP,Z
+1 IF $$NEXT("%")
IF $$WS(1)
SET TYP=2
+2 IF '$TEST
SET TYP=1
+3 SET ENAME=$$NAME(2)
+4 if '$LENGTH(ENAME)
QUIT
+5 SET ST=8
SET ENAME=$SELECT(TYP=2:"%",1:"")_ENAME
SET DUP=$DATA(^TMP(ID,$JOB,"ENT",ENAME))
+6 DO NOFWD("UNP",ENAME)
if DUP
DO ERROR(18,ENAME)
DO WS(1)
+7 IF $$SYSPUB(.SYS,.PUB)
Begin DoDot:1
+8 DO WS()
+9 IF TYP=1
IF $$NEXT("NDATA")
Begin DoDot:2
+10 DO WS(1)
+11 SET Z=$$NAME(2)
+12 if '$LENGTH(Z)
QUIT
+13 DO FWD("NOT",Z)
+14 if 'DUP
SET ^TMP(ID,$JOB,"ENT",ENAME)=""
SET ^TMP(ID,$JOB,"UNP",ENAME)=Z
End DoDot:2
+15 IF '$TEST
if 'DUP
Begin DoDot:2
+16 SET Z=$$EXTRNL(SYS,PUB)
+17 if $LENGTH(Z)
SET ^TMP(ID,$JOB,"ENT",ENAME)=Z
End DoDot:2
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 SET Z=$$VALUE(1,TYP)
+20 if 'DUP
DO SETENT(ENAME,Z)
End DoDot:1
+21 QUIT
+22 ; State 30: DTD ELEMENT declaration
+23 ; Builds a parse tree for child elements
30 NEW STK,ELEMENT,CHILD,START,END,MIXED,X,Z
+1 DO DOPARAM
+2 SET ELEMENT=$$NAME(2)
SET ST=8
+3 if '$LENGTH(ELEMENT)
QUIT
+4 if '$$WS(1)
QUIT
+5 IF $DATA(^TMP(ID,$JOB,"ELE",ELEMENT))
DO ERROR(20,ELEMENT)
QUIT
+6 DO NOFWD("ELE",ELEMENT)
+7 SET Z=$SELECT($$NEXT("EMPTY"):1,$$NEXT("ANY"):2,1:0)
SET ^TMP(ID,$JOB,"ELE",ELEMENT)=Z
+8 if Z
QUIT
+9 SET STK=0
SET MIXED=0
SET START=1
SET END=2
+10 ; Check for opening parenthesis
LPAREN DO DOPARAM
+1 IF MIXED<2
Begin DoDot:1
+2 FOR
DO WS()
if '$$NEXT("(",$SELECT(STK
QUIT
SET STK(STK)=START
SET STK=STK+1
End DoDot:1
+3 ; Element name, parameter entity, or #PCDATA
+4 DO DOPARAM
+5 IF 'MIXED
IF $$NEXT("#PCDATA")
SET CHILD="#PCDATA"
SET MIXED=2
+6 IF '$TEST
SET CHILD=$$NAME(2)
SET MIXED=$SELECT('MIXED:1,MIXED=2:3,1:MIXED)
if '$LENGTH(CHILD)
QUIT
DO FWD("ELE",CHILD)
+7 IF $DATA(STK(-1,CHILD))
DO ERROR(23,CHILD)
QUIT
+8 SET STK(-1,CHILD)=""
SET ^TMP(ID,$JOB,"ELE",ELEMENT,START,CHILD)=END
+9 if CHILD="#PCDATA"
SET ^(END)=""
+10 if MIXED>1
GOTO SEQOPR
+11 ; Check for repetition modifier
REPMOD SET X=$SELECT($$NEXT("*",$SELECT(MIXED=3:3,1:0)):2,MIXED>1:0,$$NEXT("+"):1,$$NEXT("?"):3,1:0)
+1 if X=1
SET ^TMP(ID,$JOB,"ELE",ELEMENT,END,START)=""
+2 if X=2
SET ^TMP(ID,$JOB,"ELE",ELEMENT,END,START)=""
SET ^TMP(ID,$JOB,"ELE",ELEMENT,START,END)=""
+3 if X=3
SET ^TMP(ID,$JOB,"ELE",ELEMENT,START,END)=""
+4 ; Check for sequence operator
SEQOPR DO WS()
+1 SET X=$SELECT($$NEXT("|"):2,MIXED=2:0,$$NEXT(","):1,1:0)
+2 IF X
Begin DoDot:1
+3 if '$DATA(STK(STK,0))
SET STK(STK,0)=X
+4 if STK(STK,0)'=X
DO ERROR(22,$EXTRACT(",|",X))
+5 if X=1
SET START=END
SET END=END+1
End DoDot:1
GOTO LPAREN
+6 DO WS()
+7 IF '$$NEXT(")",$SELECT(STK:3,1:0))
Begin DoDot:1
+8 SET ^TMP(ID,$JOB,"ELE",ELEMENT,END,"*")=-1
End DoDot:1
QUIT
+9 IF 'STK
DO ERROR(21)
QUIT
+10 KILL STK(STK)
+11 SET STK=STK-1
SET START=STK(STK)
+12 GOTO REPMOD
+13 ; State 40: DTD ATTLIST declaration
40 NEW ELEMENT,ATTRIB,TYPE,DFLT,DUP,X,Y
+1 DO DOPARAM
+2 SET ELEMENT=$$NAME(2)
+3 if '$LENGTH(ELEMENT)
QUIT
+4 if '$$WS(1)
QUIT
+5 DO FWD("ELE",ELEMENT)
+6 ; Attribute name
ATTNAME DO DOPARAM
+1 SET ATTRIB=$$NAME(2)
+2 if '$LENGTH(ATTRIB)
QUIT
+3 SET DUP=$DATA(^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB))
+4 if DUP
DO ERROR(4,ATTRIB)
DO WS(1)
+5 ; Attribute type
+6 SET TYPE=$$FNDTKN("TYP")
+7 IF 'TYPE
DO ERROR(33)
QUIT
+8 if 'DUP
SET ^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB)=TYPE
+9 DO WS(TYPE'=1)
if TYPE=8
DO NOTN
if TYPE=1
DO ENUM
DO WS()
+10 ; Default modifier
+11 SET DFLT=$$FNDTKN("MOD")
+12 if 'DUP
SET $PIECE(^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB),"^",2)=DFLT
SET Y=$GET(^("#ID"))
+13 ; If ID type
IF TYPE=5
Begin DoDot:1
+14 if DFLT=3
DO ERROR(34)
+15 IF '$LENGTH(Y)
if 'DUP
SET ^TMP(ID,$JOB,"ATT",ELEMENT,"#ID")=ATTRIB
+16 IF '$TEST
DO ERROR(35,Y)
End DoDot:1
+17 ; Default value
+18 IF DFLT=3!'DFLT
Begin DoDot:1
+19 if DFLT
DO WS(1)
+20 SET X=$$VALUE(1)
+21 if DUP
QUIT
+22 SET $PIECE(^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB),"^",3)=X
+23 DO CHKVAL(ELEMENT,ATTRIB,X)
End DoDot:1
+24 ; Next attribute or end of declaration
+25 DO WS()
+26 if '$$NEXT(">")
GOTO ATTNAME
+27 SET ST=5
+28 QUIT
+29 ; Search for a token of the specified group
+30 ; GRP=Group id
+31 ; Returns token id within group or 0 if none found
FNDTKN(GRP) ;
+1 NEW TKN
+2 SET TKN=""
+3 FOR
SET TKN=$ORDER(^TMP(ID,$JOB,GRP,TKN),-1)
if $$NEXT(TKN)
QUIT
+4 QUIT $SELECT($LENGTH(TKN):^TMP(ID,$JOB,GRP,TKN),1:0)
+5 ; Enumerated attribute type
ENUM FOR
DO WS()
SET X=$$NAMETKN(3)
if '$LENGTH(X)
QUIT
Begin DoDot:1
+1 if TYPE=8
DO FWD("NOT",X)
+2 SET ^TMP(ID,$JOB,"ATT",ELEMENT,ATTRIB,X)=""
+3 DO WS()
End DoDot:1
if '$$NEXT("|")
QUIT
+4 IF $$NEXT(")",3)
+5 QUIT
+6 ; NOTATION attribute type
NOTN if $$NEXT("(",3)
DO ENUM
+1 QUIT
+2 ; State 50: DTD NOTATION declaration
50 NEW NAME,SYS,PUB,DUP
+1 SET NAME=$$NAME(3)
SET ST=8
+2 if '$LENGTH(NAME)
QUIT
+3 if '$$WS(1)
QUIT
+4 SET DUP=$DATA(^TMP(ID,$JOB,"NOT",NAME))
+5 DO NOFWD("NOT",NAME)
if DUP
DO ERROR(48,NAME)
+6 IF '$$SYSPUB(.SYS,.PUB,1)
DO ERROR(39)
QUIT
+7 if DUP
QUIT
+8 SET ^TMP(ID,$JOB,"NOT",NAME,1)=SYS
SET ^(2)=PUB
+9 DO CBK("NOTATION",NAME,SYS,PUB)
+10 QUIT
+11 ; State 60: Conditional sections
60 NEW CSTYPE,CSCNT,DLM
+1 DO DOPARAM
+2 SET CSTYPE=$SELECT($$NEXT("INCLUDE"):1,$$NEXT("IGNORE"):2,1:0)
SET ST=5
+3 IF 'CSTYPE
DO ERROR(41)
QUIT
+4 IF DOCSTK=1
DO ERROR(44)
QUIT
+5 DO WS()
+6 if '$$NEXT("[",3)
QUIT
+7 IF CSTYPE=1
SET CS=CS+1
QUIT
+8 SET CSCNT=1
SET DLM=""
+9 FOR
Begin DoDot:1
+10 IF $LENGTH(DLM)
IF $$NEXT(DLM)
SET DLM=""
+11 IF '$TEST
IF $LENGTH(DLM)
SET CPOS=CPOS+1
+12 IF '$TEST
IF $$NEXT(QT)
SET DLM=QT
+13 IF '$TEST
IF $$NEXT("'")
SET DLM="'"
+14 IF '$TEST
IF $$NEXT("<![")
SET CSCNT=CSCNT+1
+15 IF '$TEST
IF $$NEXT("]]>")
SET CSCNT=CSCNT-1
+16 IF '$TEST
SET CPOS=CPOS+1
+17 if CPOS>LLEN
DO READ
End DoDot:1
if 'CSCNT!EOD
QUIT
+18 if CSCNT
DO ERROR(42)
+19 QUIT
+20 ;Local Functions moved from MXMLPRSE
+21 ; Execute event callback (if defined)
+22 ; EVT=Event name
+23 ; Pn=Parameters
CBK(EVT,P1,P2,P3,P4) ;
+1 if EOD<0
QUIT
+2 NEW EN,PNUM
+3 SET EN=$GET(CBK(EVT))
+4 if EN=""
QUIT
+5 SET PNUM=^TMP(ID,$JOB,"CBK",EVT)
+6 DO @(EN_$PIECE("(.P1,.P2,.P3,.P4",",",1,PNUM)_$SELECT('PNUM:"",1:")"))
+7 QUIT
+8 ; Save current document location for error reporting
+9 ; See EPOS^MXMLPRSE
EPOS SET ERR("XML")=XML
SET ERR("POS")=CPOS
SET ERR("LIN")=LPOS
+1 QUIT
+2 ; Check next characters
+3 ; SEQ=character sequence
+4 ; ERN=Error to signal if not found (optional)
NEXT(SEQ,ERN) ;
+1 IF SEQ=$EXTRACT(XML,CPOS,CPOS+$LENGTH(SEQ)-1)
SET CPOS=CPOS+$LENGTH(SEQ)
QUIT 1
+2 if $GET(ERN)
DO EPOS^MXMLPRSE
DO ERROR(ERN,SEQ)
+3 QUIT 0
+4 ; Skip whitespace
+5 ; ERN=Error to signal if not found (optional)
+6 ; Optional return value =1 if whitespace found, 0 if not.
WS(ERN) NEW CHR,FND
+1 DO EPOS^MXMLPRSE
+2 SET FND=0
+3 FOR
if CPOS>LLEN
DO READ
SET CHR=$EXTRACT(XML,CPOS)
if WS'[CHR!EOD
QUIT
Begin DoDot:1
+4 SET ERN=0
SET CPOS=CPOS+1
SET FND=1
End DoDot:1
+5 if $GET(ERN)
DO ERROR(ERN)
+6 if $QUIT
QUIT FND
+7 QUIT
+8 ; Shortcuts to functions/procedures defined elsewhere
ATTRIBS(X,Y) DO ATTRIBS^MXMLPRSE(.X,.Y)
QUIT
CDATA() QUIT $$CDATA^MXMLPRSE
CHKVAL(X,Y,Z) DO CHKVAL^MXMLPRS1(.X,.Y,.Z)
QUIT
DOPARAM GOTO DOPARAM^MXMLPRSE
ENTITY(X) QUIT $$ENTITY^MXMLPRSE(.X)
ERROR(X,Y) DO ERROR^MXMLPRSE(.X,.Y)
QUIT
EXTRNL(X,Y,Z) QUIT $$EXTRNL^MXMLPRSE(.X,.Y,.Z)
FWD(X,Y) DO FWD^MXMLPRS1(.X,.Y)
QUIT
ISCHILD(X,Y,Z) QUIT $$ISCHILD^MXMLPRS1(.X,.Y,.Z)
NAME(X) QUIT $$NAME^MXMLPRSE(.X)
NAMETKN(X) QUIT $$NAMETKN^MXMLPRSE(.X)
NOFWD(X,Y) DO NOFWD^MXMLPRS1(.X,.Y)
QUIT
OPNDOC(X,Y,Z) DO OPNDOC^MXMLPRSE(.X,.Y,.Z)
QUIT
PI() QUIT $$PI^MXMLPRSE
SETENT(X,Y) DO SETENT^MXMLPRSE(.X,.Y)
QUIT
SYSPUB(X,Y,Z) if $QUIT
QUIT $$SYSPUB^MXMLPRSE(.X,.Y,.Z)
+1 DO SYSPUB^MXMLPRSE(.X,.Y)
QUIT
READ GOTO READ^MXMLPRSE
VALUE(X,Y) QUIT $$VALUE^MXMLPRSE(.X,.Y)
