VPRHST1 ;SLC/KCM,MKB - Display XML object ;09/18/18 4:36pm
;;1.0;VIRTUAL PATIENT RECORD;**8,25,27**;Sep 01, 2011;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
XML(OBJ) ; -- display XML OBJect in hierarchy, returns DONE if ^
N XSTRING,ORSTK,ORNXT,ORCNT K DONE,QUIT
S XSTRING=$G(OBJ) Q:'$L(XSTRING)
S ORSTK=-1,ORCNT=0 D OPEN
;
F S ORNXT=$E(XSTRING,1,2) D @$S(ORNXT="</":"CLOSE",ORNXT?1"<"1.A.E:"OPEN",1:"XDATA") Q:XSTRING="" Q:$G(DONE)
Q
;
OPEN ; -- opening tag
N TAG S TAG=$P(XSTRING,">")_">",XSTRING=$E(XSTRING,$L(TAG)+1,999999999)
S ORCNT=ORCNT+1 I ORCNT>(IOSL-4) D READ Q:$G(DONE) S ORCNT=1
S ORSTK=ORSTK+1 W !,?((ORSTK*2)),TAG
Q
;
XDATA ; -- data + closing tag
N DATA,TAG
S DATA=$P(XSTRING,"</") W DATA
S XSTRING=$E(XSTRING,$L(DATA)+1,999999999)
S TAG=$P(XSTRING,">")_">" W TAG
S XSTRING=$E(XSTRING,$L(TAG)+1,999999999),ORSTK=ORSTK-1
Q
;
CLOSE ; -- closing tag, pop stack
N TAG S TAG=$P(XSTRING,">")_">",XSTRING=$E(XSTRING,$L(TAG)+1,999999999)
S ORCNT=ORCNT+1 I ORCNT>(IOSL-4) D READ Q:$G(DONE) S ORCNT=1
W !,?((ORSTK*2)),TAG S ORSTK=ORSTK-1
Q
;
READ ; -- continue?
N X K DONE,QUIT
R1 W !!,"Press <return> to continue or ^ to exit item ..." R X:DTIME
I X["?" W !,"Enter ^ to skip the rest of this item, or ^^ to exit the option." G R1
S:X["^" DONE=1 S:X["^^" QUIT=1
Q
;
JSON(OBJ) ; -- display JSON OBJect in hierarchy, returns DONE if ^
N XSTRING,ORSTK,ORNXT,ORCNT
S XSTRING=$G(OBJ) Q:'$L(XSTRING)
S ORSTK=-1,ORCNT=0
;
F D TAG S ORNXT=$E(XSTRING) D @$S(ORNXT="{":"BRACE",ORNXT="[":"LIST",1:"JDATA") Q:XSTRING="" Q:$G(DONE)
Q
;
TAG ; -- display tag
N TAG S TAG=$P(XSTRING,":")_":",XSTRING=$E(XSTRING,$L(TAG)+1,999999999)
S ORCNT=ORCNT+1 I ORCNT>(IOSL-4) D READ Q:$G(DONE) S ORCNT=1
S ORSTK=ORSTK+1 W !,?((ORSTK*2)),TAG
Q
;
BRACE ; -- braces
W "{"
S XSTRING=$E(XSTRING,2,999999999)
Q
;
LIST ; -- list
W "["
S XSTRING=$E(XSTRING,2,999999999)
; ??
Q
;
JDATA ; -- display value, pop stack
N X,I S X=$P(XSTRING,", ")
S:$E(XSTRING,$L(X)+1,$L(X)+2)=", " X=X_", "
S XSTRING=$E(XSTRING,$L(X)+1,999999999)
W X S ORSTK=ORSTK-1
; pop stack one more time for every closing brace
F I=1:1:$L(X) I $E(X,I)="}" S ORSTK=ORSTK-1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRHST1 2280 printed Apr 09, 2024@21:48 Page 2
VPRHST1 ;SLC/KCM,MKB - Display XML object ;09/18/18 4:36pm
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,25,27**;Sep 01, 2011;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
XML(OBJ) ; -- display XML OBJect in hierarchy, returns DONE if ^
+1 NEW XSTRING,ORSTK,ORNXT,ORCNT
KILL DONE,QUIT
+2 SET XSTRING=$GET(OBJ)
if '$LENGTH(XSTRING)
QUIT
+3 SET ORSTK=-1
SET ORCNT=0
DO OPEN
+4 ;
+5 FOR
SET ORNXT=$EXTRACT(XSTRING,1,2)
DO @$SELECT(ORNXT="</":"CLOSE",ORNXT?1"<"1.A.E:"OPEN",1:"XDATA")
if XSTRING=""
QUIT
if $GET(DONE)
QUIT
+6 QUIT
+7 ;
OPEN ; -- opening tag
+1 NEW TAG
SET TAG=$PIECE(XSTRING,">")_">"
SET XSTRING=$EXTRACT(XSTRING,$LENGTH(TAG)+1,999999999)
+2 SET ORCNT=ORCNT+1
IF ORCNT>(IOSL-4)
DO READ
if $GET(DONE)
QUIT
SET ORCNT=1
+3 SET ORSTK=ORSTK+1
WRITE !,?((ORSTK*2)),TAG
+4 QUIT
+5 ;
XDATA ; -- data + closing tag
+1 NEW DATA,TAG
+2 SET DATA=$PIECE(XSTRING,"</")
WRITE DATA
+3 SET XSTRING=$EXTRACT(XSTRING,$LENGTH(DATA)+1,999999999)
+4 SET TAG=$PIECE(XSTRING,">")_">"
WRITE TAG
+5 SET XSTRING=$EXTRACT(XSTRING,$LENGTH(TAG)+1,999999999)
SET ORSTK=ORSTK-1
+6 QUIT
+7 ;
CLOSE ; -- closing tag, pop stack
+1 NEW TAG
SET TAG=$PIECE(XSTRING,">")_">"
SET XSTRING=$EXTRACT(XSTRING,$LENGTH(TAG)+1,999999999)
+2 SET ORCNT=ORCNT+1
IF ORCNT>(IOSL-4)
DO READ
if $GET(DONE)
QUIT
SET ORCNT=1
+3 WRITE !,?((ORSTK*2)),TAG
SET ORSTK=ORSTK-1
+4 QUIT
+5 ;
READ ; -- continue?
+1 NEW X
KILL DONE,QUIT
R1 WRITE !!,"Press <return> to continue or ^ to exit item ..."
READ X:DTIME
+1 IF X["?"
WRITE !,"Enter ^ to skip the rest of this item, or ^^ to exit the option."
GOTO R1
+2 if X["^"
SET DONE=1
if X["^^"
SET QUIT=1
+3 QUIT
+4 ;
JSON(OBJ) ; -- display JSON OBJect in hierarchy, returns DONE if ^
+1 NEW XSTRING,ORSTK,ORNXT,ORCNT
+2 SET XSTRING=$GET(OBJ)
if '$LENGTH(XSTRING)
QUIT
+3 SET ORSTK=-1
SET ORCNT=0
+4 ;
+5 FOR
DO TAG
SET ORNXT=$EXTRACT(XSTRING)
DO @$SELECT(ORNXT="{":"BRACE",ORNXT="[":"LIST",1:"JDATA")
if XSTRING=""
QUIT
if $GET(DONE)
QUIT
+6 QUIT
+7 ;
TAG ; -- display tag
+1 NEW TAG
SET TAG=$PIECE(XSTRING,":")_":"
SET XSTRING=$EXTRACT(XSTRING,$LENGTH(TAG)+1,999999999)
+2 SET ORCNT=ORCNT+1
IF ORCNT>(IOSL-4)
DO READ
if $GET(DONE)
QUIT
SET ORCNT=1
+3 SET ORSTK=ORSTK+1
WRITE !,?((ORSTK*2)),TAG
+4 QUIT
+5 ;
BRACE ; -- braces
+1 WRITE "{"
+2 SET XSTRING=$EXTRACT(XSTRING,2,999999999)
+3 QUIT
+4 ;
LIST ; -- list
+1 WRITE "["
+2 SET XSTRING=$EXTRACT(XSTRING,2,999999999)
+3 ; ??
+4 QUIT
+5 ;
JDATA ; -- display value, pop stack
+1 NEW X,I
SET X=$PIECE(XSTRING,", ")
+2 if $EXTRACT(XSTRING,$LENGTH(X)+1,$LENGTH(X)+2)=", "
SET X=X_", "
+3 SET XSTRING=$EXTRACT(XSTRING,$LENGTH(X)+1,999999999)
+4 WRITE X
SET ORSTK=ORSTK-1
+5 ; pop stack one more time for every closing brace
+6 FOR I=1:1:$LENGTH(X)
IF $EXTRACT(X,I)="}"
SET ORSTK=ORSTK-1
+7 QUIT
