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

VPRJSONE.m

Go to the documentation of this file.
  1. VPRJSONE ;SLC/KCM -- Encode JSON
  1. ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
  1. ;
  1. ENCODE(VVROOT,VVJSON,VVERR) ; VVROOT (M structure) --> VVJSON (array of strings)
  1. ;
  1. DIRECT ; TAG for use by ENCODE^VPRJSON
  1. ;
  1. ; Examples: D ENCODE^VPRJSON("^GLO(99,2)","^TMP($J)")
  1. ; D ENCODE^VPRJSON("LOCALVAR","MYJSON","LOCALERR")
  1. ;
  1. ; VVROOT: closed array reference for M representation of object
  1. ; VVJSON: destination variable for the string array formatted as JSON
  1. ; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
  1. ;
  1. S VVERR=$G(VVERR,"^TMP(""VPRJERR"",$J)")
  1. I '$L($G(VVROOT)) ; set error info
  1. I '$L($G(VVJSON)) ; set error info
  1. N VVLINE,VVMAX,VVERRORS
  1. S VVLINE=1,VVMAX=4000,VVERRORS=0 ; 96 more bytes of wiggle room
  1. S @VVJSON@(VVLINE)=""
  1. D SEROBJ(VVROOT)
  1. Q
  1. ;
  1. SEROBJ(VVROOT) ; Serialize into a JSON object
  1. N VVFIRST,VVSUB,VVNXT
  1. S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"{"
  1. S VVFIRST=1
  1. S VVSUB="" F S VVSUB=$O(@VVROOT@(VVSUB)) Q:VVSUB="" D
  1. . S:'VVFIRST @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"," S VVFIRST=0
  1. . ; get the name part
  1. . D SERNAME(VVSUB)
  1. . ; if this is a value, serialize it
  1. . I $$ISVALUE(VVROOT,VVSUB) D SERVAL(VVROOT,VVSUB) Q
  1. . ; otherwise navigate to the next child object or array
  1. . I $D(@VVROOT@(VVSUB))=10 S VVNXT=$O(@VVROOT@(VVSUB,"")) D Q
  1. . . I +VVNXT D SERARY($NA(@VVROOT@(VVSUB))) I 1
  1. . . E D SEROBJ($NA(@VVROOT@(VVSUB)))
  1. . D ERRX("SOB",VVSUB) ; should quit loop before here
  1. S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"}"
  1. Q
  1. SERARY(VVROOT) ; Serialize into a JSON array
  1. N VVFIRST,VVI,VVNXT
  1. S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"["
  1. S VVFIRST=1
  1. S VVI=0 F S VVI=$O(@VVROOT@(VVI)) Q:'VVI D
  1. . S:'VVFIRST @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"," S VVFIRST=0
  1. . I $$ISVALUE(VVROOT,VVI) D SERVAL(VVROOT,VVI) Q ; write value
  1. . I $D(@VVROOT@(VVI))=10 S VVNXT=$O(@VVROOT@(VVI,"")) D Q
  1. . . I +VVNXT D SERARY($NA(@VVROOT@(VVI))) I 1
  1. . . E D SEROBJ($NA(@VVROOT@(VVI)))
  1. . D ERRX("SAR",VVI) ; should quit loop before here
  1. S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"]"
  1. Q
  1. SERNAME(VVSUB) ; Serialize the object name into JSON string
  1. I ($L(VVSUB)+$L(@VVJSON@(VVLINE)))>VVMAX S VVLINE=VVLINE+1,@VVJSON@(VVLINE)=""
  1. S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_""""_VVSUB_""""_":"
  1. Q
  1. SERVAL(VVROOT,VVSUB) ; Serialize X into appropriate JSON representation
  1. N VVX,VVI
  1. ; if the node is already in JSON format, just add it
  1. I $D(@VVROOT@(VVSUB,":")) D QUIT ; <-- jump out here if preformatted
  1. . S VVX=$G(@VVROOT@(VVSUB,":")) D:$L(VVX) CONCAT
  1. . S VVI=0 F S VVI=$O(@VVROOT@(VVSUB,":",VVI)) Q:'VVI S VVX=@VVROOT@(VVSUB,":",VVI) D CONCAT
  1. ;
  1. S VVX=$G(@VVROOT@(VVSUB))
  1. ; handle the numeric, boolean, and null types
  1. I '$D(@VVROOT@(VVSUB,"\s")),$$NUMERIC(VVX) D CONCAT QUIT
  1. I (VVX="true")!(VVX="false")!(VVX="null") D CONCAT QUIT
  1. ;I $E(vX)=$C(186) S vX=$E(vX,2,$L(vX)) ; remove the "string-forcing" char
  1. ; otherwise treat it as a string type
  1. S VVX=""""_$$ESC(VVX) ; open quote
  1. D CONCAT
  1. I $D(@VVROOT@(VVSUB,"\")) D ; handle continuation nodes
  1. . S VVI=0 F S VVI=$O(@VVROOT@(VVSUB,"\",VVI)) Q:'VVI D
  1. . . S VVX=$$ESC(@VVROOT@(VVSUB,"\",VVI))
  1. . . D CONCAT
  1. S VVX="""" D CONCAT ; close quote
  1. Q
  1. CONCAT ; come here to concatenate to JSON string
  1. I ($L(VVX)+$L(@VVJSON@(VVLINE)))>VVMAX S VVLINE=VVLINE+1,@VVJSON@(VVLINE)=""
  1. S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_VVX
  1. Q
  1. ISVALUE(VVROOT,VVSUB) ; Return true if this is a value node
  1. I $D(@VVROOT@(VVSUB))#2 Q 1
  1. N VVX S VVX=$O(@VVROOT@(VVSUB,""))
  1. Q:VVX="\" 1
  1. Q:VVX=":" 1
  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. 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^VPRJSON(ID,$G(VAL))
  1. Q