- VPRJSONE ;SLC/KCM -- Encode JSON
- ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
- ;
- ENCODE(VVROOT,VVJSON,VVERR) ; VVROOT (M structure) --> VVJSON (array of strings)
- ;
- DIRECT ; TAG for use by ENCODE^VPRJSON
- ;
- ; Examples: D ENCODE^VPRJSON("^GLO(99,2)","^TMP($J)")
- ; D ENCODE^VPRJSON("LOCALVAR","MYJSON","LOCALERR")
- ;
- ; VVROOT: closed array reference for M representation of object
- ; VVJSON: destination variable for the string array formatted as JSON
- ; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
- ;
- S VVERR=$G(VVERR,"^TMP(""VPRJERR"",$J)")
- I '$L($G(VVROOT)) ; set error info
- I '$L($G(VVJSON)) ; set error info
- N VVLINE,VVMAX,VVERRORS
- S VVLINE=1,VVMAX=4000,VVERRORS=0 ; 96 more bytes of wiggle room
- S @VVJSON@(VVLINE)=""
- D SEROBJ(VVROOT)
- Q
- ;
- SEROBJ(VVROOT) ; Serialize into a JSON object
- N VVFIRST,VVSUB,VVNXT
- S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"{"
- S VVFIRST=1
- S VVSUB="" F S VVSUB=$O(@VVROOT@(VVSUB)) Q:VVSUB="" D
- . S:'VVFIRST @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"," S VVFIRST=0
- . ; get the name part
- . D SERNAME(VVSUB)
- . ; if this is a value, serialize it
- . I $$ISVALUE(VVROOT,VVSUB) D SERVAL(VVROOT,VVSUB) Q
- . ; otherwise navigate to the next child object or array
- . I $D(@VVROOT@(VVSUB))=10 S VVNXT=$O(@VVROOT@(VVSUB,"")) D Q
- . . I +VVNXT D SERARY($NA(@VVROOT@(VVSUB))) I 1
- . . E D SEROBJ($NA(@VVROOT@(VVSUB)))
- . D ERRX("SOB",VVSUB) ; should quit loop before here
- S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"}"
- Q
- SERARY(VVROOT) ; Serialize into a JSON array
- N VVFIRST,VVI,VVNXT
- S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"["
- S VVFIRST=1
- S VVI=0 F S VVI=$O(@VVROOT@(VVI)) Q:'VVI D
- . S:'VVFIRST @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"," S VVFIRST=0
- . I $$ISVALUE(VVROOT,VVI) D SERVAL(VVROOT,VVI) Q ; write value
- . I $D(@VVROOT@(VVI))=10 S VVNXT=$O(@VVROOT@(VVI,"")) D Q
- . . I +VVNXT D SERARY($NA(@VVROOT@(VVI))) I 1
- . . E D SEROBJ($NA(@VVROOT@(VVI)))
- . D ERRX("SAR",VVI) ; should quit loop before here
- S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"]"
- Q
- SERNAME(VVSUB) ; Serialize the object name into JSON string
- I ($L(VVSUB)+$L(@VVJSON@(VVLINE)))>VVMAX S VVLINE=VVLINE+1,@VVJSON@(VVLINE)=""
- S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_""""_VVSUB_""""_":"
- Q
- SERVAL(VVROOT,VVSUB) ; Serialize X into appropriate JSON representation
- N VVX,VVI
- ; if the node is already in JSON format, just add it
- I $D(@VVROOT@(VVSUB,":")) D QUIT ; <-- jump out here if preformatted
- . S VVX=$G(@VVROOT@(VVSUB,":")) D:$L(VVX) CONCAT
- . S VVI=0 F S VVI=$O(@VVROOT@(VVSUB,":",VVI)) Q:'VVI S VVX=@VVROOT@(VVSUB,":",VVI) D CONCAT
- ;
- S VVX=$G(@VVROOT@(VVSUB))
- ; handle the numeric, boolean, and null types
- I '$D(@VVROOT@(VVSUB,"\s")),$$NUMERIC(VVX) D CONCAT QUIT
- I (VVX="true")!(VVX="false")!(VVX="null") D CONCAT QUIT
- ;I $E(vX)=$C(186) S vX=$E(vX,2,$L(vX)) ; remove the "string-forcing" char
- ; otherwise treat it as a string type
- S VVX=""""_$$ESC(VVX) ; open quote
- D CONCAT
- I $D(@VVROOT@(VVSUB,"\")) D ; handle continuation nodes
- . S VVI=0 F S VVI=$O(@VVROOT@(VVSUB,"\",VVI)) Q:'VVI D
- . . S VVX=$$ESC(@VVROOT@(VVSUB,"\",VVI))
- . . D CONCAT
- S VVX="""" D CONCAT ; close quote
- Q
- CONCAT ; come here to concatenate to JSON string
- I ($L(VVX)+$L(@VVJSON@(VVLINE)))>VVMAX S VVLINE=VVLINE+1,@VVJSON@(VVLINE)=""
- S @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_VVX
- Q
- ISVALUE(VVROOT,VVSUB) ; Return true if this is a value node
- I $D(@VVROOT@(VVSUB))#2 Q 1
- N VVX S VVX=$O(@VVROOT@(VVSUB,""))
- Q:VVX="\" 1
- Q:VVX=":" 1
- 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
- ;
- 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^VPRJSON(ID,$G(VAL))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRJSONE 4818 printed Feb 19, 2025@00:11:52 Page 2
- VPRJSONE ;SLC/KCM -- Encode JSON
- +1 ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
- +2 ;
- ENCODE(VVROOT,VVJSON,VVERR) ; VVROOT (M structure) --> VVJSON (array of strings)
- +1 ;
- DIRECT ; TAG for use by ENCODE^VPRJSON
- +1 ;
- +2 ; Examples: D ENCODE^VPRJSON("^GLO(99,2)","^TMP($J)")
- +3 ; D ENCODE^VPRJSON("LOCALVAR","MYJSON","LOCALERR")
- +4 ;
- +5 ; VVROOT: closed array reference for M representation of object
- +6 ; VVJSON: destination variable for the string array formatted as JSON
- +7 ; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
- +8 ;
- +9 SET VVERR=$GET(VVERR,"^TMP(""VPRJERR"",$J)")
- +10 ; set error info
- IF '$LENGTH($GET(VVROOT))
- +11 ; set error info
- IF '$LENGTH($GET(VVJSON))
- +12 NEW VVLINE,VVMAX,VVERRORS
- +13 ; 96 more bytes of wiggle room
- SET VVLINE=1
- SET VVMAX=4000
- SET VVERRORS=0
- +14 SET @VVJSON@(VVLINE)=""
- +15 DO SEROBJ(VVROOT)
- +16 QUIT
- +17 ;
- SEROBJ(VVROOT) ; Serialize into a JSON object
- +1 NEW VVFIRST,VVSUB,VVNXT
- +2 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"{"
- +3 SET VVFIRST=1
- +4 SET VVSUB=""
- FOR
- SET VVSUB=$ORDER(@VVROOT@(VVSUB))
- if VVSUB=""
- QUIT
- Begin DoDot:1
- +5 if 'VVFIRST
- SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_","
- SET VVFIRST=0
- +6 ; get the name part
- +7 DO SERNAME(VVSUB)
- +8 ; if this is a value, serialize it
- +9 IF $$ISVALUE(VVROOT,VVSUB)
- DO SERVAL(VVROOT,VVSUB)
- QUIT
- +10 ; otherwise navigate to the next child object or array
- +11 IF $DATA(@VVROOT@(VVSUB))=10
- SET VVNXT=$ORDER(@VVROOT@(VVSUB,""))
- Begin DoDot:2
- +12 IF +VVNXT
- DO SERARY($NAME(@VVROOT@(VVSUB)))
- IF 1
- +13 IF '$TEST
- DO SEROBJ($NAME(@VVROOT@(VVSUB)))
- End DoDot:2
- QUIT
- +14 ; should quit loop before here
- DO ERRX("SOB",VVSUB)
- End DoDot:1
- +15 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"}"
- +16 QUIT
- SERARY(VVROOT) ; Serialize into a JSON array
- +1 NEW VVFIRST,VVI,VVNXT
- +2 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"["
- +3 SET VVFIRST=1
- +4 SET VVI=0
- FOR
- SET VVI=$ORDER(@VVROOT@(VVI))
- if 'VVI
- QUIT
- Begin DoDot:1
- +5 if 'VVFIRST
- SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_","
- SET VVFIRST=0
- +6 ; write value
- IF $$ISVALUE(VVROOT,VVI)
- DO SERVAL(VVROOT,VVI)
- QUIT
- +7 IF $DATA(@VVROOT@(VVI))=10
- SET VVNXT=$ORDER(@VVROOT@(VVI,""))
- Begin DoDot:2
- +8 IF +VVNXT
- DO SERARY($NAME(@VVROOT@(VVI)))
- IF 1
- +9 IF '$TEST
- DO SEROBJ($NAME(@VVROOT@(VVI)))
- End DoDot:2
- QUIT
- +10 ; should quit loop before here
- DO ERRX("SAR",VVI)
- End DoDot:1
- +11 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_"]"
- +12 QUIT
- SERNAME(VVSUB) ; Serialize the object name into JSON string
- +1 IF ($LENGTH(VVSUB)+$LENGTH(@VVJSON@(VVLINE)))>VVMAX
- SET VVLINE=VVLINE+1
- SET @VVJSON@(VVLINE)=""
- +2 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_""""_VVSUB_""""_":"
- +3 QUIT
- SERVAL(VVROOT,VVSUB) ; Serialize X into appropriate JSON representation
- +1 NEW VVX,VVI
- +2 ; if the node is already in JSON format, just add it
- +3 ; <-- jump out here if preformatted
- IF $DATA(@VVROOT@(VVSUB,":"))
- Begin DoDot:1
- +4 SET VVX=$GET(@VVROOT@(VVSUB,":"))
- if $LENGTH(VVX)
- DO CONCAT
- +5 SET VVI=0
- FOR
- SET VVI=$ORDER(@VVROOT@(VVSUB,":",VVI))
- if 'VVI
- QUIT
- SET VVX=@VVROOT@(VVSUB,":",VVI)
- DO CONCAT
- End DoDot:1
- QUIT
- +6 ;
- +7 SET VVX=$GET(@VVROOT@(VVSUB))
- +8 ; handle the numeric, boolean, and null types
- +9 IF '$DATA(@VVROOT@(VVSUB,"\s"))
- IF $$NUMERIC(VVX)
- DO CONCAT
- QUIT
- +10 IF (VVX="true")!(VVX="false")!(VVX="null")
- DO CONCAT
- QUIT
- +11 ;I $E(vX)=$C(186) S vX=$E(vX,2,$L(vX)) ; remove the "string-forcing" char
- +12 ; otherwise treat it as a string type
- +13 ; open quote
- SET VVX=""""_$$ESC(VVX)
- +14 DO CONCAT
- +15 ; handle continuation nodes
- IF $DATA(@VVROOT@(VVSUB,"\"))
- Begin DoDot:1
- +16 SET VVI=0
- FOR
- SET VVI=$ORDER(@VVROOT@(VVSUB,"\",VVI))
- if 'VVI
- QUIT
- Begin DoDot:2
- +17 SET VVX=$$ESC(@VVROOT@(VVSUB,"\",VVI))
- +18 DO CONCAT
- End DoDot:2
- End DoDot:1
- +19 ; close quote
- SET VVX=""""
- DO CONCAT
- +20 QUIT
- CONCAT ; come here to concatenate to JSON string
- +1 IF ($LENGTH(VVX)+$LENGTH(@VVJSON@(VVLINE)))>VVMAX
- SET VVLINE=VVLINE+1
- SET @VVJSON@(VVLINE)=""
- +2 SET @VVJSON@(VVLINE)=@VVJSON@(VVLINE)_VVX
- +3 QUIT
- ISVALUE(VVROOT,VVSUB) ; Return true if this is a value node
- +1 IF $DATA(@VVROOT@(VVSUB))#2
- QUIT 1
- +2 NEW VVX
- SET VVX=$ORDER(@VVROOT@(VVSUB,""))
- +3 if VVX="\"
- QUIT 1
- +4 if VVX="
- 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 ;
- 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^VPRJSON(ID,$GET(VAL))
- +2 QUIT