Routine: VPRJSON

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRJSON   3206     printed  Apr 09, 2024@21:47:42                                                                                                                                                                                                     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

VPRJSON.m