MXMLPRS1 ;SAIC/DKM - XML Parser ;12/04/2002 15:55
;;7.3;TOOLKIT;**58,67**;Apr 25, 1995
;=================================================================
; Initialize tables
INIT N X,Y,Z
F X=0:1 S Y=$P($T(ENTITIES+X),";;",2,99) Q:'$L(Y) D
.D SETENT^MXMLPRSE($P(Y,";"),$P(Y,";",2,99))
F X=0:1 S Y=$P($T(DTDTAG+X),";;",2,99) Q:'$L(Y) D
.S DTD($P(Y,";"))=$P(Y,";",2)
F X=0:1 S Y=$P($T(TYPE+X),";;",2,99) Q:'$L(Y) D
.S ^TMP(ID,$J,"TYP",$P(Y,";",2))=+Y
F X=0:1 S Y=$P($T(MOD+X),";;",2,99) Q:'$L(Y) D
.S ^TMP(ID,$J,"MOD",$P(Y,";",2))=+Y
F X=0:1 S Y=$P($T(REF+X),";;",2,99) Q:'$L(Y) D
.S ^TMP(ID,$J,"REF",$P(Y,";",2))=+Y
F X=0:1 S Y=$P($T(CBKARGS+X),";;",2,99) Q:'$L(Y) D
.S ^TMP(ID,$J,"CBK",$P(Y,";",2))=+Y
F X=0:1 S Y=$P($T(PROLOG+X),";;",2,99) Q:'$L(Y) D
.S Z=$P(Y,";"),^TMP(ID,$J,"ATT","?xml",Z)="1^"_$S('X:1,1:2)
.F S Y=$P(Y,";",2,99) Q:'$L(Y) S ^TMP(ID,$J,"ATT","?xml",Z,$P(Y,";"))=""
Q
; Search parse tree for child element (CHILD) under parent element
; (ELEMENT) starting at specified node (NODE).
; Returns next node # in parse tree or 0
; If validation is disabled, the function always returns 1.
; If parent element is marked as EMPTY, 0 is returned.
; If parent element is marked as ANY, 1 is returned.
ISCHILD(ELEMENT,CHILD,NODE) ;
N TRN
S TRN=+$G(^TMP(ID,$J,"ELE",ELEMENT),2)
Q $S(OPTION'["V"!'NODE:1,TRN=1:CHILD="*",TRN=2:1,1:$$IC(NODE))
IC(NODE) N X,Y
S X=+$G(^TMP(ID,$J,"ELE",ELEMENT,NODE,CHILD)),Y=0
I 'X D
.F S Y=$O(^TMP(ID,$J,"ELE",ELEMENT,NODE,Y)) Q:'Y D Q:X
..S:'$D(TRN(NODE,Y)) TRN(NODE,Y)="",X=$$IC(Y)
Q X
; Check attribute value for validity
CHKVAL(ENAME,ANAME,VALUE) ;
N TYPE,X,Y,Z
Q:'$L(VALUE)
I $D(^TMP(ID,$J,"ATT",ENAME,ANAME))>1 D:'$D(^(ANAME,VALUE)) ERROR(38,VALUE) Q
S TYPE=+$G(^TMP(ID,$J,"ATT",ENAME,ANAME))
Q:'TYPE
I TYPE=5 D Q ; ID type
.I '$$ISNAME(VALUE) D ERROR(38,VALUE) Q
.I '$D(^TMP(ID,$J,"ID",VALUE)) D
..S ^(VALUE)=""
..D NOFWD("ID",VALUE)
.E D ERROR(28,VALUE)
I TYPE=9!(TYPE=10) D Q ; ENTITY/ENTITIES type
.S X=$S(TYPE=9:" ",1:" ")
.F Z=1:1:$L(VALUE,X) D FWD("UNP",$P(VALUE,X,Z))
I TYPE=3!(TYPE=4) D Q ; NMTOKEN/NMTOKENS type
.S X=$S(TYPE=3:" ",1:" ")
.F Z=1:1:$L(VALUE,X) D
..S Y=$P(VALUE,X,Z)
..D:'$$ISNMTKN(Y) ERROR(38,Y)
I TYPE=6!(TYPE=7) D Q ; IDREF/IDREFS type
.S X=$S(TYPE=6:" ",1:" ")
.F Z=1:1:$L(VALUE,X) D
..S Y=$P(VALUE,X,Z)
..I '$$ISNAME(Y) D ERROR(38,Y) Q
..D FWD("ID",Y)
Q
; Return true if valid name
ISNAME(VALUE) ;
Q VALUE?1(1A,1"_",1":").(1AN,1".",1"-",1"_",1":")
; Return true if valid name token
ISNMTKN(VALUE) ;
Q VALUE?1.(1AN,1".",1"-",1"_",1":")
; Log a forward reference
FWD(TYPE,VALUE) ;
Q:'$L(VALUE)
Q:$D(^TMP(ID,$J,TYPE,VALUE))
N Z
S Z=$O(^TMP(ID,$J,"REF",TYPE,VALUE,""),-1)+1
M ^(Z)=ERR
Q
; Resolve forward reference
NOFWD(TYPE,VALUE) ;
K ^TMP(ID,$J,"REF",TYPE,VALUE)
Q
; Signal unresolved references
UNRESLV N X,Y,Z,E
F X=1:1:LVL D
.K ERR
.M ERR=LVL(X)
.D ERROR(8,LVL(X))
S X=""
F S X=$O(^TMP(ID,$J,"REF",X)),Y="" Q:'$L(X) D ; Look for IDREF w/o corresponding ID value
.S E=^(X)
.F S Y=$O(^TMP(ID,$J,"REF",X,Y)),Z=0 Q:'$L(Y) D
..F S Z=$O(^TMP(ID,$J,"REF",X,Y,Z)) Q:'Z D
...K ERR
...M ERR=^(Z)
...D ERROR(E,Y)
Q
; Log error
ERROR(X,Y) D ERROR^MXMLPRSE(.X,.Y) Q
; Predefined general entities
; Format=entity name;entity value
ENTITIES ;;amp;&
;;lt;<
;;gt;>
;;quot;"
;;apos;'
;;
; Callback events
; Format=#args;event type
CBKARGS ;;0;STARTDOCUMENT
;;0;ENDDOCUMENT
;;3;DOCTYPE
;;1;CHARACTERS
;;2;STARTELEMENT
;;1;ENDELEMENT
;;3;NOTATION
;;2;PI
;;1;COMMENT
;;3;EXTERNAL
;;1;ERROR
;;
; Prolog attributes
; Format=attribute name;val1;val2;...;valn
PROLOG ;;version;1.0
;;encoding;UTF-8;utf-8
;;standalone;no;yes
;;
; Recognized DTD tags
; Format=tag name;state
DTDTAG ;;ENTITY;20
;;ELEMENT;30
;;ATTLIST;40
;;NOTATION;50
;;[;60
;;
; Attribute types
; Format=identifier;type
TYPE ;;1;(
;;2;CDATA
;;3;NMTOKEN
;;4;NMTOKENS
;;5;ID
;;6;IDREF
;;7;IDREFS
;;8;NOTATION
;;9;ENTITY
;;10;ENTITIES
;;
; Default modifiers
; Format=identifier;modifier
MOD ;;1;#REQUIRED
;;2;#IMPLIED
;;3;#FIXED
;;
; Forward references
; Format=type;error #;type
REF ;;49;UNP
;;46;NOT
;;26;ELE
;;47;ID
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMXMLPRS1 4599 printed Sep 23, 2025@19:46:32 Page 2
MXMLPRS1 ;SAIC/DKM - XML Parser ;12/04/2002 15:55
+1 ;;7.3;TOOLKIT;**58,67**;Apr 25, 1995
+2 ;=================================================================
+3 ; Initialize tables
INIT NEW X,Y,Z
+1 FOR X=0:1
SET Y=$PIECE($TEXT(ENTITIES+X),";;",2,99)
if '$LENGTH(Y)
QUIT
Begin DoDot:1
+2 DO SETENT^MXMLPRSE($PIECE(Y,";"),$PIECE(Y,";",2,99))
End DoDot:1
+3 FOR X=0:1
SET Y=$PIECE($TEXT(DTDTAG+X),";;",2,99)
if '$LENGTH(Y)
QUIT
Begin DoDot:1
+4 SET DTD($PIECE(Y,";"))=$PIECE(Y,";",2)
End DoDot:1
+5 FOR X=0:1
SET Y=$PIECE($TEXT(TYPE+X),";;",2,99)
if '$LENGTH(Y)
QUIT
Begin DoDot:1
+6 SET ^TMP(ID,$JOB,"TYP",$PIECE(Y,";",2))=+Y
End DoDot:1
+7 FOR X=0:1
SET Y=$PIECE($TEXT(MOD+X),";;",2,99)
if '$LENGTH(Y)
QUIT
Begin DoDot:1
+8 SET ^TMP(ID,$JOB,"MOD",$PIECE(Y,";",2))=+Y
End DoDot:1
+9 FOR X=0:1
SET Y=$PIECE($TEXT(REF+X),";;",2,99)
if '$LENGTH(Y)
QUIT
Begin DoDot:1
+10 SET ^TMP(ID,$JOB,"REF",$PIECE(Y,";",2))=+Y
End DoDot:1
+11 FOR X=0:1
SET Y=$PIECE($TEXT(CBKARGS+X),";;",2,99)
if '$LENGTH(Y)
QUIT
Begin DoDot:1
+12 SET ^TMP(ID,$JOB,"CBK",$PIECE(Y,";",2))=+Y
End DoDot:1
+13 FOR X=0:1
SET Y=$PIECE($TEXT(PROLOG+X),";;",2,99)
if '$LENGTH(Y)
QUIT
Begin DoDot:1
+14 SET Z=$PIECE(Y,";")
SET ^TMP(ID,$JOB,"ATT","?xml",Z)="1^"_$SELECT('X:1,1:2)
+15 FOR
SET Y=$PIECE(Y,";",2,99)
if '$LENGTH(Y)
QUIT
SET ^TMP(ID,$JOB,"ATT","?xml",Z,$PIECE(Y,";"))=""
End DoDot:1
+16 QUIT
+17 ; Search parse tree for child element (CHILD) under parent element
+18 ; (ELEMENT) starting at specified node (NODE).
+19 ; Returns next node # in parse tree or 0
+20 ; If validation is disabled, the function always returns 1.
+21 ; If parent element is marked as EMPTY, 0 is returned.
+22 ; If parent element is marked as ANY, 1 is returned.
ISCHILD(ELEMENT,CHILD,NODE) ;
+1 NEW TRN
+2 SET TRN=+$GET(^TMP(ID,$JOB,"ELE",ELEMENT),2)
+3 QUIT $SELECT(OPTION'["V"!'NODE:1,TRN=1:CHILD="*",TRN=2:1,1:$$IC(NODE))
IC(NODE) NEW X,Y
+1 SET X=+$GET(^TMP(ID,$JOB,"ELE",ELEMENT,NODE,CHILD))
SET Y=0
+2 IF 'X
Begin DoDot:1
+3 FOR
SET Y=$ORDER(^TMP(ID,$JOB,"ELE",ELEMENT,NODE,Y))
if 'Y
QUIT
Begin DoDot:2
+4 if '$DATA(TRN(NODE,Y))
SET TRN(NODE,Y)=""
SET X=$$IC(Y)
End DoDot:2
if X
QUIT
End DoDot:1
+5 QUIT X
+6 ; Check attribute value for validity
CHKVAL(ENAME,ANAME,VALUE) ;
+1 NEW TYPE,X,Y,Z
+2 if '$LENGTH(VALUE)
QUIT
+3 IF $DATA(^TMP(ID,$JOB,"ATT",ENAME,ANAME))>1
if '$DATA(^(ANAME,VALUE))
DO ERROR(38,VALUE)
QUIT
+4 SET TYPE=+$GET(^TMP(ID,$JOB,"ATT",ENAME,ANAME))
+5 if 'TYPE
QUIT
+6 ; ID type
IF TYPE=5
Begin DoDot:1
+7 IF '$$ISNAME(VALUE)
DO ERROR(38,VALUE)
QUIT
+8 IF '$DATA(^TMP(ID,$JOB,"ID",VALUE))
Begin DoDot:2
+9 SET ^(VALUE)=""
+10 DO NOFWD("ID",VALUE)
End DoDot:2
+11 IF '$TEST
DO ERROR(28,VALUE)
End DoDot:1
QUIT
+12 ; ENTITY/ENTITIES type
IF TYPE=9!(TYPE=10)
Begin DoDot:1
+13 SET X=$SELECT(TYPE=9:" ",1:" ")
+14 FOR Z=1:1:$LENGTH(VALUE,X)
DO FWD("UNP",$PIECE(VALUE,X,Z))
End DoDot:1
QUIT
+15 ; NMTOKEN/NMTOKENS type
IF TYPE=3!(TYPE=4)
Begin DoDot:1
+16 SET X=$SELECT(TYPE=3:" ",1:" ")
+17 FOR Z=1:1:$LENGTH(VALUE,X)
Begin DoDot:2
+18 SET Y=$PIECE(VALUE,X,Z)
+19 if '$$ISNMTKN(Y)
DO ERROR(38,Y)
End DoDot:2
End DoDot:1
QUIT
+20 ; IDREF/IDREFS type
IF TYPE=6!(TYPE=7)
Begin DoDot:1
+21 SET X=$SELECT(TYPE=6:" ",1:" ")
+22 FOR Z=1:1:$LENGTH(VALUE,X)
Begin DoDot:2
+23 SET Y=$PIECE(VALUE,X,Z)
+24 IF '$$ISNAME(Y)
DO ERROR(38,Y)
QUIT
+25 DO FWD("ID",Y)
End DoDot:2
End DoDot:1
QUIT
+26 QUIT
+27 ; Return true if valid name
ISNAME(VALUE) ;
+1 QUIT VALUE?1(1A,1"_",1":").(1AN,1".",1"-",1"_",1":")
+2 ; Return true if valid name token
ISNMTKN(VALUE) ;
+1 QUIT VALUE?1.(1AN,1".",1"-",1"_",1":")
+2 ; Log a forward reference
FWD(TYPE,VALUE) ;
+1 if '$LENGTH(VALUE)
QUIT
+2 if $DATA(^TMP(ID,$JOB,TYPE,VALUE))
QUIT
+3 NEW Z
+4 SET Z=$ORDER(^TMP(ID,$JOB,"REF",TYPE,VALUE,""),-1)+1
+5 MERGE ^(Z)=ERR
+6 QUIT
+7 ; Resolve forward reference
NOFWD(TYPE,VALUE) ;
+1 KILL ^TMP(ID,$JOB,"REF",TYPE,VALUE)
+2 QUIT
+3 ; Signal unresolved references
UNRESLV NEW X,Y,Z,E
+1 FOR X=1:1:LVL
Begin DoDot:1
+2 KILL ERR
+3 MERGE ERR=LVL(X)
+4 DO ERROR(8,LVL(X))
End DoDot:1
+5 SET X=""
+6 ; Look for IDREF w/o corresponding ID value
FOR
SET X=$ORDER(^TMP(ID,$JOB,"REF",X))
SET Y=""
if '$LENGTH(X)
QUIT
Begin DoDot:1
+7 SET E=^(X)
+8 FOR
SET Y=$ORDER(^TMP(ID,$JOB,"REF",X,Y))
SET Z=0
if '$LENGTH(Y)
QUIT
Begin DoDot:2
+9 FOR
SET Z=$ORDER(^TMP(ID,$JOB,"REF",X,Y,Z))
if 'Z
QUIT
Begin DoDot:3
+10 KILL ERR
+11 MERGE ERR=^(Z)
+12 DO ERROR(E,Y)
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ; Log error
ERROR(X,Y) DO ERROR^MXMLPRSE(.X,.Y)
QUIT
+1 ; Predefined general entities
+2 ; Format=entity name;entity value
ENTITIES ;;amp;&
+1 ;;lt;<
+2 ;;gt;>
+3 ;;quot;"
+4 ;;apos;'
+5 ;;
+6 ; Callback events
+7 ; Format=#args;event type
CBKARGS ;;0;STARTDOCUMENT
+1 ;;0;ENDDOCUMENT
+2 ;;3;DOCTYPE
+3 ;;1;CHARACTERS
+4 ;;2;STARTELEMENT
+5 ;;1;ENDELEMENT
+6 ;;3;NOTATION
+7 ;;2;PI
+8 ;;1;COMMENT
+9 ;;3;EXTERNAL
+10 ;;1;ERROR
+11 ;;
+12 ; Prolog attributes
+13 ; Format=attribute name;val1;val2;...;valn
PROLOG ;;version;1.0
+1 ;;encoding;UTF-8;utf-8
+2 ;;standalone;no;yes
+3 ;;
+4 ; Recognized DTD tags
+5 ; Format=tag name;state
DTDTAG ;;ENTITY;20
+1 ;;ELEMENT;30
+2 ;;ATTLIST;40
+3 ;;NOTATION;50
+4 ;;[;60
+5 ;;
+6 ; Attribute types
+7 ; Format=identifier;type
TYPE ;;1;(
+1 ;;2;CDATA
+2 ;;3;NMTOKEN
+3 ;;4;NMTOKENS
+4 ;;5;ID
+5 ;;6;IDREF
+6 ;;7;IDREFS
+7 ;;8;NOTATION
+8 ;;9;ENTITY
+9 ;;10;ENTITIES
+10 ;;
+11 ; Default modifiers
+12 ; Format=identifier;modifier
MOD ;;1;#REQUIRED
+1 ;;2;#IMPLIED
+2 ;;3;#FIXED
+3 ;;
+4 ; Forward references
+5 ; Format=type;error #;type
REF ;;49;UNP
+1 ;;46;NOT
+2 ;;26;ELE
+3 ;;47;ID
+4 ;;
