XLFJSONE ;SLC/KCM/TJB - Encode JSON ;26 Oct 2016
;;8.0;KERNEL;**680**;Jul 10, 1995;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
ENCODE(XUROOT,XUJSON,XUERR) ; XUROOT (M structure) --> XUJSON (array of strings)
;
DIRECT ; TAG for use by ENCODE^XLFJSON
;
; Examples: D ENCODE^XLFJSON("^GLO(99,2)","^TMP($J)")
; D ENCODE^XLFJSON("LOCALVAR","MYJSON","LOCALERR")
;
; 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)
;
S XUERR=$G(XUERR,"^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 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) ; open quote
D CONCAT
I $D(@XUROOT@(XUSUB,"\")) D ; handle continuation nodes
. S XUI=0 F S XUI=$O(@XUROOT@(XUSUB,"\",XUI)) Q:'XUI D
. . S XUX=$$ESC(@XUROOT@(XUSUB,"\",XUI))
. . D CONCAT
S XUX="""" D CONCAT ; close quote
Q
CONCAT ; come here to concatenate to JSON string
I ($L(XUX)+$L(@XUJSON@(XULINE)))>XUMAX 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
;
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
;
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
D ERRX^XLFJSON(ID,$G(VAL))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFJSONE 5274 printed Oct 16, 2024@18:03:35 Page 2
XLFJSONE ;SLC/KCM/TJB - Encode JSON ;26 Oct 2016
+1 ;;8.0;KERNEL;**680**;Jul 10, 1995;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
ENCODE(XUROOT,XUJSON,XUERR) ; XUROOT (M structure) --> XUJSON (array of strings)
+1 ;
DIRECT ; TAG for use by ENCODE^XLFJSON
+1 ;
+2 ; Examples: D ENCODE^XLFJSON("^GLO(99,2)","^TMP($J)")
+3 ; D ENCODE^XLFJSON("LOCALVAR","MYJSON","LOCALERR")
+4 ;
+5 ; XUROOT: closed array reference for M representation of object
+6 ; XUJSON: destination variable for the string array formatted as JSON
+7 ; XUERR: contains error messages, defaults to ^TMP("XLFJERR",$J)
+8 ;
+9 SET XUERR=$GET(XUERR,"^TMP(""XLFJERR"",$J)")
+10 ; set error info
IF '$LENGTH($GET(XUROOT))
+11 ; set error info
IF '$LENGTH($GET(XUJSON))
+12 NEW XULINE,XUMAX,XUERRORS
+13 ; 96 more bytes of wiggle room
SET XULINE=1
SET XUMAX=4000
SET XUERRORS=0
+14 SET @XUJSON@(XULINE)=""
+15 DO SEROBJ(XUROOT)
+16 QUIT
+17 ;
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
SET XULINE=XULINE+1
SET @XUJSON@(XULINE)=""
+3 SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_""""_XUSUB_""""_":"
+4 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 ; open quote
SET XUX=""""_$$ESC(XUX)
+15 DO CONCAT
+16 ; handle continuation nodes
IF $DATA(@XUROOT@(XUSUB,"\"))
Begin DoDot:1
+17 SET XUI=0
FOR
SET XUI=$ORDER(@XUROOT@(XUSUB,"\",XUI))
if 'XUI
QUIT
Begin DoDot:2
+18 SET XUX=$$ESC(@XUROOT@(XUSUB,"\",XUI))
+19 DO CONCAT
End DoDot:2
End DoDot:1
+20 ; close quote
SET XUX=""""
DO CONCAT
+21 QUIT
CONCAT ; come here to concatenate to JSON string
+1 IF ($LENGTH(XUX)+$LENGTH(@XUJSON@(XULINE)))>XUMAX
SET XULINE=XULINE+1
SET @XUJSON@(XULINE)=""
+2 SET @XUJSON@(XULINE)=@XUJSON@(XULINE)_XUX
+3 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 ;
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 ;
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 DO ERRX^XLFJSON(ID,$GET(VAL))
+2 QUIT
