forked from KRMAssociatesInc/JDS-GTM
-
Notifications
You must be signed in to change notification settings - Fork 0
/
VPRJSONE.m
executable file
·145 lines (145 loc) · 5.82 KB
/
VPRJSONE.m
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
VPRJSONE ;SLC/KCM -- Encode JSON
;;1.0;VIRTUAL PATIENT RECORD;**2,3**;Sep 01, 2011;Build 50
;
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
;
; V4W/DLW - Changed VVMAX from 4000 (just under the 4096 string size limit)
; to 100. With large data arrays, the JSON encoder could exhaust system
; memory, which required a switch to globals to fix. However, 4000 as a
; limit slowed the encoder down quite a bit, when using globals.
; With the change to VVMAX, the following Unit Tests required changes:
; METHOD1^VPRJTCT1, METHOD2^VPRJTCT1, METHOD3^VPRJTCT1,
; METHOD4^VPRJTCT1, METHOD5^VPRJTCT1, ODS1^VPRJTCT1,
; REV1^VPRJTCT1, REV2^VPRJTCT1, REV3^VPRJTCT1, PURENUM^VPRJUJD,
; ESTRING^VPRJUJD, BASIC^VPRJUJE, VALS^VPRJUJE, LONG^VPRJUJE,
; PRE^VPRJUJE, WP^VPRJUJE, EXAMPLE^VPRJUJE
S VVLINE=1,VVMAX=100,VVERRORS=0 ; limit document lines to 100 characters
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
. . ; Need to check if numeric representation matches string representation to decide if it is an array
. . I +VVNXT=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
. . ; Need to check if numeric representation matches string representation to decide if it is an array
. . I +VVNXT=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 $E(VVSUB)="""" S VVSUB=$E(VVSUB,2,$L(VVSUB)) ; quote indicates numeric label
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,VVDONE
; 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)),VVDONE=0
; handle the numeric, boolean, and null types
I $D(@VVROOT@(VVSUB,"\n")) S:$L(@VVROOT@(VVSUB,"\n")) VVX=@VVROOT@(VVSUB,"\n") D CONCAT QUIT ; when +X'=X
I '$D(@VVROOT@(VVSUB,"\s")),$L(VVX) D QUIT:VVDONE
. I VVX']]$C(1) S VVX=$$JNUM(VVX) D CONCAT S VVDONE=1 QUIT
. I VVX="true"!(VVX="false")!(VVX="null") D CONCAT S VVDONE=1 QUIT
; 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 ; word processing continuation node
Q:VVX=":" 1 ; pre-formatted JSON node
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
;
JNUM(N) ; Return JSON representation of a number
I N'<1 Q N
I N'>-1 Q N
I N>0 Q "0"_N
I N<0 Q "-0"_$P(N,"-",2,9)
Q N
;
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