YTWJSONO ;SLC/KCM - Instrument Admin Spec Output ; 1/25/2017
;;5.01;MENTAL HEALTH;**130,141,202**;Dec 30, 1994;Build 47
;
; Reference to XLFSTR in ICR #10104
;
TEST ;
N TEST,TREE,OUT
S TEST=7 ;144 ; CSI |153 ; CDR |162 ; BAM
D CONTENT^YTWJSON(TEST,.TREE)
D FMTJSON(.TREE,.OUT)
N I S I=0 F S I=$O(OUT(I)) Q:'I W !,OUT(I)
Q
FMTJSON(TREE,OUT) ; format instrument spec in TREE as readable lines
N LN,ROOT,SLOT,IDX
S LN=1,ROOT="TREE"
D TEXT("{")
D PROP("name"),LF(1)
I $L(@ROOT@("copyright")) D PROP("copyright"),LF(1)
D PROP("restartDays"),LF(1)
D PROP("printTitle"),LF(1)
D COMMA,TEXT("""content"":[")
S SLOT=0 F S SLOT=$O(TREE("content",SLOT)) Q:'SLOT D
. S ROOT=$NA(TREE("content",SLOT))
. D COMMA,LF(3)
. D TEXT("{")
. D PROP("id"),PROP("type"),PROP("required"),PROP("inline"),PROP("tab")
. D LF(4)
. D PROP("text")
. D LF(4)
. I $D(@ROOT@("intro")) D PROP("intro"),LF(4)
. D PROP("columns"),PROP("left"),PROP("controlWidth"),PROP("min"),PROP("max")
. ; output choices, if present
. I $D(TREE("content",SLOT,"choices"))>1 D
. . D COMMA,LF(4),TEXT("""choices"":[")
. . S IDX=0 F S IDX=$O(TREE("content",SLOT,"choices",IDX)) Q:'IDX D
. . . S ROOT=$NA(TREE("content",SLOT,"choices",IDX))
. . . D COMMA,LF(5)
. . . D TEXT("{"),PROP("id"),PROP("text"),PROP("quickKey"),TEXT("}")
. . D LF(3),TEXT("]") ; end of choices array
. ; output legend, if present
. I $D(TREE("content",SLOT,"legend"))>1 D
. . N LEGEND
. . D COMMA,LF(4),TEXT("""legend"":[")
. . S IDX=0 F S IDX=$O(TREE("content",SLOT,"legend",IDX)) Q:'IDX D
. . . S LEGEND=TREE("content",SLOT,"legend",IDX)
. . . D COMMA,TEXT(""""_LEGEND_"""")
. . D TEXT("]") ; end of legend array
. D TEXT("}") ; end of content object
D TEXT("]") ; end of content array
I $D(TREE("rules"))>1 D
. N RIDX,SIDX
. D COMMA,LF(1),TEXT("""rules"":[")
. S RIDX=0 F S RIDX=$O(TREE("rules",RIDX)) Q:'RIDX D
. . S ROOT=$NA(TREE("rules",RIDX))
. . D COMMA,LF(3),TEXT("{")
. . D PROP("question"),PROP("operator"),PROP("value")
. . I $D(TREE("rules",RIDX,"conjunction")) D
. . . D LF(4)
. . . D PROP("conjunction"),PROP("question2"),PROP("operator2"),PROP("value2")
. . I $D(TREE("rules",RIDX,"skips"))>1 D
. . . D COMMA,LF(4),TEXT("""skips"":[")
. . . S SIDX=0 F S SIDX=$O(TREE("rules",RIDX,"skips",SIDX)) Q:'SIDX D
. . . . I SIDX>1 D TEXT(",")
. . . . D TEXT(""""_TREE("rules",RIDX,"skips",SIDX)_"""")
. . . D TEXT("]") ; end of skips array
. . D TEXT("}") ; end of single rule object
. D TEXT("]") ; end of rules
D LF(0),TEXT("}") ; end of spec
Q
TEXT(X) ; Add text to output
; expects OUT,LN
S OUT(LN)=$G(OUT(LN))_X
Q
PROP(NAME) ; Add property to output, using JSON data types
; expects OUT,LN,ROOT
N X,VALUE
I '$D(@ROOT@(NAME)) QUIT ; property absent
;
; The "\n", "\s" qualifiers included for completeness but likely not needed
; for MH instruments. See VPRJSONE for more complete encoding of JSON
;
S X=@ROOT@(NAME) Q:'$L(X) ; empty value so quit
I $D(@ROOT@(NAME,"\n")) S VALUE=X ; forced numeric
I '$D(@ROOT@(NAME,"\s")) D ; if not forced string
. I X']]$C(1) S VALUE=X ; collates as numeric
. I X="true"!(X="false")!(X="null") S VALUE=X ; boolean/null
I '$D(VALUE),'$D(@ROOT@(NAME,"\")),($L(X)<80) S VALUE=""""_X_"""" ; string
I $D(VALUE) D QUIT ; finish up unless word proc
. D COMMA ; prepend comma if not first
. S OUT(LN)=OUT(LN)_""""_NAME_""": "_VALUE ; add to output line
;
; fall through here for handling word processing and longer strings
; (to keep lines short enough for MailMan to transport them
N IDX,TEXT
S IDX=0 F S IDX=$O(@ROOT@(NAME,"\",IDX)) Q:'IDX S X=X_@ROOT@(NAME,"\",IDX)
D WRAPTXT^YTWJSONU(X,.TEXT)
D COMMA
S OUT(LN)=OUT(LN)_""""_NAME_""": """_TEXT(1) ; first WP line
S IDX=1 F S IDX=$O(TEXT(IDX)) Q:'IDX S LN=LN+1,OUT(LN)=TEXT(IDX)
S OUT(LN)=OUT(LN)_"""" ; closing quote
Q
COMMA ; Add comma, if needed, before adding property
; expects OUT,LN
N LAST S LAST=$$LAST
I "{["'[LAST D ; see if we need a comma based on the last character
. I $L($TR($G(OUT(LN))," ","")) S OUT(LN)=OUT(LN)_", " Q ; use this line
. S OUT(LN-1)=OUT(LN-1)_", " ; use last line
Q
LAST() ; Return the last non-space character
; expects OUT,LN
N X
S X=$TR($G(OUT(LN))," ","")
I '$L(X) S X=$TR($G(OUT(LN-1))," ","")
Q $E(X,$L(X))
;
LF(SPACES) ; advance to next line, using indent level in SPACES
; expects OUT,LN
S LN=+$G(LN)+1 ; line number
S OUT(LN)=$$REPEAT^XLFSTR(" ",SPACES)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTWJSONO 5066 printed Apr 09, 2024@21:22:54 Page 2
YTWJSONO ;SLC/KCM - Instrument Admin Spec Output ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130,141,202**;Dec 30, 1994;Build 47
+2 ;
+3 ; Reference to XLFSTR in ICR #10104
+4 ;
TEST ;
+1 NEW TEST,TREE,OUT
+2 ;144 ; CSI |153 ; CDR |162 ; BAM
SET TEST=7
+3 DO CONTENT^YTWJSON(TEST,.TREE)
+4 DO FMTJSON(.TREE,.OUT)
+5 NEW I
SET I=0
FOR
SET I=$ORDER(OUT(I))
if 'I
QUIT
WRITE !,OUT(I)
+6 QUIT
FMTJSON(TREE,OUT) ; format instrument spec in TREE as readable lines
+1 NEW LN,ROOT,SLOT,IDX
+2 SET LN=1
SET ROOT="TREE"
+3 DO TEXT("{")
+4 DO PROP("name")
DO LF(1)
+5 IF $LENGTH(@ROOT@("copyright"))
DO PROP("copyright")
DO LF(1)
+6 DO PROP("restartDays")
DO LF(1)
+7 DO PROP("printTitle")
DO LF(1)
+8 DO COMMA
DO TEXT("""content"":[")
+9 SET SLOT=0
FOR
SET SLOT=$ORDER(TREE("content",SLOT))
if 'SLOT
QUIT
Begin DoDot:1
+10 SET ROOT=$NAME(TREE("content",SLOT))
+11 DO COMMA
DO LF(3)
+12 DO TEXT("{")
+13 DO PROP("id")
DO PROP("type")
DO PROP("required")
DO PROP("inline")
DO PROP("tab")
+14 DO LF(4)
+15 DO PROP("text")
+16 DO LF(4)
+17 IF $DATA(@ROOT@("intro"))
DO PROP("intro")
DO LF(4)
+18 DO PROP("columns")
DO PROP("left")
DO PROP("controlWidth")
DO PROP("min")
DO PROP("max")
+19 ; output choices, if present
+20 IF $DATA(TREE("content",SLOT,"choices"))>1
Begin DoDot:2
+21 DO COMMA
DO LF(4)
DO TEXT("""choices"":[")
+22 SET IDX=0
FOR
SET IDX=$ORDER(TREE("content",SLOT,"choices",IDX))
if 'IDX
QUIT
Begin DoDot:3
+23 SET ROOT=$NAME(TREE("content",SLOT,"choices",IDX))
+24 DO COMMA
DO LF(5)
+25 DO TEXT("{")
DO PROP("id")
DO PROP("text")
DO PROP("quickKey")
DO TEXT("}")
End DoDot:3
+26 ; end of choices array
DO LF(3)
DO TEXT("]")
End DoDot:2
+27 ; output legend, if present
+28 IF $DATA(TREE("content",SLOT,"legend"))>1
Begin DoDot:2
+29 NEW LEGEND
+30 DO COMMA
DO LF(4)
DO TEXT("""legend"":[")
+31 SET IDX=0
FOR
SET IDX=$ORDER(TREE("content",SLOT,"legend",IDX))
if 'IDX
QUIT
Begin DoDot:3
+32 SET LEGEND=TREE("content",SLOT,"legend",IDX)
+33 DO COMMA
DO TEXT(""""_LEGEND_"""")
End DoDot:3
+34 ; end of legend array
DO TEXT("]")
End DoDot:2
+35 ; end of content object
DO TEXT("}")
End DoDot:1
+36 ; end of content array
DO TEXT("]")
+37 IF $DATA(TREE("rules"))>1
Begin DoDot:1
+38 NEW RIDX,SIDX
+39 DO COMMA
DO LF(1)
DO TEXT("""rules"":[")
+40 SET RIDX=0
FOR
SET RIDX=$ORDER(TREE("rules",RIDX))
if 'RIDX
QUIT
Begin DoDot:2
+41 SET ROOT=$NAME(TREE("rules",RIDX))
+42 DO COMMA
DO LF(3)
DO TEXT("{")
+43 DO PROP("question")
DO PROP("operator")
DO PROP("value")
+44 IF $DATA(TREE("rules",RIDX,"conjunction"))
Begin DoDot:3
+45 DO LF(4)
+46 DO PROP("conjunction")
DO PROP("question2")
DO PROP("operator2")
DO PROP("value2")
End DoDot:3
+47 IF $DATA(TREE("rules",RIDX,"skips"))>1
Begin DoDot:3
+48 DO COMMA
DO LF(4)
DO TEXT("""skips"":[")
+49 SET SIDX=0
FOR
SET SIDX=$ORDER(TREE("rules",RIDX,"skips",SIDX))
if 'SIDX
QUIT
Begin DoDot:4
+50 IF SIDX>1
DO TEXT(",")
+51 DO TEXT(""""_TREE("rules",RIDX,"skips",SIDX)_"""")
End DoDot:4
+52 ; end of skips array
DO TEXT("]")
End DoDot:3
+53 ; end of single rule object
DO TEXT("}")
End DoDot:2
+54 ; end of rules
DO TEXT("]")
End DoDot:1
+55 ; end of spec
DO LF(0)
DO TEXT("}")
+56 QUIT
TEXT(X) ; Add text to output
+1 ; expects OUT,LN
+2 SET OUT(LN)=$GET(OUT(LN))_X
+3 QUIT
PROP(NAME) ; Add property to output, using JSON data types
+1 ; expects OUT,LN,ROOT
+2 NEW X,VALUE
+3 ; property absent
IF '$DATA(@ROOT@(NAME))
QUIT
+4 ;
+5 ; The "\n", "\s" qualifiers included for completeness but likely not needed
+6 ; for MH instruments. See VPRJSONE for more complete encoding of JSON
+7 ;
+8 ; empty value so quit
SET X=@ROOT@(NAME)
if '$LENGTH(X)
QUIT
+9 ; forced numeric
IF $DATA(@ROOT@(NAME,"\n"))
SET VALUE=X
+10 ; if not forced string
IF '$DATA(@ROOT@(NAME,"\s"))
Begin DoDot:1
+11 ; collates as numeric
IF X']]$CHAR(1)
SET VALUE=X
+12 ; boolean/null
IF X="true"!(X="false")!(X="null")
SET VALUE=X
End DoDot:1
+13 ; string
IF '$DATA(VALUE)
IF '$DATA(@ROOT@(NAME,"\"))
IF ($LENGTH(X)<80)
SET VALUE=""""_X_""""
+14 ; finish up unless word proc
IF $DATA(VALUE)
Begin DoDot:1
+15 ; prepend comma if not first
DO COMMA
+16 ; add to output line
SET OUT(LN)=OUT(LN)_""""_NAME_""": "_VALUE
End DoDot:1
QUIT
+17 ;
+18 ; fall through here for handling word processing and longer strings
+19 ; (to keep lines short enough for MailMan to transport them
+20 NEW IDX,TEXT
+21 SET IDX=0
FOR
SET IDX=$ORDER(@ROOT@(NAME,"\",IDX))
if 'IDX
QUIT
SET X=X_@ROOT@(NAME,"\",IDX)
+22 DO WRAPTXT^YTWJSONU(X,.TEXT)
+23 DO COMMA
+24 ; first WP line
SET OUT(LN)=OUT(LN)_""""_NAME_""": """_TEXT(1)
+25 SET IDX=1
FOR
SET IDX=$ORDER(TEXT(IDX))
if 'IDX
QUIT
SET LN=LN+1
SET OUT(LN)=TEXT(IDX)
+26 ; closing quote
SET OUT(LN)=OUT(LN)_""""
+27 QUIT
COMMA ; Add comma, if needed, before adding property
+1 ; expects OUT,LN
+2 NEW LAST
SET LAST=$$LAST
+3 ; see if we need a comma based on the last character
IF "{["'[LAST
Begin DoDot:1
+4 ; use this line
IF $LENGTH($TRANSLATE($GET(OUT(LN))," ",""))
SET OUT(LN)=OUT(LN)_", "
QUIT
+5 ; use last line
SET OUT(LN-1)=OUT(LN-1)_", "
End DoDot:1
+6 QUIT
LAST() ; Return the last non-space character
+1 ; expects OUT,LN
+2 NEW X
+3 SET X=$TRANSLATE($GET(OUT(LN))," ","")
+4 IF '$LENGTH(X)
SET X=$TRANSLATE($GET(OUT(LN-1))," ","")
+5 QUIT $EXTRACT(X,$LENGTH(X))
+6 ;
LF(SPACES) ; advance to next line, using indent level in SPACES
+1 ; expects OUT,LN
+2 ; line number
SET LN=+$GET(LN)+1
+3 SET OUT(LN)=$$REPEAT^XLFSTR(" ",SPACES)
+4 QUIT
