- XLFJSON ;SLC/KCM/TJB - Decode/Encode JSON ;26 Oct 2016
- ;;8.0;KERNEL;**680**;Jul 10, 1995;Build 4
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Note: Since the routines use closed array references, XUROOT and XUERR
- ; are used to reduce risk of naming conflicts on the closed array.
- ;
- DECODE(XUJSON,XUROOT,XUERR) ; Set JSON object into closed array ref XUROOT
- ; Examples: D DECODE^XLFJSON("MYJSON","LOCALVAR","LOCALERR")
- ; D DECODE^XLFJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
- ;
- ; XUJSON: Required; string/array containing serialized JSON object
- ; XUROOT: Required; closed array reference for M representation of object
- ; XUERR: Optional; closed array reference contains error messages, defaults to ^TMP("XLFJERR",$J)
- ;
- ; XUIDX: points to next character in JSON string to process
- ; XUSTACK: manages stack of subscripts
- ; XUPROP: true if next string is property name, otherwise treat as value
- ;
- G DIRECT^XLFJSOND
- ;
- ENCODE(XUROOT,XUJSON,XUERR) ; XUROOT (M structure) --> XUJSON (array of strings)
- ; Examples: D ENCODE^XLFJSON("^GLO(99,2)","^TMP($J)")
- ; D ENCODE^XLFJSON("LOCALVAR","MYJSON","LOCALERR")
- ;
- ; XUROOT: Required; closed array reference for M representation of object
- ; XUJSON: Required; destination variable for the string array formatted as JSON
- ; XUERR: Optional; closed array reference contains error messages, defaults to ^TMP("XLFJERR",$J)
- ;
- G DIRECT^XLFJSONE
- ;
- ;
- ESC(X) ; Escape string for JSON
- ; X: Required; String to be escaped
- Q $$ESC^XLFJSONE(X)
- ;
- UES(X) ; Unescape JSON string
- ; X: Required; String to be unescaped
- Q $$UES^XLFJSOND(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
- I ID="NOV" S ERRMSG="Expected value, got "_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 @XUERR@(0)=$G(@XUERR@(0))+1
- S @XUERR@(@XUERR@(0))=ERRMSG
- S XUERRORS=XUERRORS+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFJSON 3495 printed Jan 18, 2025@03:03:56 Page 2
- XLFJSON ;SLC/KCM/TJB - Decode/Encode JSON ;26 Oct 2016
- +1 ;;8.0;KERNEL;**680**;Jul 10, 1995;Build 4
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Note: Since the routines use closed array references, XUROOT and XUERR
- +5 ; are used to reduce risk of naming conflicts on the closed array.
- +6 ;
- DECODE(XUJSON,XUROOT,XUERR) ; Set JSON object into closed array ref XUROOT
- +1 ; Examples: D DECODE^XLFJSON("MYJSON","LOCALVAR","LOCALERR")
- +2 ; D DECODE^XLFJSON("^MYJSON(1)","^GLO(99)","^TMP($J)")
- +3 ;
- +4 ; XUJSON: Required; string/array containing serialized JSON object
- +5 ; XUROOT: Required; closed array reference for M representation of object
- +6 ; XUERR: Optional; closed array reference contains error messages, defaults to ^TMP("XLFJERR",$J)
- +7 ;
- +8 ; XUIDX: points to next character in JSON string to process
- +9 ; XUSTACK: manages stack of subscripts
- +10 ; XUPROP: true if next string is property name, otherwise treat as value
- +11 ;
- +12 GOTO DIRECT^XLFJSOND
- +13 ;
- ENCODE(XUROOT,XUJSON,XUERR) ; XUROOT (M structure) --> XUJSON (array of strings)
- +1 ; Examples: D ENCODE^XLFJSON("^GLO(99,2)","^TMP($J)")
- +2 ; D ENCODE^XLFJSON("LOCALVAR","MYJSON","LOCALERR")
- +3 ;
- +4 ; XUROOT: Required; closed array reference for M representation of object
- +5 ; XUJSON: Required; destination variable for the string array formatted as JSON
- +6 ; XUERR: Optional; closed array reference contains error messages, defaults to ^TMP("XLFJERR",$J)
- +7 ;
- +8 GOTO DIRECT^XLFJSONE
- +9 ;
- +10 ;
- ESC(X) ; Escape string for JSON
- +1 ; X: Required; String to be escaped
- +2 QUIT $$ESC^XLFJSONE(X)
- +3 ;
- UES(X) ; Unescape JSON string
- +1 ; X: Required; String to be unescaped
- +2 QUIT $$UES^XLFJSOND(X)
- +3 ;
- 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 IF ID="NOV"
- SET ERRMSG="Expected value, got "_VAL
- GOTO XERRX
- +26 ;
- +27 ; Encode Error Messages
- +28 ;
- +29 IF ID="SOB"
- SET ERRMSG="Unable to serialize node as object, value was "_VAL
- GOTO XERRX
- +30 IF ID="SAR"
- SET ERRMSG="Unable to serialize node as array, value was "_VAL
- GOTO XERRX
- +31 SET ERRMSG="Unspecified error "_ID_" "_$GET(VAL)
- XERRX ; end switch
- +1 SET @XUERR@(0)=$GET(@XUERR@(0))+1
- +2 SET @XUERR@(@XUERR@(0))=ERRMSG
- +3 SET XUERRORS=XUERRORS+1
- +4 QUIT