Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XLFJSONE

XLFJSONE.m

Go to the documentation of this file.
  1. XLFJSONE ;SLC/KCM/TJB - Encode JSON ;26 Oct 2016
  1. ;;8.0;KERNEL;**680**;Jul 10, 1995;Build 4
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ENCODE(XUROOT,XUJSON,XUERR) ; XUROOT (M structure) --> XUJSON (array of strings)
  1. ;
  1. DIRECT ; TAG for use by ENCODE^XLFJSON
  1. ;
  1. ; Examples: D ENCODE^XLFJSON("^GLO(99,2)","^TMP($J)")
  1. ; D ENCODE^XLFJSON("LOCALVAR","MYJSON","LOCALERR")
  1. ;
  1. ; XUROOT: closed array reference for M representation of object
  1. ; XUJSON: destination variable for the string array formatted as JSON
  1. ; XUERR: contains error messages, defaults to ^TMP("XLFJERR",$J)
  1. ;
  1. S XUERR=$G(XUERR,"^TMP(""XLFJERR"",$J)")
  1. I '$L($G(XUROOT)) ; set error info
  1. I '$L($G(XUJSON)) ; set error info
  1. N XULINE,XUMAX,XUERRORS
  1. S XULINE=1,XUMAX=4000,XUERRORS=0 ; 96 more bytes of wiggle room
  1. S @XUJSON@(XULINE)=""
  1. D SEROBJ(XUROOT)
  1. Q
  1. ;
  1. SEROBJ(XUROOT) ; Serialize into a JSON object
  1. N XUFIRST,XUSUB,XUNXT
  1. S @XUJSON@(XULINE)=@XUJSON@(XULINE)_"{"
  1. S XUFIRST=1
  1. S XUSUB="" F S XUSUB=$O(@XUROOT@(XUSUB)) Q:XUSUB="" D
  1. . S:'XUFIRST @XUJSON@(XULINE)=@XUJSON@(XULINE)_"," S XUFIRST=0
  1. . ; get the name part
  1. . D SERNAME(XUSUB)
  1. . ; if this is a value, serialize it
  1. . I $$ISVALUE(XUROOT,XUSUB) D SERVAL(XUROOT,XUSUB) Q
  1. . ; otherwise navigate to the next child object or array
  1. . I $D(@XUROOT@(XUSUB))=10 S XUNXT=$O(@XUROOT@(XUSUB,"")) D Q
  1. . . I +XUNXT D SERARY($NA(@XUROOT@(XUSUB))) I 1
  1. . . E D SEROBJ($NA(@XUROOT@(XUSUB)))
  1. . D ERRX("SOB",XUSUB) ; should quit loop before here
  1. S @XUJSON@(XULINE)=@XUJSON@(XULINE)_"}"
  1. Q
  1. SERARY(XUROOT) ; Serialize into a JSON array
  1. N XUFIRST,XUI,XUNXT
  1. S @XUJSON@(XULINE)=@XUJSON@(XULINE)_"["
  1. S XUFIRST=1
  1. S XUI=0 F S XUI=$O(@XUROOT@(XUI)) Q:'XUI D
  1. . S:'XUFIRST @XUJSON@(XULINE)=@XUJSON@(XULINE)_"," S XUFIRST=0
  1. . I $$ISVALUE(XUROOT,XUI) D SERVAL(XUROOT,XUI) Q ; write value
  1. . I $D(@XUROOT@(XUI))=10 S XUNXT=$O(@XUROOT@(XUI,"")) D Q
  1. . . I +XUNXT D SERARY($NA(@XUROOT@(XUI))) I 1
  1. . . E D SEROBJ($NA(@XUROOT@(XUI)))
  1. . D ERRX("SAR",XUI) ; should quit loop before here
  1. S @XUJSON@(XULINE)=@XUJSON@(XULINE)_"]"
  1. Q
  1. SERNAME(XUSUB) ; Serialize the object name into JSON string
  1. I $E(XUSUB)="""" S XUSUB=$E(XUSUB,2,$L(XUSUB)) ; quote indicates numeric label
  1. I ($L(XUSUB)+$L(@XUJSON@(XULINE)))>XUMAX S XULINE=XULINE+1,@XUJSON@(XULINE)=""
  1. S @XUJSON@(XULINE)=@XUJSON@(XULINE)_""""_XUSUB_""""_":"
  1. Q
  1. SERVAL(XUROOT,XUSUB) ; Serialize X into appropriate JSON representation
  1. N XUX,XUI,XUDONE
  1. ; if the node is already in JSON format, just add it
  1. I $D(@XUROOT@(XUSUB,":")) D QUIT ; <-- jump out here if preformatted
  1. . S XUX=$G(@XUROOT@(XUSUB,":")) D:$L(XUX) CONCAT
  1. . S XUI=0 F S XUI=$O(@XUROOT@(XUSUB,":",XUI)) Q:'XUI S XUX=@XUROOT@(XUSUB,":",XUI) D CONCAT
  1. ;
  1. S XUX=$G(@XUROOT@(XUSUB)),XUDONE=0
  1. ; handle the numeric, boolean, and null types
  1. I $D(@XUROOT@(XUSUB,"\n")) S:$L(@XUROOT@(XUSUB,"\n")) XUX=@XUROOT@(XUSUB,"\n") D CONCAT QUIT ; when +X'=X
  1. I '$D(@XUROOT@(XUSUB,"\s")),$L(XUX) D QUIT:XUDONE
  1. . I XUX']]$C(1) S XUX=$$JNUM(XUX) D CONCAT S XUDONE=1 QUIT
  1. . I XUX="true"!(XUX="false")!(XUX="null") D CONCAT S XUDONE=1 QUIT
  1. ; otherwise treat it as a string type
  1. S XUX=""""_$$ESC(XUX) ; open quote
  1. D CONCAT
  1. I $D(@XUROOT@(XUSUB,"\")) D ; handle continuation nodes
  1. . S XUI=0 F S XUI=$O(@XUROOT@(XUSUB,"\",XUI)) Q:'XUI D
  1. . . S XUX=$$ESC(@XUROOT@(XUSUB,"\",XUI))
  1. . . D CONCAT
  1. S XUX="""" D CONCAT ; close quote
  1. Q
  1. CONCAT ; come here to concatenate to JSON string
  1. I ($L(XUX)+$L(@XUJSON@(XULINE)))>XUMAX S XULINE=XULINE+1,@XUJSON@(XULINE)=""
  1. S @XUJSON@(XULINE)=@XUJSON@(XULINE)_XUX
  1. Q
  1. ISVALUE(XUROOT,XUSUB) ; Return true if this is a value node
  1. I $D(@XUROOT@(XUSUB))#2 Q 1
  1. N XUX S XUX=$O(@XUROOT@(XUSUB,""))
  1. Q:XUX="\" 1 ; word processing continuation node
  1. Q:XUX=":" 1 ; pre-formatted JSON node
  1. Q 0
  1. ;
  1. NUMERIC(X) ; Return true if the numeric
  1. I $L(X)>18 Q 0 ; string (too long for numeric)
  1. I X=0 Q 1 ; numeric (value is zero)
  1. I +X=0 Q 0 ; string
  1. I $E(X,1)="." Q 0 ; not a JSON number (although numeric in M)
  1. I $E(X,1,2)="-." Q 0 ; not a JSON number
  1. I +X=X Q 1 ; numeric
  1. I X?1"0."1.n Q 1 ; positive fraction
  1. I X?1"-0."1.N Q 1 ; negative fraction
  1. S X=$TR(X,"e","E")
  1. I X?.1"-"1.N.1".".N1"E".1"+"1.N Q 1 ; {-}99{.99}E{+}99
  1. I X?.1"-"1.N.1".".N1"E-"1.N Q 1 ; {-}99{.99}E-99
  1. Q 0
  1. ;
  1. ESC(X) ; Escape string for JSON
  1. N Y,I,PAIR,FROM,TO
  1. S Y=X
  1. F PAIR="\\","""""","//",$C(8,98),$C(12,102),$C(10,110),$C(13,114),$C(9,116) D
  1. . S FROM=$E(PAIR),TO=$E(PAIR,2)
  1. . S X=Y,Y=$P(X,FROM) F I=2:1:$L(X,FROM) S Y=Y_"\"_TO_$P(X,FROM,I)
  1. I Y?.E1.C.E S X=Y,Y="" F I=1:1:$L(X) S FROM=$A(X,I) D
  1. . ; skip NUL character, otherwise encode ctrl-char
  1. . I FROM<32 Q:FROM=0 S Y=Y_$$UCODE(FROM) Q
  1. . I FROM>126,(FROM<160) S Y=Y_$$UCODE(FROM) Q
  1. . S Y=Y_$E(X,I)
  1. Q Y
  1. ;
  1. JNUM(N) ; Return JSON representation of a number
  1. I N'<1 Q N
  1. I N'>-1 Q N
  1. I N>0 Q "0"_N
  1. I N<0 Q "-0"_$P(N,"-",2,9)
  1. Q N
  1. ;
  1. UCODE(C) ; Return \u00nn representation of decimal character value
  1. N H S H="0000"_$$CNV^XLFUTL(C,16)
  1. Q "\u"_$E(H,$L(H)-3,$L(H))
  1. ;
  1. ERRX(ID,VAL) ; Set the appropriate error message
  1. D ERRX^XLFJSON(ID,$G(VAL))
  1. Q