- 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 Jan 18, 2025@03:03:58 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