VPRJSONE ;SLC/KCM -- Encode JSON
;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
;
ENCODE(VVROOT,VVJSON,VVERR) ; VVROOT (M structure) --> VVJSON (array of strings)
;
DIRECT ; TAG for use by ENCODE^VPRJSON
;
; Examples: D ENCODE^VPRJSON("^GLO(99,2)","^TMP($J)")
; D ENCODE^VPRJSON("LOCALVAR","MYJSON","LOCALERR")
;
; VVROOT: closed array reference for M representation of object
; VVJSON: destination variable for the string array formatted as JSON
; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
;
S VVERR=$G(VVERR,"^TMP(""VPRJERR"",$J)")
I '$L($G(VVROOT)) ; set error info
I '$L($G(VVJSON)) ; set error info
N VVLINE,VVMAX,VVERRORS
S VVLINE=1,VVMAX=4000,VVERRORS=0 ; 96 more bytes of wiggle room
S @VVJSON@(VVLINE)=""
D SEROBJ(VVROOT)
Q
;
SEROBJ(VVROOT) ; Serialize into a JSON object
N VVFIRST,VVSUB,VVNXT
S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"{"
S VVFIRST=1
S VVSUB="" F S VVSUB=$O(@VVROOT@(VVSUB)) Q:VVSUB="" D
. S:'VVFIRST @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"," S VVFIRST=0
. ; get the name part
. D SERNAME(VVSUB)
. ; if this is a value, serialize it
. I $$ISVALUE(VVROOT,VVSUB) D SERVAL(VVROOT,VVSUB) Q
. ; otherwise navigate to the next child object or array
. I $D(@VVROOT@(VVSUB))=10 S VVNXT=$O(@VVROOT@(VVSUB,"")) D Q
. . I +VVNXT D SERARY($NA(@VVROOT@(VVSUB))) I 1
. . E D SEROBJ($NA(@VVROOT@(VVSUB)))
. D ERRX("SOB",VVSUB) ; should quit loop before here
S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"}"
Q
SERARY(VVROOT) ; Serialize into a JSON array
N VVFIRST,VVI,VVNXT
S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"["
S VVFIRST=1
S VVI=0 F S VVI=$O(@VVROOT@(VVI)) Q:'VVI D
. S:'VVFIRST @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"," S VVFIRST=0
. I $$ISVALUE(VVROOT,VVI) D SERVAL(VVROOT,VVI) Q ; write value
. I $D(@VVROOT@(VVI))=10 S VVNXT=$O(@VVROOT@(VVI,"")) D Q
. . I +VVNXT D SERARY($NA(@VVROOT@(VVI))) I 1
. . E D SEROBJ($NA(@VVROOT@(VVI)))
. D ERRX("SAR",VVI) ; should quit loop before here
S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"]"
Q
SERNAME(VVSUB) ; Serialize the object name into JSON string
I ($L(VVSUB)+$L(@VVJSON@(VVLINE)))>VVMAX S VVLINE=VVLINE+1,@VVJSON@(VVLINE)=""
S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_""""_VVSUB_""""_":"
Q
SERVAL(VVROOT,VVSUB) ; Serialize X into appropriate JSON representation
N VVX,VVI
; if the node is already in JSON format, just add it
I $D(@VVROOT@(VVSUB,":")) D QUIT ; <-- jump out here if preformatted
. S VVX=$G(@VVROOT@(VVSUB,":")) D:$L(VVX) CONCAT
. S VVI=0 F S VVI=$O(@VVROOT@(VVSUB,":",VVI)) Q:'VVI S VVX=@VVROOT@(VVSUB,":",VVI) D CONCAT
;
S VVX=$G(@VVROOT@(VVSUB))
; handle the numeric, boolean, and null types
I '$D(@VVROOT@(VVSUB,"\s")),$$NUMERIC(VVX) D CONCAT QUIT
I (VVX="true")!(VVX="false")!(VVX="null") D CONCAT QUIT
;I $E(vX)=$C(186) S vX=$E(vX,2,$L(vX)) ; remove the "string-forcing" char
; otherwise treat it as a string type
S VVX=""""_$$ESC(VVX) ; open quote
D CONCAT
I $D(@VVROOT@(VVSUB,"\")) D ; handle continuation nodes
. S VVI=0 F S VVI=$O(@VVROOT@(VVSUB,"\",VVI)) Q:'VVI D
. . S VVX=$$ESC(@VVROOT@(VVSUB,"\",VVI))
. . D CONCAT
S VVX="""" D CONCAT ; close quote
Q
CONCAT ; come here to concatenate to JSON string
I ($L(VVX)+$L(@VVJSON@(VVLINE)))>VVMAX S VVLINE=VVLINE+1,@VVJSON@(VVLINE)=""
S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_VVX
Q
ISVALUE(VVROOT,VVSUB) ; Return true if this is a value node
I $D(@VVROOT@(VVSUB))#2 Q 1
N VVX S VVX=$O(@VVROOT@(VVSUB,""))
Q:VVX="\" 1
Q:VVX=":" 1
Q 0
;
NUMERIC(X) ; Return true if the numeric
I $L(X)>18 Q 0 ; string (too long for numeric)
I X=0 Q 1 ; numeric (value is zero)
I +X=0 Q 0 ; string
I $E(X,1)="." Q 0 ; not a JSON number (although numeric in M)
I $E(X,1,2)="-." Q 0 ; not a JSON number
I +X=X Q 1 ; numeric
I X?1"0."1.n Q 1 ; positive fraction
I X?1"-0."1.N Q 1 ; negative fraction
S X=$TR(X,"e","E")
I X?.1"-"1.N.1".".N1"E".1"+"1.N Q 1 ; {-}99{.99}E{+}99
I X?.1"-"1.N.1".".N1"E-"1.N Q 1 ; {-}99{.99}E-99
Q 0
;
ESC(X) ; Escape string for JSON
N Y,I,PAIR,FROM,TO
S Y=X
F PAIR="\\","""""","//",$C(8,98),$C(12,102),$C(10,110),$C(13,114),$C(9,116) D
. S FROM=$E(PAIR),TO=$E(PAIR,2)
. S X=Y,Y=$P(X,FROM) F I=2:1:$L(X,FROM) S Y=Y_"\"_TO_$P(X,FROM,I)
I Y?.E1.C.E S X=Y,Y="" F I=1:1:$L(X) S FROM=$A(X,I) D
. ; skip NUL character, otherwise encode ctrl-char
. I FROM<32 Q:FROM=0 S Y=Y_$$UCODE(FROM) Q
. I FROM>126,(FROM<160) S Y=Y_$$UCODE(FROM) Q
. S Y=Y_$E(X,I)
Q Y
;
UCODE(C) ; Return \u00nn representation of decimal character value
N H S H="0000"_$$CNV^XLFUTL(C,16)
Q "\u"_$E(H,$L(H)-3,$L(H))
;
ERRX(ID,VAL) ; Set the appropriate error message
D ERRX^VPRJSON(ID,$G(VAL))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRJSONE 4818 printed Dec 13, 2024@02:45:25 Page 2
VPRJSONE ;SLC/KCM -- Encode JSON
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
+2 ;
ENCODE(VVROOT,VVJSON,VVERR) ; VVROOT (M structure) --> VVJSON (array of strings)
+1 ;
DIRECT ; TAG for use by ENCODE^VPRJSON
+1 ;
+2 ; Examples: D ENCODE^VPRJSON("^GLO(99,2)","^TMP($J)")
+3 ; D ENCODE^VPRJSON("LOCALVAR","MYJSON","LOCALERR")
+4 ;
+5 ; VVROOT: closed array reference for M representation of object
+6 ; VVJSON: destination variable for the string array formatted as JSON
+7 ; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
+8 ;
+9 SET VVERR=$GET(VVERR,"^TMP(""VPRJERR"",$J)")
+10 ; set error info
IF '$LENGTH($GET(VVROOT))
+11 ; set error info
IF '$LENGTH($GET(VVJSON))
+12 NEW VVLINE,VVMAX,VVERRORS
+13 ; 96 more bytes of wiggle room
SET VVLINE=1
SET VVMAX=4000
SET VVERRORS=0
+14 SET @VVJSON@(VVLINE)=""
+15 DO SEROBJ(VVROOT)
+16 QUIT
+17 ;
SEROBJ(VVROOT) ; Serialize into a JSON object
+1 NEW VVFIRST,VVSUB,VVNXT
+2 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"{"
+3 SET VVFIRST=1
+4 SET VVSUB=""
FOR
SET VVSUB=$ORDER(@VVROOT@(VVSUB))
if VVSUB=""
QUIT
Begin DoDot:1
+5 if 'VVFIRST
SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_","
SET VVFIRST=0
+6 ; get the name part
+7 DO SERNAME(VVSUB)
+8 ; if this is a value, serialize it
+9 IF $$ISVALUE(VVROOT,VVSUB)
DO SERVAL(VVROOT,VVSUB)
QUIT
+10 ; otherwise navigate to the next child object or array
+11 IF $DATA(@VVROOT@(VVSUB))=10
SET VVNXT=$ORDER(@VVROOT@(VVSUB,""))
Begin DoDot:2
+12 IF +VVNXT
DO SERARY($NAME(@VVROOT@(VVSUB)))
IF 1
+13 IF '$TEST
DO SEROBJ($NAME(@VVROOT@(VVSUB)))
End DoDot:2
QUIT
+14 ; should quit loop before here
DO ERRX("SOB",VVSUB)
End DoDot:1
+15 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"}"
+16 QUIT
SERARY(VVROOT) ; Serialize into a JSON array
+1 NEW VVFIRST,VVI,VVNXT
+2 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"["
+3 SET VVFIRST=1
+4 SET VVI=0
FOR
SET VVI=$ORDER(@VVROOT@(VVI))
if 'VVI
QUIT
Begin DoDot:1
+5 if 'VVFIRST
SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_","
SET VVFIRST=0
+6 ; write value
IF $$ISVALUE(VVROOT,VVI)
DO SERVAL(VVROOT,VVI)
QUIT
+7 IF $DATA(@VVROOT@(VVI))=10
SET VVNXT=$ORDER(@VVROOT@(VVI,""))
Begin DoDot:2
+8 IF +VVNXT
DO SERARY($NAME(@VVROOT@(VVI)))
IF 1
+9 IF '$TEST
DO SEROBJ($NAME(@VVROOT@(VVI)))
End DoDot:2
QUIT
+10 ; should quit loop before here
DO ERRX("SAR",VVI)
End DoDot:1
+11 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"]"
+12 QUIT
SERNAME(VVSUB) ; Serialize the object name into JSON string
+1 IF ($LENGTH(VVSUB)+$LENGTH(@VVJSON@(VVLINE)))>VVMAX
SET VVLINE=VVLINE+1
SET @VVJSON@(VVLINE)=""
+2 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_""""_VVSUB_""""_":"
+3 QUIT
SERVAL(VVROOT,VVSUB) ; Serialize X into appropriate JSON representation
+1 NEW VVX,VVI
+2 ; if the node is already in JSON format, just add it
+3 ; <-- jump out here if preformatted
IF $DATA(@VVROOT@(VVSUB,":"))
Begin DoDot:1
+4 SET VVX=$GET(@VVROOT@(VVSUB,":"))
if $LENGTH(VVX)
DO CONCAT
+5 SET VVI=0
FOR
SET VVI=$ORDER(@VVROOT@(VVSUB,":",VVI))
if 'VVI
QUIT
SET VVX=@VVROOT@(VVSUB,":",VVI)
DO CONCAT
End DoDot:1
QUIT
+6 ;
+7 SET VVX=$GET(@VVROOT@(VVSUB))
+8 ; handle the numeric, boolean, and null types
+9 IF '$DATA(@VVROOT@(VVSUB,"\s"))
IF $$NUMERIC(VVX)
DO CONCAT
QUIT
+10 IF (VVX="true")!(VVX="false")!(VVX="null")
DO CONCAT
QUIT
+11 ;I $E(vX)=$C(186) S vX=$E(vX,2,$L(vX)) ; remove the "string-forcing" char
+12 ; otherwise treat it as a string type
+13 ; open quote
SET VVX=""""_$$ESC(VVX)
+14 DO CONCAT
+15 ; handle continuation nodes
IF $DATA(@VVROOT@(VVSUB,"\"))
Begin DoDot:1
+16 SET VVI=0
FOR
SET VVI=$ORDER(@VVROOT@(VVSUB,"\",VVI))
if 'VVI
QUIT
Begin DoDot:2
+17 SET VVX=$$ESC(@VVROOT@(VVSUB,"\",VVI))
+18 DO CONCAT
End DoDot:2
End DoDot:1
+19 ; close quote
SET VVX=""""
DO CONCAT
+20 QUIT
CONCAT ; come here to concatenate to JSON string
+1 IF ($LENGTH(VVX)+$LENGTH(@VVJSON@(VVLINE)))>VVMAX
SET VVLINE=VVLINE+1
SET @VVJSON@(VVLINE)=""
+2 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_VVX
+3 QUIT
ISVALUE(VVROOT,VVSUB) ; Return true if this is a value node
+1 IF $DATA(@VVROOT@(VVSUB))#2
QUIT 1
+2 NEW VVX
SET VVX=$ORDER(@VVROOT@(VVSUB,""))
+3 if VVX="\"
QUIT 1
+4 if VVX="
QUIT 1
+5 QUIT 0
+6 ;
NUMERIC(X) ; Return true if the numeric
+1 ; string (too long for numeric)
IF $LENGTH(X)>18
QUIT 0
+2 ; numeric (value is zero)
IF X=0
QUIT 1
+3 ; string
IF +X=0
QUIT 0
+4 ; not a JSON number (although numeric in M)
IF $EXTRACT(X,1)="."
QUIT 0
+5 ; not a JSON number
IF $EXTRACT(X,1,2)="-."
QUIT 0
+6 ; numeric
IF +X=X
QUIT 1
+7 ; positive fraction
IF X?1"0."1.n
QUIT 1
+8 ; negative fraction
IF X?1"-0."1.N
QUIT 1
+9 SET X=$TRANSLATE(X,"e","E")
+10 ; {-}99{.99}E{+}99
IF X?.1"-"1.N.1".".N1"E".1"+"1.N
QUIT 1
+11 ; {-}99{.99}E-99
IF X?.1"-"1.N.1".".N1"E-"1.N
QUIT 1
+12 QUIT 0
+13 ;
ESC(X) ; Escape string for JSON
+1 NEW Y,I,PAIR,FROM,TO
+2 SET Y=X
+3 FOR PAIR="\\","""""","//",$CHAR(8,98),$CHAR(12,102),$CHAR(10,110),$CHAR(13,114),$CHAR(9,116)
Begin DoDot:1
+4 SET FROM=$EXTRACT(PAIR)
SET TO=$EXTRACT(PAIR,2)
+5 SET X=Y
SET Y=$PIECE(X,FROM)
FOR I=2:1:$LENGTH(X,FROM)
SET Y=Y_"\"_TO_$PIECE(X,FROM,I)
End DoDot:1
+6 IF Y?.E1.C.E
SET X=Y
SET Y=""
FOR I=1:1:$LENGTH(X)
SET FROM=$ASCII(X,I)
Begin DoDot:1
+7 ; skip NUL character, otherwise encode ctrl-char
+8 IF FROM<32
if FROM=0
QUIT
SET Y=Y_$$UCODE(FROM)
QUIT
+9 IF FROM>126
IF (FROM<160)
SET Y=Y_$$UCODE(FROM)
QUIT
+10 SET Y=Y_$EXTRACT(X,I)
End DoDot:1
+11 QUIT Y
+12 ;
UCODE(C) ; Return \u00nn representation of decimal character value
+1 NEW H
SET H="0000"_$$CNV^XLFUTL(C,16)
+2 QUIT "\u"_$EXTRACT(H,$LENGTH(H)-3,$LENGTH(H))
+3 ;
ERRX(ID,VAL) ; Set the appropriate error message
+1 DO ERRX^VPRJSON(ID,$GET(VAL))
+2 QUIT
