YTWJSONF ;SLC/KCM - File/Export JSON versions of instruments ; 7/20/2018
;;5.01;MENTAL HEALTH;**130,141**;Dec 30, 1994;Build 85
;
; External Reference ICR#
; ------------------ -----
; %ZISH 2320
; XPDUTL 10141
;
SAVEDIR ; Save all active instruments to directory
; may need to first remove current files from the destination directory
; (this doesn't clean up the destination directory first)
N PATH
S PATH=$$PROMPT^YTWJSONU("Destination Directory") Q:'$L(PATH)
D LPACTV(PATH)
D LIST(PATH)
Q
SAVE96 ; Save all active instruments as JSON in 601.96
D DEL96 ; remove the current entries for active instruments
D LPACTV("") ; empty path causes save to 601.96
D LIST96
Q
;
LPACTV(PATH) ; Loop thru all active instruments to create JSON documents
; PATH: if empty, JSON documents are saved to 601.96
; otherwise, this specifics the host directory
N TEST
S TEST=0 F S TEST=$O(^YTT(601.71,TEST)) Q:'TEST D
. I $P($G(^YTT(601.71,TEST,2)),U,2)'="Y" QUIT
. I '$L($G(PATH)) D FILE96(TEST) W "."
. I $L($G(PATH)) D FILE(TEST,PATH) W "."
Q
;
; -- calls to write to 601.96
;
DEL96 ; Delete active instruments from 601.96
N NM,IEN
S NM="YTT " F S NM=$O(^YTT(601.96,"B",NM)) Q:$E(NM,1,4)'="YTT " D
. S IEN=$O(^YTT(601.96,"B",NM,0))
. D FMDEL^YTXCHGU(601.96,IEN)
S IEN=$O(^YTT(601.96,"B","YTL ACTIVE",0))
D FMDEL^YTXCHGU(601.96,IEN)
Q
FILE96(TEST) ; save JSON test to 601.96
I TEST'=+TEST S TEST=$O(^YTT(601.71,"B",TEST,0)) Q:'TEST
Q:'$D(^YTT(601.71,TEST,0))
;
N REC,JSON,IEN
S REC(.01)="YTT "_$P(^YTT(601.71,TEST,0),U)
S REC(.02)=1
S REC(1)="JSON"
S IEN=$O(^YTT(601.96,"B",REC(.01),0))
D GETSPEC^YTWJSON(.JSON,TEST)
I '$D(JSON) D QUIT
. D MES^XPDUTL("Error creating JSON for "_$P(^YTT(601.71,TEST,0),U))
;
I IEN D FMUPD^YTXCHGU(601.96,.REC,IEN) I 1
E D FMADD^YTXCHGU(601.96,.REC)
Q
LIST96 ; Save list of instruments as JSON in 601.96
N REC,JSON,IEN
S REC(.01)="YTL ACTIVE"
S REC(.02)=1
S REC(1)="JSON"
S IEN=$O(^YTT(601.96,"B","YTL ACTIVE",0))
D NAMES^YTWJSONU(.JSON)
I IEN D FMUPD^YTXCHGU(601.96,.REC,IEN) I 1
E D FMADD^YTXCHGU(601.96,.REC)
Q
;
; -- calls to write to host directory
;
FILE(TEST,PATH) ; save JSON test to a file
I TEST'=+TEST S TEST=$O(^YTT(601.71,"B",TEST,0)) Q:'TEST
;
N JSON,OK
D GETSPEC^YTWJSON(.JSON,TEST)
I '$D(JSON) W !,"Error creating JSON for "_$P(^YTT(601.71,TEST,0),U) QUIT
;
K ^TMP($J)
M ^TMP($J)=JSON ; so can use $$GTF^%ZISH
N NAME S NAME=$TR($P(^YTT(601.71,TEST,0),U)," ","_")_".json"
S OK=$$GTF^%ZISH($NA(^TMP($J,1)),2,PATH,NAME)
I 'OK W !,"Error writing file: "_NAME
K ^TMP($J)
Q
LIST(PATH) ; Save list of instruments as JSON to directory
N JSON,OK
D NAMES^YTWJSONU(.JSON)
K ^TMP($J) M ^TMP($J)=JSON
S OK=$$GTF^%ZISH($NA(^TMP($J,1)),2,PATH,"instrumentList.json")
I 'OK W !,"Error writing file: instrumentList.json"
K ^TMP($J)
Q
;
; -- calls to seed to MH TEST/SURVEY ENTRY file (601.712)
;
LPSEED ; Loop thru all active instruments to seed JSON documents
N TEST
S TEST=0 F S TEST=$O(^YTT(601.71,TEST)) Q:'TEST D
. I $P($G(^YTT(601.71,TEST,2)),U,2)'="Y" QUIT
. D FILE712(TEST) W "."
Q
FILE712(TEST) ; save JSON test to 601.712
K ^TMP("YTQ-FILE",$J)
N JSON,CRC,ERRS,I,REC,IEN
I TEST'=+TEST S TEST=$O(^YTT(601.71,"B",TEST,0))
D GETSPEC^YTWJSON(.JSON,TEST)
I '$D(JSON) W "JSON err: "_$P(^YTT(601.71,TEST,0),U) QUIT
S I=0 F S I=$O(JSON(I)) Q:'I S ^TMP("YTQ-FILE",$J,I,0)=JSON(I)
D CHKSPEC^YTWJSONE($NA(^TMP("YTQ-FILE",$J)),.ERRS,.CRC)
I $L($G(ERRS)) W "Checksum err: "_ERRS QUIT
;
S REC(.01)=TEST
S REC(.02)=$$NOW^XLFDT
S REC(.03)=CRC
S REC(1)=$NA(^TMP("YTQ-FILE",$J))
S IEN=$O(^YTT(601.712,"B",TEST,0))
I IEN D FMUPD^YTXCHGU(601.712,.REC,IEN) I 1
E D FMADD^YTXCHGU(601.712,.REC)
K ^TMP("YTQ-FILE",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTWJSONF 3907 printed Sep 23, 2025@19:58:08 Page 2
YTWJSONF ;SLC/KCM - File/Export JSON versions of instruments ; 7/20/2018
+1 ;;5.01;MENTAL HEALTH;**130,141**;Dec 30, 1994;Build 85
+2 ;
+3 ; External Reference ICR#
+4 ; ------------------ -----
+5 ; %ZISH 2320
+6 ; XPDUTL 10141
+7 ;
SAVEDIR ; Save all active instruments to directory
+1 ; may need to first remove current files from the destination directory
+2 ; (this doesn't clean up the destination directory first)
+3 NEW PATH
+4 SET PATH=$$PROMPT^YTWJSONU("Destination Directory")
if '$LENGTH(PATH)
QUIT
+5 DO LPACTV(PATH)
+6 DO LIST(PATH)
+7 QUIT
SAVE96 ; Save all active instruments as JSON in 601.96
+1 ; remove the current entries for active instruments
DO DEL96
+2 ; empty path causes save to 601.96
DO LPACTV("")
+3 DO LIST96
+4 QUIT
+5 ;
LPACTV(PATH) ; Loop thru all active instruments to create JSON documents
+1 ; PATH: if empty, JSON documents are saved to 601.96
+2 ; otherwise, this specifics the host directory
+3 NEW TEST
+4 SET TEST=0
FOR
SET TEST=$ORDER(^YTT(601.71,TEST))
if 'TEST
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^YTT(601.71,TEST,2)),U,2)'="Y"
QUIT
+6 IF '$LENGTH($GET(PATH))
DO FILE96(TEST)
WRITE "."
+7 IF $LENGTH($GET(PATH))
DO FILE(TEST,PATH)
WRITE "."
End DoDot:1
+8 QUIT
+9 ;
+10 ; -- calls to write to 601.96
+11 ;
DEL96 ; Delete active instruments from 601.96
+1 NEW NM,IEN
+2 SET NM="YTT "
FOR
SET NM=$ORDER(^YTT(601.96,"B",NM))
if $EXTRACT(NM,1,4)'="YTT "
QUIT
Begin DoDot:1
+3 SET IEN=$ORDER(^YTT(601.96,"B",NM,0))
+4 DO FMDEL^YTXCHGU(601.96,IEN)
End DoDot:1
+5 SET IEN=$ORDER(^YTT(601.96,"B","YTL ACTIVE",0))
+6 DO FMDEL^YTXCHGU(601.96,IEN)
+7 QUIT
FILE96(TEST) ; save JSON test to 601.96
+1 IF TEST'=+TEST
SET TEST=$ORDER(^YTT(601.71,"B",TEST,0))
if 'TEST
QUIT
+2 if '$DATA(^YTT(601.71,TEST,0))
QUIT
+3 ;
+4 NEW REC,JSON,IEN
+5 SET REC(.01)="YTT "_$PIECE(^YTT(601.71,TEST,0),U)
+6 SET REC(.02)=1
+7 SET REC(1)="JSON"
+8 SET IEN=$ORDER(^YTT(601.96,"B",REC(.01),0))
+9 DO GETSPEC^YTWJSON(.JSON,TEST)
+10 IF '$DATA(JSON)
Begin DoDot:1
+11 DO MES^XPDUTL("Error creating JSON for "_$PIECE(^YTT(601.71,TEST,0),U))
End DoDot:1
QUIT
+12 ;
+13 IF IEN
DO FMUPD^YTXCHGU(601.96,.REC,IEN)
IF 1
+14 IF '$TEST
DO FMADD^YTXCHGU(601.96,.REC)
+15 QUIT
LIST96 ; Save list of instruments as JSON in 601.96
+1 NEW REC,JSON,IEN
+2 SET REC(.01)="YTL ACTIVE"
+3 SET REC(.02)=1
+4 SET REC(1)="JSON"
+5 SET IEN=$ORDER(^YTT(601.96,"B","YTL ACTIVE",0))
+6 DO NAMES^YTWJSONU(.JSON)
+7 IF IEN
DO FMUPD^YTXCHGU(601.96,.REC,IEN)
IF 1
+8 IF '$TEST
DO FMADD^YTXCHGU(601.96,.REC)
+9 QUIT
+10 ;
+11 ; -- calls to write to host directory
+12 ;
FILE(TEST,PATH) ; save JSON test to a file
+1 IF TEST'=+TEST
SET TEST=$ORDER(^YTT(601.71,"B",TEST,0))
if 'TEST
QUIT
+2 ;
+3 NEW JSON,OK
+4 DO GETSPEC^YTWJSON(.JSON,TEST)
+5 IF '$DATA(JSON)
WRITE !,"Error creating JSON for "_$PIECE(^YTT(601.71,TEST,0),U)
QUIT
+6 ;
+7 KILL ^TMP($JOB)
+8 ; so can use $$GTF^%ZISH
MERGE ^TMP($JOB)=JSON
+9 NEW NAME
SET NAME=$TRANSLATE($PIECE(^YTT(601.71,TEST,0),U)," ","_")_".json"
+10 SET OK=$$GTF^%ZISH($NAME(^TMP($JOB,1)),2,PATH,NAME)
+11 IF 'OK
WRITE !,"Error writing file: "_NAME
+12 KILL ^TMP($JOB)
+13 QUIT
LIST(PATH) ; Save list of instruments as JSON to directory
+1 NEW JSON,OK
+2 DO NAMES^YTWJSONU(.JSON)
+3 KILL ^TMP($JOB)
MERGE ^TMP($JOB)=JSON
+4 SET OK=$$GTF^%ZISH($NAME(^TMP($JOB,1)),2,PATH,"instrumentList.json")
+5 IF 'OK
WRITE !,"Error writing file: instrumentList.json"
+6 KILL ^TMP($JOB)
+7 QUIT
+8 ;
+9 ; -- calls to seed to MH TEST/SURVEY ENTRY file (601.712)
+10 ;
LPSEED ; Loop thru all active instruments to seed JSON documents
+1 NEW TEST
+2 SET TEST=0
FOR
SET TEST=$ORDER(^YTT(601.71,TEST))
if 'TEST
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^YTT(601.71,TEST,2)),U,2)'="Y"
QUIT
+4 DO FILE712(TEST)
WRITE "."
End DoDot:1
+5 QUIT
FILE712(TEST) ; save JSON test to 601.712
+1 KILL ^TMP("YTQ-FILE",$JOB)
+2 NEW JSON,CRC,ERRS,I,REC,IEN
+3 IF TEST'=+TEST
SET TEST=$ORDER(^YTT(601.71,"B",TEST,0))
+4 DO GETSPEC^YTWJSON(.JSON,TEST)
+5 IF '$DATA(JSON)
WRITE "JSON err: "_$PIECE(^YTT(601.71,TEST,0),U)
QUIT
+6 SET I=0
FOR
SET I=$ORDER(JSON(I))
if 'I
QUIT
SET ^TMP("YTQ-FILE",$JOB,I,0)=JSON(I)
+7 DO CHKSPEC^YTWJSONE($NAME(^TMP("YTQ-FILE",$JOB)),.ERRS,.CRC)
+8 IF $LENGTH($GET(ERRS))
WRITE "Checksum err: "_ERRS
QUIT
+9 ;
+10 SET REC(.01)=TEST
+11 SET REC(.02)=$$NOW^XLFDT
+12 SET REC(.03)=CRC
+13 SET REC(1)=$NAME(^TMP("YTQ-FILE",$JOB))
+14 SET IEN=$ORDER(^YTT(601.712,"B",TEST,0))
+15 IF IEN
DO FMUPD^YTXCHGU(601.712,.REC,IEN)
IF 1
+16 IF '$TEST
DO FMADD^YTXCHGU(601.712,.REC)
+17 KILL ^TMP("YTQ-FILE",$JOB)
+18 QUIT
