VPRJSOND ;SLC/KCM -- Decode JSON
;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
;
DECODE(VVJSON,VVROOT,VVERR) ; Set JSON object into closed array ref VVROOT
;
DIRECT ; TAG for use by DECODE^VPRJSON
;
; Examples: D DECODE^VPRJSON("MYJSON","LOCALVAR","LOCALERR")
; D DECODE^VPRJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
;
; VVJSON: string/array containing serialized JSON object
; VVROOT: closed array reference for M representation of object
; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
;
; VVIDX: points to next character in JSON string to process
; VVSTACK: manages stack of subscripts
; VVPROP: true if next string is property name, otherwise treat as value
;
N VVMAX S VVMAX=4000 ; limit document lines to 4000 characters
S VVERR=$G(VVERR,"^TMP(""VPRJERR"",$J)")
; If a simple string is passed in, move it to an temp array (VVINPUT)
; so that the processing is consistently on an array.
I $D(@VVJSON)=1 N VVINPUT S VVINPUT(1)=@VVJSON,VVJSON="VVINPUT"
S VVROOT=$NA(@VVROOT@("Z")),VVROOT=$E(VVROOT,1,$L(VVROOT)-4) ; make open array ref
N VVLINE,VVIDX,VVSTACK,VVPROP,VVTYPE,VVERRORS
S VVLINE=$O(@VVJSON@("")),VVIDX=1,VVSTACK=0,VVPROP=0,VVERRORS=0
F S VVTYPE=$$NXTKN() Q:VVTYPE="" D I VVERRORS Q
. I VVTYPE="{" S VVSTACK=VVSTACK+1,VVSTACK(VVSTACK)="",VVPROP=1 D:VVSTACK>64 ERRX("STL{") Q
. I VVTYPE="}" D:VVSTACK(VVSTACK) ERRX("OBM") S VVSTACK=VVSTACK-1 D:VVSTACK<0 ERRX("SUF}") Q
. I VVTYPE="[" S VVSTACK=VVSTACK+1,VVSTACK(VVSTACK)=1 D:VVSTACK>64 ERRX("STL[") Q
. I VVTYPE="]" D:'VVSTACK(VVSTACK) ERRX("ARM") S VVSTACK=VVSTACK-1 D:VVSTACK<0 ERRX("SUF]") Q
. I VVTYPE="," D Q
. . I VVSTACK(VVSTACK) S VVSTACK(VVSTACK)=VVSTACK(VVSTACK)+1 ; next in array
. . E S VVPROP=1 ; or next property name
. I VVTYPE=":" S VVPROP=0 D:'$L($G(VVSTACK(VVSTACK))) ERRX("MPN") Q
. I VVTYPE="""" D Q
. . I VVPROP S VVSTACK(VVSTACK)=$$NAMPARS() I 1
. . E D ADDSTR
. S VVTYPE=$TR(VVTYPE,"TFN","tfn")
. I VVTYPE="t" D SETBOOL("t") Q
. I VVTYPE="f" D SETBOOL("f") Q
. I VVTYPE="n" D SETBOOL("n") Q
. I "0123456789+-.eE"[VVTYPE S @$$CURNODE()=$$NUMPARS(VVTYPE) Q
. D ERRX("TKN",VVTYPE)
I VVSTACK'=0 D ERRX("SCT",VVSTACK)
Q
NXTKN() ; Move the pointers to the beginning of the next token
N VVDONE,VVEOF,VVTOKEN
S VVDONE=0,VVEOF=0 F D Q:VVDONE!VVEOF ; eat spaces & new lines until next visible char
. I VVIDX>$L(@VVJSON@(VVLINE)) S VVLINE=$O(@VVJSON@(VVLINE)),VVIDX=1 I 'VVLINE S VVEOF=1 Q
. I $A(@VVJSON@(VVLINE),VVIDX)>32 S VVDONE=1 Q
. S VVIDX=VVIDX+1
Q:VVEOF "" ; we're at the end of input
S VVTOKEN=$E(@VVJSON@(VVLINE),VVIDX),VVIDX=VVIDX+1
Q VVTOKEN
;
ADDSTR ; Add string value to current node, escaping text along the way
; Expects VVLINE,VVIDX to reference that starting point of the index
; TODO: add a mechanism to specify names that should not be escaped
; just store as ":")= and ":",n)=
;
; Happy path -- we find the end quote in the same line
N VVEND,VVX
S VVEND=$F(@VVJSON@(VVLINE),"""",VVIDX)
I VVEND,($E(@VVJSON@(VVLINE),VVEND-2)'="\") D SETSTR QUIT ;normal
I VVEND,$$ISCLOSEQ(VVLINE) D SETSTR QUIT ;close quote preceded by escaped \
;
; Less happy path -- first quote wasn't close quote
N VVDONE,VVTLINE
S VVDONE=0,VVTLINE=VVLINE ; VVTLINE for temporary increment of VVLINE
F D Q:VVDONE Q:VVERRORS
. ;if no quote on current line advance line, scan again
. I 'VVEND S VVTLINE=VVTLINE+1,VVEND=1 I '$D(@VVJSON@(VVTLINE)) D ERRX("EIQ") Q
. S VVEND=$F(@VVJSON@(VVTLINE),"""",VVEND)
. Q:'VVEND ; continue on to next line if no quote found on this one
. I (VVEND>2),($E(@VVJSON@(VVTLINE),VVEND-2)'="\") S VVDONE=1 Q ; found quote position
. S VVDONE=$$ISCLOSEQ(VVTLINE) ; see if this is an escaped quote or closing quote
Q:VVERRORS
; unescape from VVIDX to VVEND, using \-extension nodes as necessary
D UESEXT
; now we need to move VVLINE and VVIDX to next parsing point
S VVLINE=VVTLINE,VVIDX=VVEND
Q
SETSTR ; Set simple string value from within same line
; expects VVJSON, VVLINE, VVINX, VVEND
N VVX
S VVX=$E(@VVJSON@(VVLINE),VVIDX,VVEND-2),VVIDX=VVEND
S @$$CURNODE()=$$UES(VVX)
I (+VVX=VVX)!($E(VVX,1,2)="0.")!($E(VVX,1,3)="-0.") S @$$CURNODE()@("\s")=""
I VVIDX>$L(@VVJSON@(VVLINE)) S VVLINE=VVLINE+1,VVIDX=1
Q
UESEXT ; unescape from VVLINE,VVIDX to VVTLINE,VVEND & extend (\) if necessary
; expects VVLINE,VVIDX,VVTLINE,VVEND
N VVI,VVY,VVSTART,VVSTOP,VVDONE,VVBUF,VVNODE,VVMORE,VVTO
S VVNODE=$$CURNODE(),VVBUF="",VVMORE=0,VVSTOP=VVEND-2
S VVI=VVIDX,VVY=VVLINE,VVDONE=0
F D Q:VVDONE Q:VVERRORS
. S VVSTART=VVI,VVI=$F(@VVJSON@(VVY),"\",VVI)
. ; if we are on the last line, don't extract past VVSTOP
. I (VVY=VVTLINE) S VVTO=$S('VVI:VVSTOP,VVI>VVSTOP:VVSTOP,1:VVI-2) I 1
. E S VVTO=$S('VVI:99999,1:VVI-2)
. D ADDBUF($E(@VVJSON@(VVY),VVSTART,VVTO))
. I (VVY'<VVTLINE),(('VVI)!(VVI>VVSTOP)) S VVDONE=1 QUIT ; now past close quote
. I 'VVI S VVY=VVY+1,VVI=1 QUIT ; nothing escaped, go to next line
. I VVI>$L(@VVJSON@(VVY)) S VVY=VVY+1,VVI=1 I '$D(@VVJSON@(VVY)) D ERRX("EIU")
. N VVTGT S VVTGT=$E(@VVJSON@(VVY),VVI)
. I VVTGT="u" D I 1
. . N VVTGTC S VVTGTC=$E(@VVJSON@(VVY),VVI+1,VVI+4),VVI=VVI+4
. . I $L(VVTGTC)<4 S VVY=VVY+1,VVI=4-$L(VVTGTC),VVTGTC=VVTGTC_$E(@VVJSON@(VVY),1,VVI)
. . D ADDBUF($C($$DEC^XLFUTL(VVTGTC,16)))
. E D ADDBUF($$REALCHAR(VVTGT))
. S VVI=VVI+1
. I (VVY'<VVTLINE),(VVI>VVSTOP) S VVDONE=1 ; VVI incremented past stop
Q:VVERRORS
D SAVEBUF
Q
ADDBUF(VVX) ; add buffer of characters to destination
; expects VVBUF,VVMAX,VVNODE,VVMORE to be defined
; used directly by ADDSTR
I $L(VVX)+$L(VVBUF)>VVMAX D SAVEBUF
S VVBUF=VVBUF_VVX
Q
SAVEBUF ; write out buffer to destination
; expects VVBUF,VVMAX,VVNODE,VVMORE to be defined
; used directly by ADDSTR,ADDBUF
I VVMORE S @VVNODE@("\",VVMORE)=VVBUF
I 'VVMORE S @VVNODE=VVBUF I $L(VVBUF)<19,+$E(VVBUF,1,18) S @VVNODE@("\s")=""
S VVMORE=VVMORE+1,VVBUF=""
Q
ISCLOSEQ(VVBLINE) ; return true if this is a closing, rather than escaped, quote
; expects
; VVJSON: lines of the JSON encoded string
; VVIDX: points to 1st character of the segment
; VVLINE: points to the line in which the segment starts
; VVEND: points to 1st character after the " (may be past the end of the line)
; used directly by ADDSTR
N VVBS,VVBIDX,VVBDONE
S VVBS=0,VVBIDX=VVEND-2,VVBDONE=0 ; VVBIDX starts at 1st character before quote
; count the backslashes preceding the quote (odd number means the quote was escaped)
F D Q:VVBDONE!VVERRORS
. I VVBIDX<1 D Q ; when VVBIDX<1 go back a line
. . S VVBLINE=VVBLINE-1 I VVBLINE<VVLINE D ERRX("RSB") Q
. . S VVBIDX=$L(@VVJSON@(VVBLINE))
. I $E(@VVJSON@(VVBLINE),VVBIDX)'="\" S VVBDONE=1 Q
. S VVBS=VVBS+1,VVBIDX=VVBIDX-1
Q VVBS#2=0 ; VVBS is even if this is a close quote
;
NAMPARS() ; Return parsed name, advancing index past the close quote
; -- This assumes no embedded quotes are in the name itself --
N VVEND,VVDONE,VVNAME
S VVDONE=0,VVNAME=""
F D Q:VVDONE Q:VVERRORS
. S VVEND=$F(@VVJSON@(VVLINE),"""",VVIDX)
. I VVEND S VVNAME=VVNAME_$E(@VVJSON@(VVLINE),VVIDX,VVEND-2),VVIDX=VVEND,VVDONE=1
. I 'VVEND S VVNAME=VVNAME_$E(@VVJSON@(VVLINE),VVIDX,$L(@VVJSON@(VVLINE)))
. I 'VVEND!(VVEND>$L(@VVJSON@(VVLINE))) S VVLINE=VVLINE+1,VVIDX=1 I '$D(@VVJSON@(VVLINE)) D ERRX("ORN")
Q VVNAME
;
NUMPARS(VVDIGIT) ; Return parsed number, advancing index past the end of the number
; VVIDX intially references the second digit
N VVDONE,VVNUM
S VVDONE=0,VVNUM=VVDIGIT
F D Q:VVDONE Q:VVERRORS
. I '("0123456789+-.eE"[$E(@VVJSON@(VVLINE),VVIDX)) S VVDONE=1 Q
. S VVNUM=VVNUM_$E(@VVJSON@(VVLINE),VVIDX)
. S VVIDX=VVIDX+1 I VVIDX>$L(@VVJSON@(VVLINE)) S VVLINE=VVLINE+1,VVIDX=1 I '$D(@VVJSON@(VVLINE)) D ERRX("OR#")
Q VVNUM
;
SETBOOL(VVLTR) ; Return parsed value, advancing index past the end of the value
N VVDONE,VVBOOL,VVX
S VVDONE=0,VVBOOL=VVLTR
F D Q:VVDONE Q:VVERRORS
. S VVX=$TR($E(@VVJSON@(VVLINE),VVIDX),"TRUEFALSN","truefalsn")
. I '("truefalsn"[VVX) S VVDONE=1 Q
. S VVBOOL=VVBOOL_VVX
. S VVIDX=VVIDX+1 I VVIDX>$L(@VVJSON@(VVLINE)) S VVLINE=VVLINE+1,VVIDX=1 I '$D(@VVJSON@(VVLINE)) D ERRX("ORB")
I VVLTR="t",(VVBOOL'="true") D ERRX("EXT",VVTYPE)
I VVLTR="f",(VVBOOL'="false") D ERRX("EXF",VVTYPE)
I VVLTR="n",(VVBOOL'="null") D ERRX("EXN",VVTYPE)
S @$$CURNODE()=VVBOOL
Q
;
OSETBOOL(VVX) ; set a value and increment VVIDX
S @$$CURNODE()=VVX
S VVIDX=VVIDX+$L(VVX)-1
N VVDIFF S VVDIFF=VVIDX-$L(@VVJSON@(VVLINE)) ; in case VVIDX moves to next line
I VVDIFF>0 S VVLINE=VVLINE+1,VVIDX=VVDIFF I '$D(@VVJSON@(VVLINE)) D ERRX("ORB")
Q
CURNODE() ; Return a global/local variable name based on VVSTACK
; Expects VVSTACK to be defined already
N VVI,VVSUBS
S VVSUBS=""
F VVI=1:1:VVSTACK S:VVI>1 VVSUBS=VVSUBS_"," D
. I VVSTACK(VVI) S VVSUBS=VVSUBS_VVSTACK(VVI)
. E S VVSUBS=VVSUBS_""""_VVSTACK(VVI)_""""
Q VVROOT_VVSUBS_")"
;
UES(X) ; Unescape JSON string
; copy segments from START to POS-2 (right before \)
; translate target character (which is at $F position)
N POS,Y,START
S POS=0,Y=""
F S START=POS+1 D Q:START>$L(X)
. S POS=$F(X,"\",START) ; find next position
. I 'POS S Y=Y_$E(X,START,$L(X)),POS=$L(X) Q
. ; otherwise handle escaped char
. N TGT
. S TGT=$E(X,POS),Y=Y_$E(X,START,POS-2)
. I TGT="u" S Y=Y_$C($$DEC^XLFUTL($E(X,POS+1,POS+4),16)),POS=POS+4 Q
. S Y=Y_$$REALCHAR(TGT)
Q Y
;
REALCHAR(C) ; Return actual character from escaped
I C="""" Q """"
I C="/" Q "/"
I C="\" Q "\"
I C="b" Q $C(8)
I C="f" Q $C(12)
I C="n" Q $C(10)
I C="r" Q $C(13)
I C="t" Q $C(9)
I C="u" ;case covered above in $$DEC^XLFUTL calls
;otherwise
I $L($G(VVERR)) D ERRX("ESC",C)
Q C
;
ERRX(ID,VAL) ; Set the appropriate error message
D ERRX^VPRJSON(ID,$G(VAL))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRJSOND 9970 printed Dec 13, 2024@02:45:24 Page 2
VPRJSOND ;SLC/KCM -- Decode JSON
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
+2 ;
DECODE(VVJSON,VVROOT,VVERR) ; Set JSON object into closed array ref VVROOT
+1 ;
DIRECT ; TAG for use by DECODE^VPRJSON
+1 ;
+2 ; Examples: D DECODE^VPRJSON("MYJSON","LOCALVAR","LOCALERR")
+3 ; D DECODE^VPRJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
+4 ;
+5 ; VVJSON: string/array containing serialized JSON object
+6 ; VVROOT: closed array reference for M representation of object
+7 ; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
+8 ;
+9 ; VVIDX: points to next character in JSON string to process
+10 ; VVSTACK: manages stack of subscripts
+11 ; VVPROP: true if next string is property name, otherwise treat as value
+12 ;
+13 ; limit document lines to 4000 characters
NEW VVMAX
SET VVMAX=4000
+14 SET VVERR=$GET(VVERR,"^TMP(""VPRJERR"",$J)")
+15 ; If a simple string is passed in, move it to an temp array (VVINPUT)
+16 ; so that the processing is consistently on an array.
+17 IF $DATA(@VVJSON)=1
NEW VVINPUT
SET VVINPUT(1)=@VVJSON
SET VVJSON="VVINPUT"
+18 ; make open array ref
SET VVROOT=$NAME(@VVROOT@("Z"))
SET VVROOT=$EXTRACT(VVROOT,1,$LENGTH(VVROOT)-4)
+19 NEW VVLINE,VVIDX,VVSTACK,VVPROP,VVTYPE,VVERRORS
+20 SET VVLINE=$ORDER(@VVJSON@(""))
SET VVIDX=1
SET VVSTACK=0
SET VVPROP=0
SET VVERRORS=0
+21 FOR
SET VVTYPE=$$NXTKN()
if VVTYPE=""
QUIT
Begin DoDot:1
+22 IF VVTYPE="{"
SET VVSTACK=VVSTACK+1
SET VVSTACK(VVSTACK)=""
SET VVPROP=1
if VVSTACK>64
DO ERRX("STL{")
QUIT
+23 IF VVTYPE="}"
if VVSTACK(VVSTACK)
DO ERRX("OBM")
SET VVSTACK=VVSTACK-1
if VVSTACK<0
DO ERRX("SUF}")
QUIT
+24 IF VVTYPE="["
SET VVSTACK=VVSTACK+1
SET VVSTACK(VVSTACK)=1
if VVSTACK>64
DO ERRX("STL[")
QUIT
+25 IF VVTYPE="]"
if 'VVSTACK(VVSTACK)
DO ERRX("ARM")
SET VVSTACK=VVSTACK-1
if VVSTACK<0
DO ERRX("SUF]")
QUIT
+26 IF VVTYPE=","
Begin DoDot:2
+27 ; next in array
IF VVSTACK(VVSTACK)
SET VVSTACK(VVSTACK)=VVSTACK(VVSTACK)+1
+28 ; or next property name
IF '$TEST
SET VVPROP=1
End DoDot:2
QUIT
+29 IF VVTYPE=":"
SET VVPROP=0
if '$LENGTH($GET(VVSTACK(VVSTACK)))
DO ERRX("MPN")
QUIT
+30 IF VVTYPE=""""
Begin DoDot:2
+31 IF VVPROP
SET VVSTACK(VVSTACK)=$$NAMPARS()
IF 1
+32 IF '$TEST
DO ADDSTR
End DoDot:2
QUIT
+33 SET VVTYPE=$TRANSLATE(VVTYPE,"TFN","tfn")
+34 IF VVTYPE="t"
DO SETBOOL("t")
QUIT
+35 IF VVTYPE="f"
DO SETBOOL("f")
QUIT
+36 IF VVTYPE="n"
DO SETBOOL("n")
QUIT
+37 IF "0123456789+-.eE"[VVTYPE
SET @$$CURNODE()=$$NUMPARS(VVTYPE)
QUIT
+38 DO ERRX("TKN",VVTYPE)
End DoDot:1
IF VVERRORS
QUIT
+39 IF VVSTACK'=0
DO ERRX("SCT",VVSTACK)
+40 QUIT
NXTKN() ; Move the pointers to the beginning of the next token
+1 NEW VVDONE,VVEOF,VVTOKEN
+2 ; eat spaces & new lines until next visible char
SET VVDONE=0
SET VVEOF=0
FOR
Begin DoDot:1
+3 IF VVIDX>$LENGTH(@VVJSON@(VVLINE))
SET VVLINE=$ORDER(@VVJSON@(VVLINE))
SET VVIDX=1
IF 'VVLINE
SET VVEOF=1
QUIT
+4 IF $ASCII(@VVJSON@(VVLINE),VVIDX)>32
SET VVDONE=1
QUIT
+5 SET VVIDX=VVIDX+1
End DoDot:1
if VVDONE!VVEOF
QUIT
+6 ; we're at the end of input
if VVEOF
QUIT ""
+7 SET VVTOKEN=$EXTRACT(@VVJSON@(VVLINE),VVIDX)
SET VVIDX=VVIDX+1
+8 QUIT VVTOKEN
+9 ;
ADDSTR ; Add string value to current node, escaping text along the way
+1 ; Expects VVLINE,VVIDX to reference that starting point of the index
+2 ; TODO: add a mechanism to specify names that should not be escaped
+3 ; just store as ":")= and ":",n)=
+4 ;
+5 ; Happy path -- we find the end quote in the same line
+6 NEW VVEND,VVX
+7 SET VVEND=$FIND(@VVJSON@(VVLINE),"""",VVIDX)
+8 ;normal
IF VVEND
IF ($EXTRACT(@VVJSON@(VVLINE),VVEND-2)'="\")
DO SETSTR
QUIT
+9 ;close quote preceded by escaped \
IF VVEND
IF $$ISCLOSEQ(VVLINE)
DO SETSTR
QUIT
+10 ;
+11 ; Less happy path -- first quote wasn't close quote
+12 NEW VVDONE,VVTLINE
+13 ; VVTLINE for temporary increment of VVLINE
SET VVDONE=0
SET VVTLINE=VVLINE
+14 FOR
Begin DoDot:1
+15 ;if no quote on current line advance line, scan again
+16 IF 'VVEND
SET VVTLINE=VVTLINE+1
SET VVEND=1
IF '$DATA(@VVJSON@(VVTLINE))
DO ERRX("EIQ")
QUIT
+17 SET VVEND=$FIND(@VVJSON@(VVTLINE),"""",VVEND)
+18 ; continue on to next line if no quote found on this one
if 'VVEND
QUIT
+19 ; found quote position
IF (VVEND>2)
IF ($EXTRACT(@VVJSON@(VVTLINE),VVEND-2)'="\")
SET VVDONE=1
QUIT
+20 ; see if this is an escaped quote or closing quote
SET VVDONE=$$ISCLOSEQ(VVTLINE)
End DoDot:1
if VVDONE
QUIT
if VVERRORS
QUIT
+21 if VVERRORS
QUIT
+22 ; unescape from VVIDX to VVEND, using \-extension nodes as necessary
+23 DO UESEXT
+24 ; now we need to move VVLINE and VVIDX to next parsing point
+25 SET VVLINE=VVTLINE
SET VVIDX=VVEND
+26 QUIT
SETSTR ; Set simple string value from within same line
+1 ; expects VVJSON, VVLINE, VVINX, VVEND
+2 NEW VVX
+3 SET VVX=$EXTRACT(@VVJSON@(VVLINE),VVIDX,VVEND-2)
SET VVIDX=VVEND
+4 SET @$$CURNODE()=$$UES(VVX)
+5 IF (+VVX=VVX)!($EXTRACT(VVX,1,2)="0.")!($EXTRACT(VVX,1,3)="-0.")
SET @$$CURNODE()@("\s")=""
+6 IF VVIDX>$LENGTH(@VVJSON@(VVLINE))
SET VVLINE=VVLINE+1
SET VVIDX=1
+7 QUIT
UESEXT ; unescape from VVLINE,VVIDX to VVTLINE,VVEND & extend (\) if necessary
+1 ; expects VVLINE,VVIDX,VVTLINE,VVEND
+2 NEW VVI,VVY,VVSTART,VVSTOP,VVDONE,VVBUF,VVNODE,VVMORE,VVTO
+3 SET VVNODE=$$CURNODE()
SET VVBUF=""
SET VVMORE=0
SET VVSTOP=VVEND-2
+4 SET VVI=VVIDX
SET VVY=VVLINE
SET VVDONE=0
+5 FOR
Begin DoDot:1
+6 SET VVSTART=VVI
SET VVI=$FIND(@VVJSON@(VVY),"\",VVI)
+7 ; if we are on the last line, don't extract past VVSTOP
+8 IF (VVY=VVTLINE)
SET VVTO=$SELECT('VVI:VVSTOP,VVI>VVSTOP:VVSTOP,1:VVI-2)
IF 1
+9 IF '$TEST
SET VVTO=$SELECT('VVI:99999,1:VVI-2)
+10 DO ADDBUF($EXTRACT(@VVJSON@(VVY),VVSTART,VVTO))
+11 ; now past close quote
IF (VVY'<VVTLINE)
IF (('VVI)!(VVI>VVSTOP))
SET VVDONE=1
QUIT
+12 ; nothing escaped, go to next line
IF 'VVI
SET VVY=VVY+1
SET VVI=1
QUIT
+13 IF VVI>$LENGTH(@VVJSON@(VVY))
SET VVY=VVY+1
SET VVI=1
IF '$DATA(@VVJSON@(VVY))
DO ERRX("EIU")
+14 NEW VVTGT
SET VVTGT=$EXTRACT(@VVJSON@(VVY),VVI)
+15 IF VVTGT="u"
Begin DoDot:2
+16 NEW VVTGTC
SET VVTGTC=$EXTRACT(@VVJSON@(VVY),VVI+1,VVI+4)
SET VVI=VVI+4
+17 IF $LENGTH(VVTGTC)<4
SET VVY=VVY+1
SET VVI=4-$LENGTH(VVTGTC)
SET VVTGTC=VVTGTC_$EXTRACT(@VVJSON@(VVY),1,VVI)
+18 DO ADDBUF($CHAR($$DEC^XLFUTL(VVTGTC,16)))
End DoDot:2
IF 1
+19 IF '$TEST
DO ADDBUF($$REALCHAR(VVTGT))
+20 SET VVI=VVI+1
+21 ; VVI incremented past stop
IF (VVY'<VVTLINE)
IF (VVI>VVSTOP)
SET VVDONE=1
End DoDot:1
if VVDONE
QUIT
if VVERRORS
QUIT
+22 if VVERRORS
QUIT
+23 DO SAVEBUF
+24 QUIT
ADDBUF(VVX) ; add buffer of characters to destination
+1 ; expects VVBUF,VVMAX,VVNODE,VVMORE to be defined
+2 ; used directly by ADDSTR
+3 IF $LENGTH(VVX)+$LENGTH(VVBUF)>VVMAX
DO SAVEBUF
+4 SET VVBUF=VVBUF_VVX
+5 QUIT
SAVEBUF ; write out buffer to destination
+1 ; expects VVBUF,VVMAX,VVNODE,VVMORE to be defined
+2 ; used directly by ADDSTR,ADDBUF
+3 IF VVMORE
SET @VVNODE@("\",VVMORE)=VVBUF
+4 IF 'VVMORE
SET @VVNODE=VVBUF
IF $LENGTH(VVBUF)<19
IF +$EXTRACT(VVBUF,1,18)
SET @VVNODE@("\s")=""
+5 SET VVMORE=VVMORE+1
SET VVBUF=""
+6 QUIT
ISCLOSEQ(VVBLINE) ; return true if this is a closing, rather than escaped, quote
+1 ; expects
+2 ; VVJSON: lines of the JSON encoded string
+3 ; VVIDX: points to 1st character of the segment
+4 ; VVLINE: points to the line in which the segment starts
+5 ; VVEND: points to 1st character after the " (may be past the end of the line)
+6 ; used directly by ADDSTR
+7 NEW VVBS,VVBIDX,VVBDONE
+8 ; VVBIDX starts at 1st character before quote
SET VVBS=0
SET VVBIDX=VVEND-2
SET VVBDONE=0
+9 ; count the backslashes preceding the quote (odd number means the quote was escaped)
+10 FOR
Begin DoDot:1
+11 ; when VVBIDX<1 go back a line
IF VVBIDX<1
Begin DoDot:2
+12 SET VVBLINE=VVBLINE-1
IF VVBLINE<VVLINE
DO ERRX("RSB")
QUIT
+13 SET VVBIDX=$LENGTH(@VVJSON@(VVBLINE))
End DoDot:2
QUIT
+14 IF $EXTRACT(@VVJSON@(VVBLINE),VVBIDX)'="\"
SET VVBDONE=1
QUIT
+15 SET VVBS=VVBS+1
SET VVBIDX=VVBIDX-1
End DoDot:1
if VVBDONE!VVERRORS
QUIT
+16 ; VVBS is even if this is a close quote
QUIT VVBS#2=0
+17 ;
NAMPARS() ; Return parsed name, advancing index past the close quote
+1 ; -- This assumes no embedded quotes are in the name itself --
+2 NEW VVEND,VVDONE,VVNAME
+3 SET VVDONE=0
SET VVNAME=""
+4 FOR
Begin DoDot:1
+5 SET VVEND=$FIND(@VVJSON@(VVLINE),"""",VVIDX)
+6 IF VVEND
SET VVNAME=VVNAME_$EXTRACT(@VVJSON@(VVLINE),VVIDX,VVEND-2)
SET VVIDX=VVEND
SET VVDONE=1
+7 IF 'VVEND
SET VVNAME=VVNAME_$EXTRACT(@VVJSON@(VVLINE),VVIDX,$LENGTH(@VVJSON@(VVLINE)))
+8 IF 'VVEND!(VVEND>$LENGTH(@VVJSON@(VVLINE)))
SET VVLINE=VVLINE+1
SET VVIDX=1
IF '$DATA(@VVJSON@(VVLINE))
DO ERRX("ORN")
End DoDot:1
if VVDONE
QUIT
if VVERRORS
QUIT
+9 QUIT VVNAME
+10 ;
NUMPARS(VVDIGIT) ; Return parsed number, advancing index past the end of the number
+1 ; VVIDX intially references the second digit
+2 NEW VVDONE,VVNUM
+3 SET VVDONE=0
SET VVNUM=VVDIGIT
+4 FOR
Begin DoDot:1
+5 IF '("0123456789+-.eE"[$EXTRACT(@VVJSON@(VVLINE),VVIDX))
SET VVDONE=1
QUIT
+6 SET VVNUM=VVNUM_$EXTRACT(@VVJSON@(VVLINE),VVIDX)
+7 SET VVIDX=VVIDX+1
IF VVIDX>$LENGTH(@VVJSON@(VVLINE))
SET VVLINE=VVLINE+1
SET VVIDX=1
IF '$DATA(@VVJSON@(VVLINE))
DO ERRX("OR#")
End DoDot:1
if VVDONE
QUIT
if VVERRORS
QUIT
+8 QUIT VVNUM
+9 ;
SETBOOL(VVLTR) ; Return parsed value, advancing index past the end of the value
+1 NEW VVDONE,VVBOOL,VVX
+2 SET VVDONE=0
SET VVBOOL=VVLTR
+3 FOR
Begin DoDot:1
+4 SET VVX=$TRANSLATE($EXTRACT(@VVJSON@(VVLINE),VVIDX),"TRUEFALSN","truefalsn")
+5 IF '("truefalsn"[VVX)
SET VVDONE=1
QUIT
+6 SET VVBOOL=VVBOOL_VVX
+7 SET VVIDX=VVIDX+1
IF VVIDX>$LENGTH(@VVJSON@(VVLINE))
SET VVLINE=VVLINE+1
SET VVIDX=1
IF '$DATA(@VVJSON@(VVLINE))
DO ERRX("ORB")
End DoDot:1
if VVDONE
QUIT
if VVERRORS
QUIT
+8 IF VVLTR="t"
IF (VVBOOL'="true")
DO ERRX("EXT",VVTYPE)
+9 IF VVLTR="f"
IF (VVBOOL'="false")
DO ERRX("EXF",VVTYPE)
+10 IF VVLTR="n"
IF (VVBOOL'="null")
DO ERRX("EXN",VVTYPE)
+11 SET @$$CURNODE()=VVBOOL
+12 QUIT
+13 ;
OSETBOOL(VVX) ; set a value and increment VVIDX
+1 SET @$$CURNODE()=VVX
+2 SET VVIDX=VVIDX+$LENGTH(VVX)-1
+3 ; in case VVIDX moves to next line
NEW VVDIFF
SET VVDIFF=VVIDX-$LENGTH(@VVJSON@(VVLINE))
+4 IF VVDIFF>0
SET VVLINE=VVLINE+1
SET VVIDX=VVDIFF
IF '$DATA(@VVJSON@(VVLINE))
DO ERRX("ORB")
+5 QUIT
CURNODE() ; Return a global/local variable name based on VVSTACK
+1 ; Expects VVSTACK to be defined already
+2 NEW VVI,VVSUBS
+3 SET VVSUBS=""
+4 FOR VVI=1:1:VVSTACK
if VVI>1
SET VVSUBS=VVSUBS_","
Begin DoDot:1
+5 IF VVSTACK(VVI)
SET VVSUBS=VVSUBS_VVSTACK(VVI)
+6 IF '$TEST
SET VVSUBS=VVSUBS_""""_VVSTACK(VVI)_""""
End DoDot:1
+7 QUIT VVROOT_VVSUBS_")"
+8 ;
UES(X) ; Unescape JSON string
+1 ; copy segments from START to POS-2 (right before \)
+2 ; translate target character (which is at $F position)
+3 NEW POS,Y,START
+4 SET POS=0
SET Y=""
+5 FOR
SET START=POS+1
Begin DoDot:1
+6 ; find next position
SET POS=$FIND(X,"\",START)
+7 IF 'POS
SET Y=Y_$EXTRACT(X,START,$LENGTH(X))
SET POS=$LENGTH(X)
QUIT
+8 ; otherwise handle escaped char
+9 NEW TGT
+10 SET TGT=$EXTRACT(X,POS)
SET Y=Y_$EXTRACT(X,START,POS-2)
+11 IF TGT="u"
SET Y=Y_$CHAR($$DEC^XLFUTL($EXTRACT(X,POS+1,POS+4),16))
SET POS=POS+4
QUIT
+12 SET Y=Y_$$REALCHAR(TGT)
End DoDot:1
if START>$LENGTH(X)
QUIT
+13 QUIT Y
+14 ;
REALCHAR(C) ; Return actual character from escaped
+1 IF C=""""
QUIT """"
+2 IF C="/"
QUIT "/"
+3 IF C="\"
QUIT "\"
+4 IF C="b"
QUIT $CHAR(8)
+5 IF C="f"
QUIT $CHAR(12)
+6 IF C="n"
QUIT $CHAR(10)
+7 IF C="r"
QUIT $CHAR(13)
+8 IF C="t"
QUIT $CHAR(9)
+9 ;case covered above in $$DEC^XLFUTL calls
IF C="u"
+10 ;otherwise
+11 IF $LENGTH($GET(VVERR))
DO ERRX("ESC",C)
+12 QUIT C
+13 ;
ERRX(ID,VAL) ; Set the appropriate error message
+1 DO ERRX^VPRJSON(ID,$GET(VAL))
+2 QUIT
