YTXCHGT ;SLC/KCM - JSON / Tree Conversions ; 9/15/2015
;;5.01;MENTAL HEALTH;**121,123,130,202**;Dec 30, 1994;Build 47
;
; Reference to VPRJSON supported by IA #6411
;
; SRC,DEST are global or local array references
;
MHA2TR(TEST,DEST) ; Load MHA test into DEST tree
D EXPORT^YTXCHGE(TEST,DEST)
Q
TR2MHA(TREE,YTXDRY) ; Save SRC tree into MHA file entries
; TREE: closed reference to node that represents 1 instrument
; YTXDRY: defined and true if this is just a dry run
N SEQ,PREFIX,TESTNM,NEWDT
S PREFIX=$S($G(YTXDRY):"Trial install for ",1:"Installing ")
S SEQ=0 F S SEQ=$O(@TREE@("test",SEQ)) Q:'SEQ D
. N YTXLOG S YTXLOG=1
. S TESTNM=@TREE@("test",SEQ,"info","name")
. D LOG^YTXCHGU("info",PREFIX_TESTNM)
. ; if not a dry run, do a test pass first and look for conflicts
. I '$G(YTXDRY) D IMPTREE^YTXCHGI($NA(@TREE@("test",SEQ)),2)
. I $G(YTXLOG("conflict")) D SHOSUMM^YTXCHGP(.YTXLOG,1) QUIT
. ; do a dry run or actual pass
. K YTXLOG S YTXLOG=1
. I '$G(YTXDRY) D BACKUP^YTXCHGU(@TREE@("test",SEQ,"info","name"))
. D IMPTREE^YTXCHGI($NA(@TREE@("test",SEQ)),YTXDRY)
. D SHOSUMM^YTXCHGP(.YTXLOG,YTXDRY)
. D LOG^YTXCHGU("info",$S($G(DRYRUN):"Trial install",1:"Installation")_" complete."_$S($G(DRYRUN):" (No changes made)",1:""))
. Q:$G(YTXDRY)
. S NEWDT=@TREE@("test",SEQ,"info","lastEditDate")
. I ($G(YTXLOG("added"))+$G(YTXLOG("updated")))>0 D NEWDATE^YTXCHGU(TESTNM,NEWDT)
. D FILE96^YTWJSONF(@TREE@("test",SEQ,"info","name")) ; move new instrument to 601.96
Q
TR2JSON(SRC,DEST) ; Convert tree representation to JSON
N JSONERR,INTERIM,OK
S INTERIM=$NA(^TMP("YTXCHG",$J,"INTERIM"))
K @INTERIM
I $E(DEST)=U,($E(DEST,1,4)'="^TMP") K @DEST ; empty DEST
D ENCODE^VPRJSON(SRC,INTERIM,"JSONERR")
I $D(JSONERR) D LOG^YTXCHGU("error","JSON encode, "_$G(JSONERR(1))) Q 0
D SPLITLN(INTERIM,DEST) ; split into smaller lines for Fileman
K @INTERIM
Q 1
;
JSON2TR(SRC,DEST) ; Convert JSON to tree representation
; returns 1 if converted without error
; SRC contains JSON representation
; DEST is $NA value and should be empty
N JSONERR
D DECODE^VPRJSON(SRC,DEST,"JSONERR")
I $D(JSONERR) D LOG^YTXCHGU("error","JSON decode, "_$G(JSONERR(1))) Q 0
Q 1
;
SPEC2TR(XCHGIEN,DEST) ; Convert JSON WP entry in 601.95 to tree representation
; returns 1 if converted without error
; DEST is $NA value and should be empty
K ^TMP("YTXCHG",$J,"JSONTMP")
N I,JSONERR
; convert main specification from JSON to TREE
S I=0 F S I=$O(^YTT(601.95,XCHGIEN,1,I)) Q:'I S ^TMP("YTXCHG",$J,"JSONTMP",I)=^YTT(601.95,XCHGIEN,1,I,0)
D DECODE^VPRJSON($NA(^TMP("YTXCHG",$J,"JSONTMP")),DEST,"JSONERR")
K ^TMP("YTXCHG",$J,"JSONTMP")
I $D(JSONERR) D LOG^YTXCHGU("error","JSON decode, "_$G(JSONERR(1))) Q 0
D ADDEND(XCHGIEN)
Q 1
;
ADDEND(XCHGIEN) ; Process any contents in addendum
; example: {"ignoreConflicts": ["601.72:6488","601.72:6491","601.72:6734"]}
N I,X,ARRAY
D ADD2TR(XCHGIEN,.ARRAY) Q:'$D(ARRAY)
K ^XTMP("YTXIDX","ignore")
S I=0 F S I=$O(ARRAY("ignoreConflicts",I)) Q:'I D
. S X=ARRAY("ignoreConflicts",I)
. S ^XTMP("YTXIDX","ignore",+$P(X,":"),+$P(X,":",2))=""
Q
CHKSCORE(XCHGIEN) ; Check addendum for instruments that should be re-scored
; example: {"rescoreInstruments":["PCL-5"]}
N I,X,ARRAY,IEN,REV
D ADD2TR(XCHGIEN,.ARRAY) Q:'$D(ARRAY)
S I=0 F S I=$O(ARRAY("rescoreInstruments",I)) Q:'I D
. S X=ARRAY("rescoreInstruments",I)
. S IEN=$O(^YTT(601.71,"B",X,0)) Q:'IEN
. S REV=$P($G(^YTT(601.71,IEN,9)),U,3) Q:'REV
. D QTASK^YTSCOREV(IEN_"~"_REV,($H+1)_",3600") ; queue rescoring (T+1@1am)
Q
ADD2TR(XCHGIEN,ARRAY) ; Load Addendum JSON into TREE
N I,JSONTMP,JSONERR
S I=0 F S I=$O(^YTT(601.95,XCHGIEN,4,I)) Q:'I S JSONTMP(I)=^YTT(601.95,XCHGIEN,4,I,0)
Q:'$D(JSONTMP)
D DECODE^VPRJSON("JSONTMP","ARRAY","JSONERR")
I $D(JSONERR) D LOG^YTXCHGU("error","Addendum decode, "_$G(JSONERR(1))) Q
Q
JSON2WP(SRC,DEST) ; Convert JSON array (n) to WP array (n,0)
N I
S I=0 F S I=$O(@SRC@(I)) Q:'I S @DEST@(I,0)=@SRC@(I)
Q
WP2TR(SRC,DEST) ; Convert FM WP field to tree representation
; SRC: glvn of source array
; DEST: glvn of destination array
I $E(DEST)=U,($E(DEST,1,4)'="^TMP") K @DEST ; empty DEST
N LN S LN=0
F S LN=$O(@SRC@(LN)) Q:'LN D
. I LN=1 S @DEST=@SRC@(LN,0) I 1
. E S @DEST@("\",LN-1)=$C(13,10)_@SRC@(LN,0)
Q
TR2WP(SRC,DEST) ; Convert tree representation to FM WP
; SRC: glvn of source array (JSON node with wp text)
; DEST: glvn of destination array (will add [line,0] nodes)
N I,J,X,LN
S LN=0,X=$TR($G(@SRC),$C(13)) ; drop CR and only parse on LF
F J=1:1:$L(X,$C(10)) S LN=LN+1,@DEST@(LN,0)=$P(X,$C(10),J)
S I=0 F S I=$O(@SRC@("\",I)) Q:'I D
. S X=$TR(@SRC@("\",I),$C(13)) ; drop CR and only parse on LF (in \ nodes)
. F J=1:1:$L(X,$C(10)) D
. . I J=1 S @DEST@(LN,0)=@DEST@(LN,0)_$P(X,$C(10),1) I 1
. . E S LN=LN+1,@DEST@(LN,0)=$P(X,$C(10),J)
Q
SPLITLN(SRC,DEST,MAX) ; Split JSON lines into lines of MAX length
N I,LN,X
S MAX=$G(MAX,240) S:MAX'>0 MAX=240 ; MAX default is 240
S LN=0,I=0 F S I=$O(@SRC@(I)) Q:'I D
. S X=@SRC@(I)
. F S LN=LN+1,@DEST@(LN)=$E(X,1,MAX),X=$E(X,MAX+1,99999) Q:'$L(X)
Q
;
TEST2WP ; test TR2WP entry point
N JSON,TEXT
S JSON("wp")="This is line 1."_$C(13,10)_"This is line 2."_$C(13,10)_"This is "
S JSON("wp","\",1)="line 3."_$C(13,10)_"This is line 4."_$C(13,10)_"This is line "
S JSON("wp","\",2)="5."_$C(13,10)_"This is the last line."
D TR2WP($NA(JSON("wp")),$NA(TEXT(2)))
; ZW TEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTXCHGT 5568 printed Dec 13, 2024@02:22:09 Page 2
YTXCHGT ;SLC/KCM - JSON / Tree Conversions ; 9/15/2015
+1 ;;5.01;MENTAL HEALTH;**121,123,130,202**;Dec 30, 1994;Build 47
+2 ;
+3 ; Reference to VPRJSON supported by IA #6411
+4 ;
+5 ; SRC,DEST are global or local array references
+6 ;
MHA2TR(TEST,DEST) ; Load MHA test into DEST tree
+1 DO EXPORT^YTXCHGE(TEST,DEST)
+2 QUIT
TR2MHA(TREE,YTXDRY) ; Save SRC tree into MHA file entries
+1 ; TREE: closed reference to node that represents 1 instrument
+2 ; YTXDRY: defined and true if this is just a dry run
+3 NEW SEQ,PREFIX,TESTNM,NEWDT
+4 SET PREFIX=$SELECT($GET(YTXDRY):"Trial install for ",1:"Installing ")
+5 SET SEQ=0
FOR
SET SEQ=$ORDER(@TREE@("test",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+6 NEW YTXLOG
SET YTXLOG=1
+7 SET TESTNM=@TREE@("test",SEQ,"info","name")
+8 DO LOG^YTXCHGU("info",PREFIX_TESTNM)
+9 ; if not a dry run, do a test pass first and look for conflicts
+10 IF '$GET(YTXDRY)
DO IMPTREE^YTXCHGI($NAME(@TREE@("test",SEQ)),2)
+11 IF $GET(YTXLOG("conflict"))
DO SHOSUMM^YTXCHGP(.YTXLOG,1)
QUIT
+12 ; do a dry run or actual pass
+13 KILL YTXLOG
SET YTXLOG=1
+14 IF '$GET(YTXDRY)
DO BACKUP^YTXCHGU(@TREE@("test",SEQ,"info","name"))
+15 DO IMPTREE^YTXCHGI($NAME(@TREE@("test",SEQ)),YTXDRY)
+16 DO SHOSUMM^YTXCHGP(.YTXLOG,YTXDRY)
+17 DO LOG^YTXCHGU("info",$SELECT($GET(DRYRUN):"Trial install",1:"Installation")_" complete."_$SELECT($GET(DRYRUN):" (No changes made)",1:""))
+18 if $GET(YTXDRY)
QUIT
+19 SET NEWDT=@TREE@("test",SEQ,"info","lastEditDate")
+20 IF ($GET(YTXLOG("added"))+$GET(YTXLOG("updated")))>0
DO NEWDATE^YTXCHGU(TESTNM,NEWDT)
+21 ; move new instrument to 601.96
DO FILE96^YTWJSONF(@TREE@("test",SEQ,"info","name"))
End DoDot:1
+22 QUIT
TR2JSON(SRC,DEST) ; Convert tree representation to JSON
+1 NEW JSONERR,INTERIM,OK
+2 SET INTERIM=$NAME(^TMP("YTXCHG",$JOB,"INTERIM"))
+3 KILL @INTERIM
+4 ; empty DEST
IF $EXTRACT(DEST)=U
IF ($EXTRACT(DEST,1,4)'="^TMP")
KILL @DEST
+5 DO ENCODE^VPRJSON(SRC,INTERIM,"JSONERR")
+6 IF $DATA(JSONERR)
DO LOG^YTXCHGU("error","JSON encode, "_$GET(JSONERR(1)))
QUIT 0
+7 ; split into smaller lines for Fileman
DO SPLITLN(INTERIM,DEST)
+8 KILL @INTERIM
+9 QUIT 1
+10 ;
JSON2TR(SRC,DEST) ; Convert JSON to tree representation
+1 ; returns 1 if converted without error
+2 ; SRC contains JSON representation
+3 ; DEST is $NA value and should be empty
+4 NEW JSONERR
+5 DO DECODE^VPRJSON(SRC,DEST,"JSONERR")
+6 IF $DATA(JSONERR)
DO LOG^YTXCHGU("error","JSON decode, "_$GET(JSONERR(1)))
QUIT 0
+7 QUIT 1
+8 ;
SPEC2TR(XCHGIEN,DEST) ; Convert JSON WP entry in 601.95 to tree representation
+1 ; returns 1 if converted without error
+2 ; DEST is $NA value and should be empty
+3 KILL ^TMP("YTXCHG",$JOB,"JSONTMP")
+4 NEW I,JSONERR
+5 ; convert main specification from JSON to TREE
+6 SET I=0
FOR
SET I=$ORDER(^YTT(601.95,XCHGIEN,1,I))
if 'I
QUIT
SET ^TMP("YTXCHG",$JOB,"JSONTMP",I)=^YTT(601.95,XCHGIEN,1,I,0)
+7 DO DECODE^VPRJSON($NAME(^TMP("YTXCHG",$JOB,"JSONTMP")),DEST,"JSONERR")
+8 KILL ^TMP("YTXCHG",$JOB,"JSONTMP")
+9 IF $DATA(JSONERR)
DO LOG^YTXCHGU("error","JSON decode, "_$GET(JSONERR(1)))
QUIT 0
+10 DO ADDEND(XCHGIEN)
+11 QUIT 1
+12 ;
ADDEND(XCHGIEN) ; Process any contents in addendum
+1 ; example: {"ignoreConflicts": ["601.72:6488","601.72:6491","601.72:6734"]}
+2 NEW I,X,ARRAY
+3 DO ADD2TR(XCHGIEN,.ARRAY)
if '$DATA(ARRAY)
QUIT
+4 KILL ^XTMP("YTXIDX","ignore")
+5 SET I=0
FOR
SET I=$ORDER(ARRAY("ignoreConflicts",I))
if 'I
QUIT
Begin DoDot:1
+6 SET X=ARRAY("ignoreConflicts",I)
+7 SET ^XTMP("YTXIDX","ignore",+$PIECE(X,":"),+$PIECE(X,":",2))=""
End DoDot:1
+8 QUIT
CHKSCORE(XCHGIEN) ; Check addendum for instruments that should be re-scored
+1 ; example: {"rescoreInstruments":["PCL-5"]}
+2 NEW I,X,ARRAY,IEN,REV
+3 DO ADD2TR(XCHGIEN,.ARRAY)
if '$DATA(ARRAY)
QUIT
+4 SET I=0
FOR
SET I=$ORDER(ARRAY("rescoreInstruments",I))
if 'I
QUIT
Begin DoDot:1
+5 SET X=ARRAY("rescoreInstruments",I)
+6 SET IEN=$ORDER(^YTT(601.71,"B",X,0))
if 'IEN
QUIT
+7 SET REV=$PIECE($GET(^YTT(601.71,IEN,9)),U,3)
if 'REV
QUIT
+8 ; queue rescoring (T+1@1am)
DO QTASK^YTSCOREV(IEN_"~"_REV,($HOROLOG+1)_",3600")
End DoDot:1
+9 QUIT
ADD2TR(XCHGIEN,ARRAY) ; Load Addendum JSON into TREE
+1 NEW I,JSONTMP,JSONERR
+2 SET I=0
FOR
SET I=$ORDER(^YTT(601.95,XCHGIEN,4,I))
if 'I
QUIT
SET JSONTMP(I)=^YTT(601.95,XCHGIEN,4,I,0)
+3 if '$DATA(JSONTMP)
QUIT
+4 DO DECODE^VPRJSON("JSONTMP","ARRAY","JSONERR")
+5 IF $DATA(JSONERR)
DO LOG^YTXCHGU("error","Addendum decode, "_$GET(JSONERR(1)))
QUIT
+6 QUIT
JSON2WP(SRC,DEST) ; Convert JSON array (n) to WP array (n,0)
+1 NEW I
+2 SET I=0
FOR
SET I=$ORDER(@SRC@(I))
if 'I
QUIT
SET @DEST@(I,0)=@SRC@(I)
+3 QUIT
WP2TR(SRC,DEST) ; Convert FM WP field to tree representation
+1 ; SRC: glvn of source array
+2 ; DEST: glvn of destination array
+3 ; empty DEST
IF $EXTRACT(DEST)=U
IF ($EXTRACT(DEST,1,4)'="^TMP")
KILL @DEST
+4 NEW LN
SET LN=0
+5 FOR
SET LN=$ORDER(@SRC@(LN))
if 'LN
QUIT
Begin DoDot:1
+6 IF LN=1
SET @DEST=@SRC@(LN,0)
IF 1
+7 IF '$TEST
SET @DEST@("\",LN-1)=$CHAR(13,10)_@SRC@(LN,0)
End DoDot:1
+8 QUIT
TR2WP(SRC,DEST) ; Convert tree representation to FM WP
+1 ; SRC: glvn of source array (JSON node with wp text)
+2 ; DEST: glvn of destination array (will add [line,0] nodes)
+3 NEW I,J,X,LN
+4 ; drop CR and only parse on LF
SET LN=0
SET X=$TRANSLATE($GET(@SRC),$CHAR(13))
+5 FOR J=1:1:$LENGTH(X,$CHAR(10))
SET LN=LN+1
SET @DEST@(LN,0)=$PIECE(X,$CHAR(10),J)
+6 SET I=0
FOR
SET I=$ORDER(@SRC@("\",I))
if 'I
QUIT
Begin DoDot:1
+7 ; drop CR and only parse on LF (in \ nodes)
SET X=$TRANSLATE(@SRC@("\",I),$CHAR(13))
+8 FOR J=1:1:$LENGTH(X,$CHAR(10))
Begin DoDot:2
+9 IF J=1
SET @DEST@(LN,0)=@DEST@(LN,0)_$PIECE(X,$CHAR(10),1)
IF 1
+10 IF '$TEST
SET LN=LN+1
SET @DEST@(LN,0)=$PIECE(X,$CHAR(10),J)
End DoDot:2
End DoDot:1
+11 QUIT
SPLITLN(SRC,DEST,MAX) ; Split JSON lines into lines of MAX length
+1 NEW I,LN,X
+2 ; MAX default is 240
SET MAX=$GET(MAX,240)
if MAX'>0
SET MAX=240
+3 SET LN=0
SET I=0
FOR
SET I=$ORDER(@SRC@(I))
if 'I
QUIT
Begin DoDot:1
+4 SET X=@SRC@(I)
+5 FOR
SET LN=LN+1
SET @DEST@(LN)=$EXTRACT(X,1,MAX)
SET X=$EXTRACT(X,MAX+1,99999)
if '$LENGTH(X)
QUIT
End DoDot:1
+6 QUIT
+7 ;
TEST2WP ; test TR2WP entry point
+1 NEW JSON,TEXT
+2 SET JSON("wp")="This is line 1."_$CHAR(13,10)_"This is line 2."_$CHAR(13,10)_"This is "
+3 SET JSON("wp","\",1)="line 3."_$CHAR(13,10)_"This is line 4."_$CHAR(13,10)_"This is line "
+4 SET JSON("wp","\",2)="5."_$CHAR(13,10)_"This is the last line."
+5 DO TR2WP($NAME(JSON("wp")),$NAME(TEXT(2)))
+6 ; ZW TEXT
+7 QUIT
