YSBJSON ;SLC/DJE - Encode JSON ; Apr 01, 2021@16:33
;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
;
; Dashboard version of JSON encoder
;
ENCODE(XUROOT,XUJSON,XUERR) ; XUROOT (M structure) --> XUJSON (array of strings)
;
; XUROOT: closed array reference for M representation of object
; XUJSON: destination variable for the string array formatted as JSON
; XUERR: contains error messages, defaults to ^TMP("XLFJERR",$J)
;
I '$L($G(XUROOT)) ; set error info
I '$L($G(XUJSON)) ; set error info
N XULINE,XUMAX,XUERRORS
S XULINE=1,XUMAX=4000,XUERRORS=0 ; 96 more bytes of wiggle room
S @XUJSON@(XULINE)=""
D SEROBJ(XUROOT)
Q
;
SEROBJ(XUROOT) ; Serialize into a JSON object
N XUFIRST,XUSUB,XUNXT
S @XUJSON@(XULINE)=@XUJSON@(XULINE)_"{"
S XUFIRST=1
S XUSUB="" F S XUSUB=$O(@XUROOT@(XUSUB)) Q:XUSUB="" D
. S:'XUFIRST @XUJSON@(XULINE)=@XUJSON@(XULINE)_"," S XUFIRST=0
. ; get the name part
. D SERNAME(XUSUB)
. ; if this is a value, serialize it
. I $$ISVALUE(XUROOT,XUSUB) D SERVAL(XUROOT,XUSUB) Q
. ; otherwise navigate to the next child object or array
. I $D(@XUROOT@(XUSUB))=10 S XUNXT=$O(@XUROOT@(XUSUB,"")) D Q
. . I +XUNXT D SERARY($NA(@XUROOT@(XUSUB))) I 1
. . E D SEROBJ($NA(@XUROOT@(XUSUB)))
. D ERRX("SOB",XUSUB) ; should quit loop before here
S @XUJSON@(XULINE)=@XUJSON@(XULINE)_"}"
Q
SERARY(XUROOT) ; Serialize into a JSON array
N XUFIRST,XUI,XUNXT
S @XUJSON@(XULINE)=@XUJSON@(XULINE)_"["
S XUFIRST=1
S XUI=0 F S XUI=$O(@XUROOT@(XUI)) Q:'XUI D
. S:'XUFIRST @XUJSON@(XULINE)=@XUJSON@(XULINE)_"," S XUFIRST=0
. I $$ISVALUE(XUROOT,XUI) D SERVAL(XUROOT,XUI) Q ; write value
. I $D(@XUROOT@(XUI))=10 S XUNXT=$O(@XUROOT@(XUI,"")) D Q
. . I +XUNXT D SERARY($NA(@XUROOT@(XUI))) I 1
. . E D SEROBJ($NA(@XUROOT@(XUI)))
. D ERRX("SAR",XUI) ; should quit loop before here
S @XUJSON@(XULINE)=@XUJSON@(XULINE)_"]"
Q
SERNAME(XUSUB) ; Serialize the object name into JSON string
I $E(XUSUB)="""" S XUSUB=$E(XUSUB,2,$L(XUSUB)) ; quote indicates numeric label
I ($L(XUSUB)+$L(@XUJSON@(XULINE)))>XUMAX D
.S XULINE=XULINE+1,@XUJSON@(XULINE)=""
S @XUJSON@(XULINE)=@XUJSON@(XULINE)_""""_XUSUB_""""_":"
Q
SERVAL(XUROOT,XUSUB) ; Serialize X into appropriate JSON representation
N XUX,XUI,XUDONE
; if the node is already in JSON format, just add it
I $D(@XUROOT@(XUSUB,":")) D QUIT ; <-- jump out here if preformatted
. S XUX=$G(@XUROOT@(XUSUB,":")) D:$L(XUX) CONCAT
. S XUI=0 F S XUI=$O(@XUROOT@(XUSUB,":",XUI)) Q:'XUI S XUX=@XUROOT@(XUSUB,":",XUI) D CONCAT
;
S XUX=$G(@XUROOT@(XUSUB)),XUDONE=0
; handle the numeric, boolean, and null types
I $D(@XUROOT@(XUSUB,"\n")) S:$L(@XUROOT@(XUSUB,"\n")) XUX=@XUROOT@(XUSUB,"\n") D CONCAT QUIT ; when +X'=X
I '$D(@XUROOT@(XUSUB,"\s")),$L(XUX) D QUIT:XUDONE
. I XUX']]$C(1) S XUX=$$JNUM(XUX) D CONCAT S XUDONE=1 QUIT
. I XUX="true"!(XUX="false")!(XUX="null") D CONCAT S XUDONE=1 QUIT
; otherwise treat it as a string type
S XUX=""""_$$ESC(XUX)_"""" D CONCAT ; put in quotes
Q
CONCAT ; come here to concatenate to JSON string
I ($L(XUX)+$L(@XUJSON@(XULINE)))>XUMAX D
.S XULINE=XULINE+1,@XUJSON@(XULINE)=""
S @XUJSON@(XULINE)=@XUJSON@(XULINE)_XUX
Q
ISVALUE(XUROOT,XUSUB) ; Return true if this is a value node
I $D(@XUROOT@(XUSUB))#2 Q 1
N XUX S XUX=$O(@XUROOT@(XUSUB,""))
Q:XUX="\" 1 ; word processing continuation node
Q:XUX=":" 1 ; pre-formatted JSON node
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
;
JNUM(N) ; Return JSON representation of a number
I N'<1 Q N
I N'>-1 Q N
I N>0 Q "0"_N
I N<0 Q "-0"_$P(N,"-",2,9)
Q N
;
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
; switch (ID) -- XERRX ends statement
N ERRMSG
;
; Decode Error Messages
;
I ID="STL{" S ERRMSG="Stack too large for new object." G XERRX
I ID="SUF}" S ERRMSG="Stack Underflow - extra } found" G XERRX
I ID="STL[" S ERRMSG="Stack too large for new array." G XERRX
I ID="SUF]" S ERRMSG="Stack Underflow - extra ] found." G XERRX
I ID="OBM" S ERRMSG="Array mismatch - expected ] got }." G XERRX
I ID="ARM" S ERRMSG="Object mismatch - expected } got ]." G XERRX
I ID="MPN" S ERRMSG="Missing property name." G XERRX
I ID="EXT" S ERRMSG="Expected true, got "_VAL G XERRX
I ID="EXF" S ERRMSG="Expected false, got "_VAL G XERRX
I ID="EXN" S ERRMSG="Expected null, got "_VAL G XERRX
I ID="TKN" S ERRMSG="Unable to identify type of token, value was "_VAL G XERRX
I ID="SCT" S ERRMSG="Stack mismatch - exit stack level was "_VAL G XERRX
I ID="EIQ" S ERRMSG="Close quote not found before end of input." G XERRX
I ID="EIU" S ERRMSG="Unexpected end of input while unescaping." G XERRX
I ID="RSB" S ERRMSG="Reverse search for \ past beginning of input." G XERRX
I ID="ORN" S ERRMSG="Overrun while scanning name." G XERRX
I ID="OR#" S ERRMSG="Overrun while scanning number." G XERRX
I ID="ORB" S ERRMSG="Overrun while scanning boolean." G XERRX
I ID="ESC" S ERRMSG="Escaped character not recognized"_VAL G XERRX
I ID="NOV" S ERRMSG="Expected value, got "_VAL G XERRX
;
; Encode Error Messages
;
I ID="SOB" S ERRMSG="Unable to serialize node as object, value was "_VAL G XERRX
I ID="SAR" S ERRMSG="Unable to serialize node as array, value was "_VAL G XERRX
S ERRMSG="Unspecified error "_ID_" "_$G(VAL)
XERRX ; end switch
S @XUERR@(0)=$G(@XUERR@(0))+1
S @XUERR@(@XUERR@(0))=ERRMSG
S XUERRORS=XUERRORS+1
Q
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSBJSON 6577 printed Nov 22, 2024@17:23:28 Page 2
YSBJSON ;SLC/DJE - Encode JSON ; Apr 01, 2021@16:33
+1 ;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
+2 ;
+3 ; Dashboard version of JSON encoder
+4 ;
ENCODE(XUROOT,XUJSON,XUERR) ; XUROOT (M structure) --> XUJSON (array of strings)
+1 ;
+2 ; XUROOT: closed array reference for M representation of object
+3 ; XUJSON: destination variable for the string array formatted as JSON
+4 ; XUERR: contains error messages, defaults to ^TMP("XLFJERR",$J)
+5 ;
+6 ; set error info
IF '$LENGTH($GET(XUROOT))
+7 ; set error info
IF '$LENGTH($GET(XUJSON))
+8 NEW XULINE,XUMAX,XUERRORS
+9 ; 96 more bytes of wiggle room
SET XULINE=1
SET XUMAX=4000
SET XUERRORS=0
+10 SET @XUJSON@(XULINE)=""
+11 DO SEROBJ(XUROOT)
+12 QUIT
+13 ;
SEROBJ(XUROOT) ; Serialize into a JSON object
+1 NEW XUFIRST,XUSUB,XUNXT
+2 SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_"{"
+3 SET XUFIRST=1
+4 SET XUSUB=""
FOR
SET XUSUB=$ORDER(@XUROOT@(XUSUB))
if XUSUB=""
QUIT
Begin DoDot:1
+5 if 'XUFIRST
SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_","
SET XUFIRST=0
+6 ; get the name part
+7 DO SERNAME(XUSUB)
+8 ; if this is a value, serialize it
+9 IF $$ISVALUE(XUROOT,XUSUB)
DO SERVAL(XUROOT,XUSUB)
QUIT
+10 ; otherwise navigate to the next child object or array
+11 IF $DATA(@XUROOT@(XUSUB))=10
SET XUNXT=$ORDER(@XUROOT@(XUSUB,""))
Begin DoDot:2
+12 IF +XUNXT
DO SERARY($NAME(@XUROOT@(XUSUB)))
IF 1
+13 IF '$TEST
DO SEROBJ($NAME(@XUROOT@(XUSUB)))
End DoDot:2
QUIT
+14 ; should quit loop before here
DO ERRX("SOB",XUSUB)
End DoDot:1
+15 SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_"}"
+16 QUIT
SERARY(XUROOT) ; Serialize into a JSON array
+1 NEW XUFIRST,XUI,XUNXT
+2 SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_"["
+3 SET XUFIRST=1
+4 SET XUI=0
FOR
SET XUI=$ORDER(@XUROOT@(XUI))
if 'XUI
QUIT
Begin DoDot:1
+5 if 'XUFIRST
SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_","
SET XUFIRST=0
+6 ; write value
IF $$ISVALUE(XUROOT,XUI)
DO SERVAL(XUROOT,XUI)
QUIT
+7 IF $DATA(@XUROOT@(XUI))=10
SET XUNXT=$ORDER(@XUROOT@(XUI,""))
Begin DoDot:2
+8 IF +XUNXT
DO SERARY($NAME(@XUROOT@(XUI)))
IF 1
+9 IF '$TEST
DO SEROBJ($NAME(@XUROOT@(XUI)))
End DoDot:2
QUIT
+10 ; should quit loop before here
DO ERRX("SAR",XUI)
End DoDot:1
+11 SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_"]"
+12 QUIT
SERNAME(XUSUB) ; Serialize the object name into JSON string
+1 ; quote indicates numeric label
IF $EXTRACT(XUSUB)=""""
SET XUSUB=$EXTRACT(XUSUB,2,$LENGTH(XUSUB))
+2 IF ($LENGTH(XUSUB)+$LENGTH(@XUJSON@(XULINE)))>XUMAX
Begin DoDot:1
+3 SET XULINE=XULINE+1
SET @XUJSON@(XULINE)=""
End DoDot:1
+4 SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_""""_XUSUB_""""_":"
+5 QUIT
SERVAL(XUROOT,XUSUB) ; Serialize X into appropriate JSON representation
+1 NEW XUX,XUI,XUDONE
+2 ; if the node is already in JSON format, just add it
+3 ; <-- jump out here if preformatted
IF $DATA(@XUROOT@(XUSUB,":"))
Begin DoDot:1
+4 SET XUX=$GET(@XUROOT@(XUSUB,":"))
if $LENGTH(XUX)
DO CONCAT
+5 SET XUI=0
FOR
SET XUI=$ORDER(@XUROOT@(XUSUB,":",XUI))
if 'XUI
QUIT
SET XUX=@XUROOT@(XUSUB,":",XUI)
DO CONCAT
End DoDot:1
QUIT
+6 ;
+7 SET XUX=$GET(@XUROOT@(XUSUB))
SET XUDONE=0
+8 ; handle the numeric, boolean, and null types
+9 ; when +X'=X
IF $DATA(@XUROOT@(XUSUB,"\n"))
if $LENGTH(@XUROOT@(XUSUB,"\n"))
SET XUX=@XUROOT@(XUSUB,"\n")
DO CONCAT
QUIT
+10 IF '$DATA(@XUROOT@(XUSUB,"\s"))
IF $LENGTH(XUX)
Begin DoDot:1
+11 IF XUX']]$CHAR(1)
SET XUX=$$JNUM(XUX)
DO CONCAT
SET XUDONE=1
QUIT
+12 IF XUX="true"!(XUX="false")!(XUX="null")
DO CONCAT
SET XUDONE=1
QUIT
End DoDot:1
if XUDONE
QUIT
+13 ; otherwise treat it as a string type
+14 ; put in quotes
SET XUX=""""_$$ESC(XUX)_""""
DO CONCAT
+15 QUIT
CONCAT ; come here to concatenate to JSON string
+1 IF ($LENGTH(XUX)+$LENGTH(@XUJSON@(XULINE)))>XUMAX
Begin DoDot:1
+2 SET XULINE=XULINE+1
SET @XUJSON@(XULINE)=""
End DoDot:1
+3 SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_XUX
+4 QUIT
ISVALUE(XUROOT,XUSUB) ; Return true if this is a value node
+1 IF $DATA(@XUROOT@(XUSUB))#2
QUIT 1
+2 NEW XUX
SET XUX=$ORDER(@XUROOT@(XUSUB,""))
+3 ; word processing continuation node
if XUX="\"
QUIT 1
+4 ; pre-formatted JSON node
if XUX="
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 ;
JNUM(N) ; Return JSON representation of a number
+1 IF N'<1
QUIT N
+2 IF N'>-1
QUIT N
+3 IF N>0
QUIT "0"_N
+4 IF N<0
QUIT "-0"_$PIECE(N,"-",2,9)
+5 QUIT N
+6 ;
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 ; switch (ID) -- XERRX ends statement
+2 NEW ERRMSG
+3 ;
+4 ; Decode Error Messages
+5 ;
+6 IF ID="STL{"
SET ERRMSG="Stack too large for new object."
GOTO XERRX
+7 IF ID="SUF}"
SET ERRMSG="Stack Underflow - extra } found"
GOTO XERRX
+8 IF ID="STL["
SET ERRMSG="Stack too large for new array."
GOTO XERRX
+9 IF ID="SUF]"
SET ERRMSG="Stack Underflow - extra ] found."
GOTO XERRX
+10 IF ID="OBM"
SET ERRMSG="Array mismatch - expected ] got }."
GOTO XERRX
+11 IF ID="ARM"
SET ERRMSG="Object mismatch - expected } got ]."
GOTO XERRX
+12 IF ID="MPN"
SET ERRMSG="Missing property name."
GOTO XERRX
+13 IF ID="EXT"
SET ERRMSG="Expected true, got "_VAL
GOTO XERRX
+14 IF ID="EXF"
SET ERRMSG="Expected false, got "_VAL
GOTO XERRX
+15 IF ID="EXN"
SET ERRMSG="Expected null, got "_VAL
GOTO XERRX
+16 IF ID="TKN"
SET ERRMSG="Unable to identify type of token, value was "_VAL
GOTO XERRX
+17 IF ID="SCT"
SET ERRMSG="Stack mismatch - exit stack level was "_VAL
GOTO XERRX
+18 IF ID="EIQ"
SET ERRMSG="Close quote not found before end of input."
GOTO XERRX
+19 IF ID="EIU"
SET ERRMSG="Unexpected end of input while unescaping."
GOTO XERRX
+20 IF ID="RSB"
SET ERRMSG="Reverse search for \ past beginning of input."
GOTO XERRX
+21 IF ID="ORN"
SET ERRMSG="Overrun while scanning name."
GOTO XERRX
+22 IF ID="OR#"
SET ERRMSG="Overrun while scanning number."
GOTO XERRX
+23 IF ID="ORB"
SET ERRMSG="Overrun while scanning boolean."
GOTO XERRX
+24 IF ID="ESC"
SET ERRMSG="Escaped character not recognized"_VAL
GOTO XERRX
+25 IF ID="NOV"
SET ERRMSG="Expected value, got "_VAL
GOTO XERRX
+26 ;
+27 ; Encode Error Messages
+28 ;
+29 IF ID="SOB"
SET ERRMSG="Unable to serialize node as object, value was "_VAL
GOTO XERRX
+30 IF ID="SAR"
SET ERRMSG="Unable to serialize node as array, value was "_VAL
GOTO XERRX
+31 SET ERRMSG="Unspecified error "_ID_" "_$GET(VAL)
XERRX ; end switch
+1 SET @XUERR@(0)=$GET(@XUERR@(0))+1
+2 SET @XUERR@(@XUERR@(0))=ERRMSG
+3 SET XUERRORS=XUERRORS+1
+4 QUIT
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
