MXMLPRSE ;SAIC/DKM - XML Parser ;09/08/08 11:50
;;7.3;TOOLKIT;**58,67,89,116,136**;Apr 25, 1995;Build 5
;Per VHA Directive 6402, this routine should not be modified
;=================================================================
; Main entry point.
; DOC = Closed reference to global array containing document
; CBK = Local array containing entry points for callback interface
; OPTION = Option flags; expected values are:
; D = Debug mode
; W = Do not report warnings
; V = Validate (checks only well-formedness by default)
; 0,1 = Terminate on encountering error at specified level
EN(DOC,CBK,OPTION) ;
N WS,ID,QT,EDC,DTD,LVL,CS,DOCSTK,LLEN,LPOS,CPOS,LCUR,ERR,XML,PFX,SFX,EOD,EOG,ST,PATH,OFX
S ID=$T(+0),WS=$C(9,10,13,32),QT="""",(DOCSTK,EOG,EOD,LVL,CS,ST,LPOS,LLEN,LCUR)=0,(CPOS,LVL(0,"N"))=1,OPTION=$G(OPTION),(XML,PFX,SFX)="",PATH=$$PATH(DOC)
K ^TMP(ID,$J)
I $L($T(TOUCH^XUSCLEAN)) D TOUCH^XUSCLEAN ;Set the keepalive node
D INIT^MXMLPRS1,EPOS,CBK("STARTDOCUMENT"),OPNDOC(DOC)
F Q:EOD D READ,EPOS,@ST^MXMLPRS0:'EOD
D UNRESLV^MXMLPRS1,ERROR(17):ST'=2,CBK("ENDDOCUMENT")
K ^TMP(ID,$J)
Q
; Open a document
; Saves state of current document on stack.
; DOCREF=Closed reference to array containing document
; PREFIX=Optional prefix to prepend to document
; SUFFIX=Optional suffix to append to document
OPNDOC(DOCREF,PREFIX,SUFFIX) ;
S:$E(DOCREF)'="^" DOCREF=$$EXTRNL(DOCREF)
Q:'$L(DOCREF)
D SAVRES(1)
S DOC=$NA(@DOCREF)
I '$D(^TMP(ID,$J,"DOC",DOC)) S ^(DOC)=""
E D ERROR(43)
S (LPOS,LLEN,LCUR)=0,CPOS=1,(OFX,XML)="",PFX=$G(PREFIX),SFX=$G(SUFFIX)
S LCUR=DOC,DOC=$E(DOC,1,$L(DOC)-1) ;*rwf
Q
; Close current document
; Restores state of previous document from stack.
CLSDOC K ^TMP(ID,$J,"DOC",DOC_")") ;*rwf
D SAVRES(0)
Q
; Extract path from filespec
PATH(DOC) ;
N X
Q:U[$E(DOC) ""
F X="\","/","]",":","" Q:DOC[X
Q $P(DOC,X,1,$L(DOC,X)-1)_X
; Save or restore document state
SAVRES(SAVE) ;
N X
S:'SAVE DOCSTK=DOCSTK-1,EOD=DOCSTK=0
I DOCSTK F X="LLEN","LPOS","CPOS","LCUR","XML","PFX","SFX","OFX","DOC" D
.I SAVE S DOCSTK(DOCSTK,X)=@X
.E S @X=DOCSTK(DOCSTK,X)
I SAVE S DOCSTK=DOCSTK+1
E K DOCSTK(DOCSTK)
Q
; Retrieve text from document
READ Q:((LLEN-CPOS)>50)!EOD ;Quit if still have 50 char or EOD
I (CPOS'<LLEN)&EOG D CLSDOC S EOG=0 Q ;At end of text in file
N TMP,X
D SHIFT Q:$L(XML)>50
I EOG!EOD Q ;Quit at end of document
S LPOS=LPOS+1,LCUR=$Q(@LCUR) ;Get next node
I LCUR'[DOC S EOG=1 Q ;At end of global
S TMP=@LCUR ;Get next data chunk
W:OPTION["D" !,$J(LPOS,3)_":",TMP,!
S OFX=OFX_TMP
D SHIFT
I LLEN<50 G READ
Q
;Shift OFX to XML
SHIFT ;
S XML=$E(XML,CPOS,9999),CPOS=1 ;Drop old
I $L(PFX) S OFX=XML_OFX,XML=PFX,PFX=""
I $L(OFX) S X=511-$L(XML),XML=XML_$E(OFX,1,X),OFX=$E(OFX,X+1,99999)
S LLEN=$L(XML)
Q
; Parse name
; ERN=Error to signal if invalid (optional)
NAME(ERN) ;
N X
D EPOS
S X=$E(XML,CPOS)
I X'?1A,"_:"'[X D:$G(ERN) ERROR(ERN,X) Q ""
Q $$NAMETKN(.ERN)
; Parse name token
; ERN=Error to signal if invalid (optional)
NAMETKN(ERN) ;
N X,Y
D EPOS
F X=CPOS:1:LLEN+1 S Y=$E(XML,X) I Y'?1AN,".-_:"'[Y Q
S Y=$E(XML,CPOS,X-1),CPOS=X
I '$L(Y),$G(ERN) D ERROR(ERN,Y)
Q Y
; Parse quote-enclosed value
; ERF=If set, signal error if not found
; FLG=Special flag: 0=attribute literal, 1=general entity literal
; 2=parameter entity literal
; Returns value less quotes with normalized whitespace
VALUE(ERF,FLG) ;
N DLM,CHR,RTN,EXC
D WS()
S DLM=$S($$NEXT(QT):QT,$$NEXT("'"):"'",1:""),RTN="",FLG=+$G(FLG),EXC=$S(FLG=2:"",1:"<")
I DLM="" D:$G(ERF) EPOS,ERROR(11) Q RTN
F S CHR=$E(XML,CPOS) Q:DLM=CHR!(EXC[CHR)!EOD D
.I $$NEXT("&#") S RTN=RTN_$$CHENTITY
.E I 'FLG,$$NEXT("&") S RTN=RTN_$$ENTITY
.E S RTN=RTN_CHR,CPOS=CPOS+1
.;D:CPOS>LLEN READ
.D:(LLEN-CPOS)<50 READ ;P136
I DLM=CHR S CPOS=CPOS+1
E D EPOS,ERROR($S('$L(CHR):12,EXC[CHR:13,1:12)) Q ""
Q $$NMLWS(RTN)
; Normalize whitespace
; Note: used as input transform for Entity Catalog, so can't depend
; on any environment variables.
; TXT=Text to normalize
; Returns text stripped of leading and trailing whitespace and with
; imbedded contiguous whitespace reduced to single space.
NMLWS(TXT,FG) ;
N Z,CRLF
S CRLF=$C(13,10)
;Normalize CRLF to one SP first
F S Z=$F(TXT,CRLF) Q:'Z S TXT=$P(TXT,CRLF,1)_" "_$P(TXT,CRLF,2,999)
S TXT=$TR(TXT,$C(9,10,13,32)," ")
;For CDATA or unk, this is where we should stop
Q:'$G(FG) TXT
F Z=1:1 Q:$E(TXT,Z)'=" "
S TXT=$E(TXT,Z,9999)
F Z=$L(TXT):-1 Q:$E(TXT,Z)'=" "
S TXT=$E(TXT,1,Z)
F Z=1:1:$L(TXT) D:$E(TXT,Z)=" "
.F Q:$E(TXT,Z+1)'=" " S $E(TXT,Z+1)=""
Q TXT
; Process parameter entity if found
DOPARAM F D WS() Q:EOD!'$$NEXT("%") I $$ENTITY(1)
Q
; Resolve general/parameter/character entity
; PARAM=1: parameter; PARAM=0: general or character (default)
ENTITY(PARAM) ;
N NAME,APND
S PARAM=+$G(PARAM)
I 'PARAM,$$NEXT("#") Q $$CHENTITY
S NAME=$S(PARAM:"%",1:"")_$$NAME(2)
Q:'$$NEXT(";",3) ""
;Handle the common ones inline
S APND=$S(NAME="amp":"&",NAME="lt":"<",NAME="gt":">",NAME="quot":$C(34),NAME="apos":"'",1:"")
Q:$L(APND) APND
I $D(^TMP(ID,$J,"UNP",NAME)) D ERROR(40,NAME) Q ""
I '$D(^TMP(ID,$J,"ENT",NAME)) D ERROR(14,NAME) Q ""
S APND=$S(PARAM:" ",1:"")
D OPNDOC(^TMP(ID,$J,"ENT",NAME),APND,APND)
Q ""
; Parse character entity reference
; Returns character equivalent
CHENTITY() ;
N DIGIT,BASE,DIGITS,VAL
S BASE=$S($$NEXT("x"):16,1:10),DIGITS="0123456789"_$S(BASE=16:"ABCDEF",1:""),VAL=0
F CPOS=CPOS:1:LLEN+1 Q:$$NEXT(";")!EOD D
.S DIGIT=$F(DIGITS,$$UP^XLFSTR($E(XML,CPOS)))-2,VAL=VAL*BASE+DIGIT
.D:DIGIT<0 ERROR(19)
I VAL<32,WS'[$C(VAL) D ERROR(19)
Q $C(VAL)
; Set an entity value
SETENT(NAME,VAL) ;
K ^TMP(ID,$J,"ENT",NAME)
S ^(NAME)=$NA(^(NAME)),^(NAME,1)=VAL
Q
; Process all attributes
ATTRIBS(ENAME,ATTR) ;
N TYP,MOD,DEF,ANAME
K ATTR
F Q:'$$ATTRIB(ENAME,.ATTR)
I OPTION["V" D
.S ANAME="$"
.F S ANAME=$O(^TMP(ID,$J,"ATT",ENAME,ANAME)) Q:'$L(ANAME) D
..S TYP=^(ANAME),MOD=$P(TYP,"^",2),DEF=$P(TYP,"^",3,9999),TYP=+TYP
..I MOD=1!(MOD=3),'$D(ATTR(ANAME)) D ERROR(36,ANAME) Q
..I MOD=3,ATTR(ANAME)'=DEF D ERROR(37,ATTR(ANAME)) Q
..I MOD=2,'$D(ATTR(ANAME)) Q
..S:'$D(ATTR(ANAME)) ATTR(ANAME)=DEF
Q
; Parse attribute=value sequence
; ENAME=Element name to which attribute belongs
; ATTR=Local array (by reference) to receive attribute value.
; Format is ATTR("<attribute name>")="<attribute value>"
; Returns 1 if successful, 0 if not.
ATTRIB(ENAME,ATTR) ;
N ANAME
D READ,WS() ;p116
S ANAME=$$NAME
Q:ANAME="" 0
I $D(ATTR(ANAME)) D ERROR(4,ANAME) Q 0
D:'$D(^TMP(ID,$J,"ATT",ENAME,ANAME)) ERROR(29,ANAME)
D READ,WS() ;p116
Q:'$$NEXT("=",3) 0
D WS()
S ATTR(ANAME)=$$VALUE(1)
D CHKVAL^MXMLPRS1(ENAME,ANAME,ATTR(ANAME))
Q 1
; Parse a processing instruction
; Returns 1 if PI found, 0 if not.
PI() N PNAME,ARGS,DONE
Q:'$$NEXT("<?") 0
S PNAME=$$NAME(2),ARGS=0
I $$UP^XLFSTR(PNAME)="XML" D ERROR(9) Q 0
D WS(1)
F S DONE=$F(XML,"?>",CPOS) D Q:DONE!EOD
.S ARGS=ARGS+1,ARGS(ARGS)=$E(XML,CPOS,$S(DONE:DONE-3,1:LLEN))
.S CPOS=$S(DONE:DONE,1:LLEN+1)
.D READ
I EOD D ERROR(7) Q 0
D CBK("PI",PNAME,.ARGS)
Q 1
; Parse a comment
; Returns 1 if comment found, 0 if not.
; Parse a CDATA section
; Returns 1 if found, 0 if not.
CDATA() Q $$PARSCT("<![CDATA[","]]>","","CHARACTERS")
; Parse a section (for CDATA and COMMENT)
; BGN=Beginning delimiter
; END=Ending delimiter
; TRL=Trailing delimiter
; TYP=Event type
PARSCT(BGN,END,TRL,TYP) ;
N X
Q:'$$NEXT(BGN) 0
D EPOS
I 'LVL,TYP'="COMMENT" D ERROR(6) Q 0
F S X=$F(XML,END,CPOS) D Q:X!EOD
.D CBK(TYP,$E(XML,CPOS,$S(X:X-$L(END)-1,1:LLEN)))
.S CPOS=$S(X:X,1:LLEN+1)
.D READ,EPOS
I EOD D ERROR(7) Q 0
I $L(TRL),$$NEXT(TRL,3)
Q 1
; Fetch an external entity from file or entity catalog
; SYS=System identifier (i.e., a URL)
; PUB=Public identifier (i.e., Entity Catalog ID) - optional
; GBL=Optional global root to receive entity content
; Returns global reference or null if error
EXTRNL(SYS,PUB,GBL) ;
N X,Y
S PUB=$$NMLWS($G(PUB)),GBL=$G(GBL)
I '$L(GBL) D CBK("EXTERNAL",.SYS,.PUB,.GBL) Q:$L(GBL) GBL
I $L(PUB) D Q:X $NA(^MXML(950,X,1))
.S Y=$E(PUB,1,30),X=0
.F S X=$O(^MXML(950,"B",Y,X)) Q:'X Q:$G(^MXML(950,X,0))=PUB
S:'$L(GBL) GBL=$$TMPGBL
S:$$PATH(SYS)="" SYS=PATH_SYS
S X=$S($$FTG^%ZISH(SYS,"",$NA(@GBL@(1)),$QL(GBL)+1):GBL,1:"")
D:'$L(X) ERROR(30,$S($L(SYS):SYS,1:PUB))
Q X
; Return a unique scratch global reference
TMPGBL() N SUB
S SUB=$O(^TMP(ID,$J,$C(1)),-1)+1,^(SUB)=""
Q $NA(^(SUB))
; Returns a SYSTEM and/or PUBLIC id
; SYS=Returned SYSTEM id
; PUB=Returned PUBLIC id
; FLG=If set, SYSTEM id is optional after PUBLIC id
; Optional return value: 0=neither, 1=PUBLIC, 2=SYSTEM
SYSPUB(SYS,PUB,FLG) ;
N RTN
I $$NEXT("PUBLIC") D
.D WS(1)
.S PUB=$$VALUE(1),SYS=$$VALUE('$G(FLG)),RTN=1
E I $$NEXT("SYSTEM") D
.D WS(1)
.S PUB="",SYS=$$VALUE(1),RTN=2
E S (SYS,PUB)="",RTN=0
Q:$Q RTN
Q
; Save current document location for error reporting
; See EPOS^MXMLPRS0
EPOS S ERR("XML")=XML,ERR("POS")=CPOS,ERR("LIN")=LPOS
Q
; Setup error information
ERROR(ERN,ARG) ;
N DIHELP,DIMSG,DIERR,MSG
D BLD^DIALOG(9500000+ERN,"","","MSG","")
S ERR("NUM")=ERN
S ERR("SEV")=$S($G(DIHELP):0,$G(DIMSG):1,1:2)
S ERR("MSG")=$G(MSG(1))
S ERR("ARG")=$G(ARG)
I OPTION'["W"!ERR("SEV"),OPTION["V"!(ERR("SEV")'=1) D CBK("ERROR",.ERR)
S:ERR("SEV")=2!(OPTION[ERR("SEV")) EOD=-1 ; Stop parsing on severe error
Q
; Shortcuts to functions/procedures defined elsewhere
WS(X) Q:$Q $$WS^MXMLPRS0(.X)
D WS^MXMLPRS0(.X) Q
CBK(X,Y1,Y2,Y3,Y4) D CBK^MXMLPRS0(.X,.Y1,.Y2,.Y3,.Y4) Q
NEXT(X,Y) Q $$NEXT^MXMLPRS0(.X,.Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMXMLPRSE 9984 printed Sep 23, 2025@19:46:33 Page 2
MXMLPRSE ;SAIC/DKM - XML Parser ;09/08/08 11:50
+1 ;;7.3;TOOLKIT;**58,67,89,116,136**;Apr 25, 1995;Build 5
+2 ;Per VHA Directive 6402, this routine should not be modified
+3 ;=================================================================
+4 ; Main entry point.
+5 ; DOC = Closed reference to global array containing document
+6 ; CBK = Local array containing entry points for callback interface
+7 ; OPTION = Option flags; expected values are:
+8 ; D = Debug mode
+9 ; W = Do not report warnings
+10 ; V = Validate (checks only well-formedness by default)
+11 ; 0,1 = Terminate on encountering error at specified level
EN(DOC,CBK,OPTION) ;
+1 NEW WS,ID,QT,EDC,DTD,LVL,CS,DOCSTK,LLEN,LPOS,CPOS,LCUR,ERR,XML,PFX,SFX,EOD,EOG,ST,PATH,OFX
+2 SET ID=$TEXT(+0)
SET WS=$CHAR(9,10,13,32)
SET QT=""""
SET (DOCSTK,EOG,EOD,LVL,CS,ST,LPOS,LLEN,LCUR)=0
SET (CPOS,LVL(0,"N"))=1
SET OPTION=$GET(OPTION)
SET (XML,PFX,SFX)=""
SET PATH=$$PATH(DOC)
+3 KILL ^TMP(ID,$JOB)
+4 ;Set the keepalive node
IF $LENGTH($TEXT(TOUCH^XUSCLEAN))
DO TOUCH^XUSCLEAN
+5 DO INIT^MXMLPRS1
DO EPOS
DO CBK("STARTDOCUMENT")
DO OPNDOC(DOC)
+6 FOR
if EOD
QUIT
DO READ
DO EPOS
if 'EOD
DO @ST^MXMLPRS0
+7 DO UNRESLV^MXMLPRS1
if ST'=2
DO ERROR(17)
DO CBK("ENDDOCUMENT")
+8 KILL ^TMP(ID,$JOB)
+9 QUIT
+10 ; Open a document
+11 ; Saves state of current document on stack.
+12 ; DOCREF=Closed reference to array containing document
+13 ; PREFIX=Optional prefix to prepend to document
+14 ; SUFFIX=Optional suffix to append to document
OPNDOC(DOCREF,PREFIX,SUFFIX) ;
+1 if $EXTRACT(DOCREF)'="^"
SET DOCREF=$$EXTRNL(DOCREF)
+2 if '$LENGTH(DOCREF)
QUIT
+3 DO SAVRES(1)
+4 SET DOC=$NAME(@DOCREF)
+5 IF '$DATA(^TMP(ID,$JOB,"DOC",DOC))
SET ^(DOC)=""
+6 IF '$TEST
DO ERROR(43)
+7 SET (LPOS,LLEN,LCUR)=0
SET CPOS=1
SET (OFX,XML)=""
SET PFX=$GET(PREFIX)
SET SFX=$GET(SUFFIX)
+8 ;*rwf
SET LCUR=DOC
SET DOC=$EXTRACT(DOC,1,$LENGTH(DOC)-1)
+9 QUIT
+10 ; Close current document
+11 ; Restores state of previous document from stack.
CLSDOC ;*rwf
KILL ^TMP(ID,$JOB,"DOC",DOC_")")
+1 DO SAVRES(0)
+2 QUIT
+3 ; Extract path from filespec
PATH(DOC) ;
+1 NEW X
+2 if U[$EXTRACT(DOC)
QUIT ""
+3 FOR X="\","/","]",":",""
if DOC[X
QUIT
+4 QUIT $PIECE(DOC,X,1,$LENGTH(DOC,X)-1)_X
+5 ; Save or restore document state
SAVRES(SAVE) ;
+1 NEW X
+2 if 'SAVE
SET DOCSTK=DOCSTK-1
SET EOD=DOCSTK=0
+3 IF DOCSTK
FOR X="LLEN","LPOS","CPOS","LCUR","XML","PFX","SFX","OFX","DOC"
Begin DoDot:1
+4 IF SAVE
SET DOCSTK(DOCSTK,X)=@X
+5 IF '$TEST
SET @X=DOCSTK(DOCSTK,X)
End DoDot:1
+6 IF SAVE
SET DOCSTK=DOCSTK+1
+7 IF '$TEST
KILL DOCSTK(DOCSTK)
+8 QUIT
+9 ; Retrieve text from document
READ ;Quit if still have 50 char or EOD
if ((LLEN-CPOS)>50)!EOD
QUIT
+1 ;At end of text in file
IF (CPOS'<LLEN)&EOG
DO CLSDOC
SET EOG=0
QUIT
+2 NEW TMP,X
+3 DO SHIFT
if $LENGTH(XML)>50
QUIT
+4 ;Quit at end of document
IF EOG!EOD
QUIT
+5 ;Get next node
SET LPOS=LPOS+1
SET LCUR=$QUERY(@LCUR)
+6 ;At end of global
IF LCUR'[DOC
SET EOG=1
QUIT
+7 ;Get next data chunk
SET TMP=@LCUR
+8 if OPTION["D"
WRITE !,$JUSTIFY(LPOS,3)_":",TMP,!
+9 SET OFX=OFX_TMP
+10 DO SHIFT
+11 IF LLEN<50
GOTO READ
+12 QUIT
+13 ;Shift OFX to XML
SHIFT ;
+1 ;Drop old
SET XML=$EXTRACT(XML,CPOS,9999)
SET CPOS=1
+2 IF $LENGTH(PFX)
SET OFX=XML_OFX
SET XML=PFX
SET PFX=""
+3 IF $LENGTH(OFX)
SET X=511-$LENGTH(XML)
SET XML=XML_$EXTRACT(OFX,1,X)
SET OFX=$EXTRACT(OFX,X+1,99999)
+4 SET LLEN=$LENGTH(XML)
+5 QUIT
+6 ; Parse name
+7 ; ERN=Error to signal if invalid (optional)
NAME(ERN) ;
+1 NEW X
+2 DO EPOS
+3 SET X=$EXTRACT(XML,CPOS)
+4 IF X'?1A
IF "_:"'[X
if $GET(ERN)
DO ERROR(ERN,X)
QUIT ""
+5 QUIT $$NAMETKN(.ERN)
+6 ; Parse name token
+7 ; ERN=Error to signal if invalid (optional)
NAMETKN(ERN) ;
+1 NEW X,Y
+2 DO EPOS
+3 FOR X=CPOS:1:LLEN+1
SET Y=$EXTRACT(XML,X)
IF Y'?1AN
IF ".-_:"'[Y
QUIT
+4 SET Y=$EXTRACT(XML,CPOS,X-1)
SET CPOS=X
+5 IF '$LENGTH(Y)
IF $GET(ERN)
DO ERROR(ERN,Y)
+6 QUIT Y
+7 ; Parse quote-enclosed value
+8 ; ERF=If set, signal error if not found
+9 ; FLG=Special flag: 0=attribute literal, 1=general entity literal
+10 ; 2=parameter entity literal
+11 ; Returns value less quotes with normalized whitespace
VALUE(ERF,FLG) ;
+1 NEW DLM,CHR,RTN,EXC
+2 DO WS()
+3 SET DLM=$SELECT($$NEXT(QT):QT,$$NEXT("'"):"'",1:"")
SET RTN=""
SET FLG=+$GET(FLG)
SET EXC=$SELECT(FLG=2:"",1:"<")
+4 IF DLM=""
if $GET(ERF)
DO EPOS
DO ERROR(11)
QUIT RTN
+5 FOR
SET CHR=$EXTRACT(XML,CPOS)
if DLM=CHR!(EXC[CHR)!EOD
QUIT
Begin DoDot:1
+6 IF $$NEXT("&#")
SET RTN=RTN_$$CHENTITY
+7 IF '$TEST
IF 'FLG
IF $$NEXT("&")
SET RTN=RTN_$$ENTITY
+8 IF '$TEST
SET RTN=RTN_CHR
SET CPOS=CPOS+1
+9 ;D:CPOS>LLEN READ
+10 ;P136
if (LLEN-CPOS)<50
DO READ
End DoDot:1
+11 IF DLM=CHR
SET CPOS=CPOS+1
+12 IF '$TEST
DO EPOS
DO ERROR($SELECT('$LENGTH(CHR):12,EXC[CHR:13,1:12))
QUIT ""
+13 QUIT $$NMLWS(RTN)
+14 ; Normalize whitespace
+15 ; Note: used as input transform for Entity Catalog, so can't depend
+16 ; on any environment variables.
+17 ; TXT=Text to normalize
+18 ; Returns text stripped of leading and trailing whitespace and with
+19 ; imbedded contiguous whitespace reduced to single space.
NMLWS(TXT,FG) ;
+1 NEW Z,CRLF
+2 SET CRLF=$CHAR(13,10)
+3 ;Normalize CRLF to one SP first
+4 FOR
SET Z=$FIND(TXT,CRLF)
if 'Z
QUIT
SET TXT=$PIECE(TXT,CRLF,1)_" "_$PIECE(TXT,CRLF,2,999)
+5 SET TXT=$TRANSLATE(TXT,$CHAR(9,10,13,32)," ")
+6 ;For CDATA or unk, this is where we should stop
+7 if '$GET(FG)
QUIT TXT
+8 FOR Z=1:1
if $EXTRACT(TXT,Z)'=" "
QUIT
+9 SET TXT=$EXTRACT(TXT,Z,9999)
+10 FOR Z=$LENGTH(TXT):-1
if $EXTRACT(TXT,Z)'=" "
QUIT
+11 SET TXT=$EXTRACT(TXT,1,Z)
+12 FOR Z=1:1:$LENGTH(TXT)
if $EXTRACT(TXT,Z)=" "
Begin DoDot:1
+13 FOR
if $EXTRACT(TXT,Z+1)'=" "
QUIT
SET $EXTRACT(TXT,Z+1)=""
End DoDot:1
+14 QUIT TXT
+15 ; Process parameter entity if found
DOPARAM FOR
DO WS()
if EOD!'$$NEXT("%")
QUIT
IF $$ENTITY(1)
+1 QUIT
+2 ; Resolve general/parameter/character entity
+3 ; PARAM=1: parameter; PARAM=0: general or character (default)
ENTITY(PARAM) ;
+1 NEW NAME,APND
+2 SET PARAM=+$GET(PARAM)
+3 IF 'PARAM
IF $$NEXT("#")
QUIT $$CHENTITY
+4 SET NAME=$SELECT(PARAM:"%",1:"")_$$NAME(2)
+5 if '$$NEXT(";",3)
QUIT ""
+6 ;Handle the common ones inline
+7 SET APND=$SELECT(NAME="amp":"&",NAME="lt":"<",NAME="gt":">",NAME="quot":$CHAR(34),NAME="apos":"'",1:"")
+8 if $LENGTH(APND)
QUIT APND
+9 IF $DATA(^TMP(ID,$JOB,"UNP",NAME))
DO ERROR(40,NAME)
QUIT ""
+10 IF '$DATA(^TMP(ID,$JOB,"ENT",NAME))
DO ERROR(14,NAME)
QUIT ""
+11 SET APND=$SELECT(PARAM:" ",1:"")
+12 DO OPNDOC(^TMP(ID,$JOB,"ENT",NAME),APND,APND)
+13 QUIT ""
+14 ; Parse character entity reference
+15 ; Returns character equivalent
CHENTITY() ;
+1 NEW DIGIT,BASE,DIGITS,VAL
+2 SET BASE=$SELECT($$NEXT("x"):16,1:10)
SET DIGITS="0123456789"_$SELECT(BASE=16:"ABCDEF",1:"")
SET VAL=0
+3 FOR CPOS=CPOS:1:LLEN+1
if $$NEXT(";")!EOD
QUIT
Begin DoDot:1
+4 SET DIGIT=$FIND(DIGITS,$$UP^XLFSTR($EXTRACT(XML,CPOS)))-2
SET VAL=VAL*BASE+DIGIT
+5 if DIGIT<0
DO ERROR(19)
End DoDot:1
+6 IF VAL<32
IF WS'[$CHAR(VAL)
DO ERROR(19)
+7 QUIT $CHAR(VAL)
+8 ; Set an entity value
SETENT(NAME,VAL) ;
+1 KILL ^TMP(ID,$JOB,"ENT",NAME)
+2 SET ^(NAME)=$NAME(^(NAME))
SET ^(NAME,1)=VAL
+3 QUIT
+4 ; Process all attributes
ATTRIBS(ENAME,ATTR) ;
+1 NEW TYP,MOD,DEF,ANAME
+2 KILL ATTR
+3 FOR
if '$$ATTRIB(ENAME,.ATTR)
QUIT
+4 IF OPTION["V"
Begin DoDot:1
+5 SET ANAME="$"
+6 FOR
SET ANAME=$ORDER(^TMP(ID,$JOB,"ATT",ENAME,ANAME))
if '$LENGTH(ANAME)
QUIT
Begin DoDot:2
+7 SET TYP=^(ANAME)
SET MOD=$PIECE(TYP,"^",2)
SET DEF=$PIECE(TYP,"^",3,9999)
SET TYP=+TYP
+8 IF MOD=1!(MOD=3)
IF '$DATA(ATTR(ANAME))
DO ERROR(36,ANAME)
QUIT
+9 IF MOD=3
IF ATTR(ANAME)'=DEF
DO ERROR(37,ATTR(ANAME))
QUIT
+10 IF MOD=2
IF '$DATA(ATTR(ANAME))
QUIT
+11 if '$DATA(ATTR(ANAME))
SET ATTR(ANAME)=DEF
End DoDot:2
End DoDot:1
+12 QUIT
+13 ; Parse attribute=value sequence
+14 ; ENAME=Element name to which attribute belongs
+15 ; ATTR=Local array (by reference) to receive attribute value.
+16 ; Format is ATTR("<attribute name>")="<attribute value>"
+17 ; Returns 1 if successful, 0 if not.
ATTRIB(ENAME,ATTR) ;
+1 NEW ANAME
+2 ;p116
DO READ
DO WS()
+3 SET ANAME=$$NAME
+4 if ANAME=""
QUIT 0
+5 IF $DATA(ATTR(ANAME))
DO ERROR(4,ANAME)
QUIT 0
+6 if '$DATA(^TMP(ID,$JOB,"ATT",ENAME,ANAME))
DO ERROR(29,ANAME)
+7 ;p116
DO READ
DO WS()
+8 if '$$NEXT("=",3)
QUIT 0
+9 DO WS()
+10 SET ATTR(ANAME)=$$VALUE(1)
+11 DO CHKVAL^MXMLPRS1(ENAME,ANAME,ATTR(ANAME))
+12 QUIT 1
+13 ; Parse a processing instruction
+14 ; Returns 1 if PI found, 0 if not.
PI() NEW PNAME,ARGS,DONE
+1 if '$$NEXT("<?")
QUIT 0
+2 SET PNAME=$$NAME(2)
SET ARGS=0
+3 IF $$UP^XLFSTR(PNAME)="XML"
DO ERROR(9)
QUIT 0
+4 DO WS(1)
+5 FOR
SET DONE=$FIND(XML,"?>",CPOS)
Begin DoDot:1
+6 SET ARGS=ARGS+1
SET ARGS(ARGS)=$EXTRACT(XML,CPOS,$SELECT(DONE:DONE-3,1:LLEN))
+7 SET CPOS=$SELECT(DONE:DONE,1:LLEN+1)
+8 DO READ
End DoDot:1
if DONE!EOD
QUIT
+9 IF EOD
DO ERROR(7)
QUIT 0
+10 DO CBK("PI",PNAME,.ARGS)
+11 QUIT 1
+12 ; Parse a comment
+13 ; Returns 1 if comment found, 0 if not.
+1 ; Parse a CDATA section
+2 ; Returns 1 if found, 0 if not.
CDATA() QUIT $$PARSCT("<![CDATA[","]]>","","CHARACTERS")
+1 ; Parse a section (for CDATA and COMMENT)
+2 ; BGN=Beginning delimiter
+3 ; END=Ending delimiter
+4 ; TRL=Trailing delimiter
+5 ; TYP=Event type
PARSCT(BGN,END,TRL,TYP) ;
+1 NEW X
+2 if '$$NEXT(BGN)
QUIT 0
+3 DO EPOS
+4 IF 'LVL
IF TYP'="COMMENT"
DO ERROR(6)
QUIT 0
+5 FOR
SET X=$FIND(XML,END,CPOS)
Begin DoDot:1
+6 DO CBK(TYP,$EXTRACT(XML,CPOS,$SELECT(X:X-$LENGTH(END)-1,1:LLEN)))
+7 SET CPOS=$SELECT(X:X,1:LLEN+1)
+8 DO READ
DO EPOS
End DoDot:1
if X!EOD
QUIT
+9 IF EOD
DO ERROR(7)
QUIT 0
+10 IF $LENGTH(TRL)
IF $$NEXT(TRL,3)
+11 QUIT 1
+12 ; Fetch an external entity from file or entity catalog
+13 ; SYS=System identifier (i.e., a URL)
+14 ; PUB=Public identifier (i.e., Entity Catalog ID) - optional
+15 ; GBL=Optional global root to receive entity content
+16 ; Returns global reference or null if error
EXTRNL(SYS,PUB,GBL) ;
+1 NEW X,Y
+2 SET PUB=$$NMLWS($GET(PUB))
SET GBL=$GET(GBL)
+3 IF '$LENGTH(GBL)
DO CBK("EXTERNAL",.SYS,.PUB,.GBL)
if $LENGTH(GBL)
QUIT GBL
+4 IF $LENGTH(PUB)
Begin DoDot:1
+5 SET Y=$EXTRACT(PUB,1,30)
SET X=0
+6 FOR
SET X=$ORDER(^MXML(950,"B",Y,X))
if 'X
QUIT
if $GET(^MXML(950,X,0))=PUB
QUIT
End DoDot:1
if X
QUIT $NAME(^MXML(950,X,1))
+7 if '$LENGTH(GBL)
SET GBL=$$TMPGBL
+8 if $$PATH(SYS)=""
SET SYS=PATH_SYS
+9 SET X=$SELECT($$FTG^%ZISH(SYS,"",$NAME(@GBL@(1)),$QLENGTH(GBL)+1):GBL,1:"")
+10 if '$LENGTH(X)
DO ERROR(30,$SELECT($LENGTH(SYS):SYS,1:PUB))
+11 QUIT X
+12 ; Return a unique scratch global reference
TMPGBL() NEW SUB
+1 SET SUB=$ORDER(^TMP(ID,$JOB,$CHAR(1)),-1)+1
SET ^(SUB)=""
+2 QUIT $NAME(^(SUB))
+3 ; Returns a SYSTEM and/or PUBLIC id
+4 ; SYS=Returned SYSTEM id
+5 ; PUB=Returned PUBLIC id
+6 ; FLG=If set, SYSTEM id is optional after PUBLIC id
+7 ; Optional return value: 0=neither, 1=PUBLIC, 2=SYSTEM
SYSPUB(SYS,PUB,FLG) ;
+1 NEW RTN
+2 IF $$NEXT("PUBLIC")
Begin DoDot:1
+3 DO WS(1)
+4 SET PUB=$$VALUE(1)
SET SYS=$$VALUE('$GET(FLG))
SET RTN=1
End DoDot:1
+5 IF '$TEST
IF $$NEXT("SYSTEM")
Begin DoDot:1
+6 DO WS(1)
+7 SET PUB=""
SET SYS=$$VALUE(1)
SET RTN=2
End DoDot:1
+8 IF '$TEST
SET (SYS,PUB)=""
SET RTN=0
+9 if $QUIT
QUIT RTN
+10 QUIT
+11 ; Save current document location for error reporting
+12 ; See EPOS^MXMLPRS0
EPOS SET ERR("XML")=XML
SET ERR("POS")=CPOS
SET ERR("LIN")=LPOS
+1 QUIT
+2 ; Setup error information
ERROR(ERN,ARG) ;
+1 NEW DIHELP,DIMSG,DIERR,MSG
+2 DO BLD^DIALOG(9500000+ERN,"","","MSG","")
+3 SET ERR("NUM")=ERN
+4 SET ERR("SEV")=$SELECT($GET(DIHELP):0,$GET(DIMSG):1,1:2)
+5 SET ERR("MSG")=$GET(MSG(1))
+6 SET ERR("ARG")=$GET(ARG)
+7 IF OPTION'["W"!ERR("SEV")
IF OPTION["V"!(ERR("SEV")'=1)
DO CBK("ERROR",.ERR)
+8 ; Stop parsing on severe error
if ERR("SEV")=2!(OPTION[ERR("SEV"))
SET EOD=-1
+9 QUIT
+10 ; Shortcuts to functions/procedures defined elsewhere
WS(X) if $QUIT
QUIT $$WS^MXMLPRS0(.X)
+1 DO WS^MXMLPRS0(.X)
QUIT
CBK(X,Y1,Y2,Y3,Y4) DO CBK^MXMLPRS0(.X,.Y1,.Y2,.Y3,.Y4)
QUIT
NEXT(X,Y) QUIT $$NEXT^MXMLPRS0(.X,.Y)
