VPRJSON ;SLC/KCM -- Decode/Encode JSON ;8/14/13 11:22
;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
;
; Note: Since the routines use closed array references, VVROOT and VVERR
; are used to reduce risk of naming conflicts on the closed array.
;
DECODE(VVJSON,VVROOT,VVERR) ; Set JSON object into closed array ref VVROOT
; Examples: D DECODE^VPRJSON("MYJSON","LOCALVAR","LOCALERR")
; D DECODE^VPRJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
;
; VVJSON: string/array containing serialized JSON object
; VVROOT: closed array reference for M representation of object
; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
;
; VVIDX: points to next character in JSON string to process
; VVSTACK: manages stack of subscripts
; VVPROP: true if next string is property name, otherwise treat as value
;
G DIRECT^VPRJSOND
;
ENCODE(VVROOT,VVJSON,VVERR) ; VVROOT (M structure) --> VVJSON (array of strings)
; 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)
;
G DIRECT^VPRJSONE
;
;
ESC(X) ; Escape string for JSON
Q $$ESC^VPRJSONE(X)
;
UES(X) ; Unescape JSON string
Q $$UES^VPRJSOND(X)
;
ERRX(ID,VAL) ; Set the appropriate error message
; switch (ID) -- XERRX ends statement
N ERRMSG
;
; Decode Error Messages
;
I ID="STL{" S ERRMSG="Stack too large for new object." G XERRX
I ID="SUF}" S ERRMSG="Stack Underflow - extra } found" G XERRX
I ID="STL[" S ERRMSG="Stack too large for new array." G XERRX
I ID="SUF]" S ERRMSG="Stack Underflow - extra ] found." G XERRX
I ID="OBM" S ERRMSG="Array mismatch - expected ] got }." G XERRX
I ID="ARM" S ERRMSG="Object mismatch - expected } got ]." G XERRX
I ID="MPN" S ERRMSG="Missing property name." G XERRX
I ID="EXT" S ERRMSG="Expected true, got "_VAL G XERRX
I ID="EXF" S ERRMSG="Expected false, got "_VAL G XERRX
I ID="EXN" S ERRMSG="Expected null, got "_VAL G XERRX
I ID="TKN" S ERRMSG="Unable to identify type of token, value was "_VAL G XERRX
I ID="SCT" S ERRMSG="Stack mismatch - exit stack level was "_VAL G XERRX
I ID="EIQ" S ERRMSG="Close quote not found before end of input." G XERRX
I ID="EIU" S ERRMSG="Unexpected end of input while unescaping." G XERRX
I ID="RSB" S ERRMSG="Reverse search for \ past beginning of input." G XERRX
I ID="ORN" S ERRMSG="Overrun while scanning name." G XERRX
I ID="OR#" S ERRMSG="Overrun while scanning number." G XERRX
I ID="ORB" S ERRMSG="Overrun while scanning boolean." G XERRX
I ID="ESC" S ERRMSG="Escaped character not recognized"_VAL G XERRX
;
; Encode Error Messages
;
I ID="SOB" S ERRMSG="Unable to serialize node as object, value was "_VAL G XERRX
I ID="SAR" S ERRMSG="Unable to serialize node as array, value was "_VAL G XERRX
S ERRMSG="Unspecified error "_ID_" "_$G(VAL)
XERRX ; end switch
S @VVERR@(0)=$G(@VVERR@(0))+1
S @VVERR@(@VVERR@(0))=ERRMSG
S VVERRORS=VVERRORS+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRJSON 3206 printed Sep 23, 2025@20:21:45 Page 2
VPRJSON ;SLC/KCM -- Decode/Encode JSON ;8/14/13 11:22
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
+2 ;
+3 ; Note: Since the routines use closed array references, VVROOT and VVERR
+4 ; are used to reduce risk of naming conflicts on the closed array.
+5 ;
DECODE(VVJSON,VVROOT,VVERR) ; Set JSON object into closed array ref VVROOT
+1 ; Examples: D DECODE^VPRJSON("MYJSON","LOCALVAR","LOCALERR")
+2 ; D DECODE^VPRJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
+3 ;
+4 ; VVJSON: string/array containing serialized JSON object
+5 ; VVROOT: closed array reference for M representation of object
+6 ; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
+7 ;
+8 ; VVIDX: points to next character in JSON string to process
+9 ; VVSTACK: manages stack of subscripts
+10 ; VVPROP: true if next string is property name, otherwise treat as value
+11 ;
+12 GOTO DIRECT^VPRJSOND
+13 ;
ENCODE(VVROOT,VVJSON,VVERR) ; VVROOT (M structure) --> VVJSON (array of strings)
+1 ; Examples: D ENCODE^VPRJSON("^GLO(99,2)","^TMP($J)")
+2 ; D ENCODE^VPRJSON("LOCALVAR","MYJSON","LOCALERR")
+3 ;
+4 ; VVROOT: closed array reference for M representation of object
+5 ; VVJSON: destination variable for the string array formatted as JSON
+6 ; VVERR: contains error messages, defaults to ^TMP("VPRJERR",$J)
+7 ;
+8 GOTO DIRECT^VPRJSONE
+9 ;
+10 ;
ESC(X) ; Escape string for JSON
+1 QUIT $$ESC^VPRJSONE(X)
+2 ;
UES(X) ; Unescape JSON string
+1 QUIT $$UES^VPRJSOND(X)
+2 ;
ERRX(ID,VAL) ; Set the appropriate error message
+1 ; switch (ID) -- XERRX ends statement
+2 NEW ERRMSG
+3 ;
+4 ; Decode Error Messages
+5 ;
+6 IF ID="STL{"
SET ERRMSG="Stack too large for new object."
GOTO XERRX
+7 IF ID="SUF}"
SET ERRMSG="Stack Underflow - extra } found"
GOTO XERRX
+8 IF ID="STL["
SET ERRMSG="Stack too large for new array."
GOTO XERRX
+9 IF ID="SUF]"
SET ERRMSG="Stack Underflow - extra ] found."
GOTO XERRX
+10 IF ID="OBM"
SET ERRMSG="Array mismatch - expected ] got }."
GOTO XERRX
+11 IF ID="ARM"
SET ERRMSG="Object mismatch - expected } got ]."
GOTO XERRX
+12 IF ID="MPN"
SET ERRMSG="Missing property name."
GOTO XERRX
+13 IF ID="EXT"
SET ERRMSG="Expected true, got "_VAL
GOTO XERRX
+14 IF ID="EXF"
SET ERRMSG="Expected false, got "_VAL
GOTO XERRX
+15 IF ID="EXN"
SET ERRMSG="Expected null, got "_VAL
GOTO XERRX
+16 IF ID="TKN"
SET ERRMSG="Unable to identify type of token, value was "_VAL
GOTO XERRX
+17 IF ID="SCT"
SET ERRMSG="Stack mismatch - exit stack level was "_VAL
GOTO XERRX
+18 IF ID="EIQ"
SET ERRMSG="Close quote not found before end of input."
GOTO XERRX
+19 IF ID="EIU"
SET ERRMSG="Unexpected end of input while unescaping."
GOTO XERRX
+20 IF ID="RSB"
SET ERRMSG="Reverse search for \ past beginning of input."
GOTO XERRX
+21 IF ID="ORN"
SET ERRMSG="Overrun while scanning name."
GOTO XERRX
+22 IF ID="OR#"
SET ERRMSG="Overrun while scanning number."
GOTO XERRX
+23 IF ID="ORB"
SET ERRMSG="Overrun while scanning boolean."
GOTO XERRX
+24 IF ID="ESC"
SET ERRMSG="Escaped character not recognized"_VAL
GOTO XERRX
+25 ;
+26 ; Encode Error Messages
+27 ;
+28 IF ID="SOB"
SET ERRMSG="Unable to serialize node as object, value was "_VAL
GOTO XERRX
+29 IF ID="SAR"
SET ERRMSG="Unable to serialize node as array, value was "_VAL
GOTO XERRX
+30 SET ERRMSG="Unspecified error "_ID_" "_$GET(VAL)
XERRX ; end switch
+1 SET @VVERR@(0)=$GET(@VVERR@(0))+1
+2 SET @VVERR@(@VVERR@(0))=ERRMSG
+3 SET VVERRORS=VVERRORS+1
+4 QUIT
