YTXCHGI ;SLC/KCM - Instrument Specification Import ; 9/15/2015
;;5.01;MENTAL HEALTH;**121,202,250**;Dec 30, 1994;Build 26
;
; Reference to TIUFLF7 in ICR #5352
Q
IMPTREE(TREE,YTXDRY) ; updates database from object tree source
; TREE : name of array containing object tree
; .YTXLOG: array of log info (count, errors)
; YTXDRY: 1 if just doing a dry run of the install
;
; get map file:field to array nodes
; MAP(file,field)=node subscripts for value
; MAP("store",seq,"file")=sequence for processing file entries
; MAP("store",seq,"loop")=name of subscript(s) if array
N MAP,FILESEQ,FILE,LOOP,DONE,TSTIEN,YTXERRS,YTXNOTE
K ^TMP("YTXCHGI",$J,"ENTRY")
; TSTIEN may change if instrument doesn't exist yet
S TSTIEN=$O(^YTT(601.71,"B",@TREE@("info","name"),0))
; build list of all entries, leftovers are delete candidates
I TSTIEN D BLDTEST^YTXCHGV(TSTIEN,$NA(^TMP("YTXCHGI",$J,"ENTRY")))
S YTXNOTE=$$CHKNOTE(@TREE@("info","name"))
D BLDMAP^YTXCHGM(.MAP)
S FILESEQ=0 F S FILESEQ=$O(MAP("store",FILESEQ)) Q:'FILESEQ D
. N ARRAY
. S ARRAY=0
. S FILE=MAP("store",FILESEQ,"file")
. S LOOP=MAP("store",FILESEQ,"loop")
. I $L(LOOP) F I=1:1:$L(LOOP,":") S ARRAY(I)=$P(LOOP,":",I),ARRAY=ARRAY+1
. I ARRAY=0 D PROCESS(FILE) ; top level value
. I ARRAY=1 D DEPTH1(FILE,.ARRAY) ; one array deep
. I ARRAY=2 D DEPTH2(FILE,.ARRAY) ; two arrays deep
. I ARRAY=3 D DEPTH3(FILE,.ARRAY) ; three arrays deep
D DELETES(TSTIEN)
I YTXNOTE D ADDNOTE(@TREE@("info","name"))
K ^TMP("YTXCHGI",$J,"ENTRY")
Q
DEPTH1(FILE,ARRAY) ; loop 1 level deep in .ARRAY(1) to save in FILE
; FILE: file number
; ARRAY(n): subscript name for level n
N I ;array of current index values
S I(1)=0
F S I(1)=$O(@TREE@(ARRAY(1),I(1))) Q:'I(1) D PROCESS(FILE,.I)
Q
DEPTH2(FILE,ARRAY) ; loop 2 levels deep in .ARRAY to save in FILE
; FILE: file number
; ARRAY(n): subscript name for level n
N I ;array of current index values
S I(1)=0 F S I(1)=$O(@TREE@(ARRAY(1),I(1))) Q:'I(1) D
. S I(2)=0 F S I(2)=$O(@TREE@(ARRAY(1),I(1),ARRAY(2),I(2))) Q:'I(2) D PROCESS(FILE,.I)
Q
DEPTH3(FILE,ARRAY) ; loop 3 levels deep in .ARRAY to save in FILE
; FILE: file number
; ARRAY(n): subscript name for level n
N I ;array of current index values
S I(1)=0 F S I(1)=$O(@TREE@(ARRAY(1),I(1))) Q:'I(1) D
. S I(2)=0 F S I(2)=$O(@TREE@(ARRAY(1),I(1),ARRAY(2),I(2))) Q:'I(2) D
. . S I(3)=0 F S I(3)=$O(@TREE@(ARRAY(1),I(1),ARRAY(2),I(2),ARRAY(3),I(3))) Q:'I(3) D PROCESS(FILE,.I)
Q
PROCESS(FILE,IDX) ; using instances identified in IDX to save values to FILE
; expects: MAP,DONE,TSTIEN
; FILE: file number
; IDX: index values used to replace ?n subscripts
;
; build REC array for compare and Fileman calls
; REC(fieldNum)=value
; REC(fieldNum)=^TMP("YTXCHG",$J,"WP",field) -- for word processing field
;
; get values from nodes in M array representation
K ^TMP("YTXCHG",$J,"WP")
N FIELD,SUBS,REF,REC,IEN,UPDTYPE
S FIELD=0 F S FIELD=$O(MAP(FILE,FIELD)) Q:'FIELD D
. S SUBS=$$MKSUBS^YTXCHGU(FILE,FIELD,.IDX)
. S REF=$E(TREE,1,$L(TREE)-1)_","_SUBS_")"
. I $G(MAP(FILE,FIELD,"type"))["e" Q ; skip
. I $G(MAP(FILE,FIELD,"type"))["w" D WP2REC(REF,FIELD,.REC) Q ; wp
. I $D(@REF) D
. . I @REF="null" S REC(FIELD)="" Q ; empty
. . I $G(MAP(FILE,FIELD,"type"))["t" S REC(FIELD)=$$ISO2FM^YTXCHGU(@REF) Q ; date
. . I $G(MAP(FILE,FIELD,"type"))["y" S REC(FIELD)=$S(@REF="true":"Y",1:"N") Q ; bool
. . S REC(FIELD)=@REF ; other
Q:'$D(REC) ; nothing for this record
;
; figure out IEN (.001 for cases where file is not DINUM'd)
S IEN=$S($D(REC(.001)):REC(.001),1:REC(.01))
K REC(.001)
Q:'IEN ; IEN is absent for empty pointer fields
Q:$D(DONE(FILE,IEN)) ; already dealt with this record
;
; compare with current record, do nothing if same (UPDTYPE=0)
S UPDTYPE=$$DIFFREC(FILE,IEN,.REC)
D FMSAVE(UPDTYPE,FILE,.REC,IEN)
S DONE(FILE,IEN)=""
K ^TMP("YTXCHGI",$J,"ENTRY",FILE,IEN)
K ^TMP("YTXCHG",$J,"WP")
Q
FMSAVE(UPDTYPE,FILE,REC,IEN) ; add/update file
N UPDOK
I UPDTYPE=0 QUIT ; no changes so quit
D LOG^YTXCHGU("prog",".")
D LOG^YTXCHGU($S(UPDTYPE=1:"updated",UPDTYPE=2:"added",1:"unknown"))
I UPDTYPE=1 S UPDOK='$$COLLIDE^YTXCHGV(FILE,IEN)
; show change if verbose and not doing verify pass
I $G(YTXVRB),($G(YTXDRY)'=2) D SHOWREC(UPDTYPE,FILE,.REC,IEN)
I $G(YTXDRY) QUIT ; dry run so quit
;
; update entry
I UPDTYPE=1,UPDOK D FMUPD^YTXCHGU(FILE,.REC,IEN)
; add new entry
I UPDTYPE=2 D
. D FMADD^YTXCHGU(FILE,.REC,.IEN)
. I FILE=601.71 S TSTIEN=IEN ; in case instrument just added
. D ADDIDX^YTXCHGV(FILE,IEN,TSTIEN)
Q
DIFFREC(FILE,IEN,REC) ; return 0 if identical, 1 if changed, 2 if absent
; expects MAP
; will modify .REC to remove empty fields that need no update
;
; new entry, so remove empty fields in .REC and return 2 (absent)
I '$D(^YTT(FILE,IEN)) D QUIT 2
. S FLD=0 F S FLD=$O(REC(FLD)) Q:'FLD I '$L(REC(FLD)) K REC(FLD)
;
N FLD,LN,OLD,NEW,FLDS,IENS,VALS,WPREF,ERRS
S IENS=IEN_",",FLDS="",OLD="",NEW=""
;
; build string OLD using current database values
S FLD=0 F S FLD=$O(REC(FLD)) Q:'FLD S FLDS=FLDS_FLD_";"
D GETS^DIQ(FILE,IENS,FLDS,"IN","VALS","ERRS") ; "IN"=internal, no nulls
S FLD=0 F S FLD=$O(VALS(FILE,IENS,FLD)) Q:'FLD D
. Q:'$D(MAP(FILE,FLD))
. S OLD=OLD_FLD_":"
. I $O(VALS(FILE,IENS,FLD,0)) D ; word processing
. . S LN=0 F S LN=$O(VALS(FILE,IENS,FLD,LN)) Q:'LN S OLD=OLD_VALS(FILE,IENS,FLD,LN)
. E S OLD=OLD_VALS(FILE,IENS,FLD,"I")
. S OLD=OLD_$C(9)
;
; remove empty values from .REC if not present in VALS
S FLD=0 F S FLD=$O(REC(FLD)) Q:'FLD I '$L(REC(FLD)) D
. I '$D(VALS(FILE,IENS,FLD)) K REC(FLD) ; nothing to remove
;
; build string NEW using REC array
S FLD=0 F S FLD=$O(REC(FLD)) Q:'FLD D
. S NEW=NEW_FLD_":"
. I $E(REC(FLD),1,5)="^TMP(" D ; word processing
. . S WPREF=$NA(^TMP("YTXCHG",$J,"WP",FLD))
. . S LN=0 F S LN=$O(@WPREF@(LN)) Q:'LN S NEW=NEW_@WPREF@(LN,0)
. E S NEW=NEW_REC(FLD)
. S NEW=NEW_$C(9)
;
I NEW=OLD Q 0 ; return same
Q 1 ; return different
;
WP2REC(TREEREF,FIELD,REC) ; parse CRLF delimited JSON TREE text into ^TMP
I '$D(@TREEREF) QUIT ; nothing in WP field
I @TREEREF="null",'$D(@TREEREF@("\s")) QUIT ; nothing in WP field
;
K ^TMP("YTXCHG",$J,"WP",FIELD)
D TR2WP^YTXCHGT(TREEREF,$NA(^TMP("YTXCHG",$J,"WP",FIELD)))
S REC(FIELD)=$NA(^TMP("YTXCHG",$J,"WP",FIELD))
Q
;
SHOWREC(UPDTYPE,FILE,REC,IEN) ; show record
N FLD,X
S FLD=0,X="" F S FLD=$O(REC(FLD)) Q:'FLD D
. I $L(X) S X=X_", "
. S X=X_FLD_"="
. I $E(REC(FLD))="^" S X=X_$E($G(^TMP("YTXCHG",$J,"WP",FLD,1)),1,30)_"..." I 1
. E S X=X_REC(FLD)
W !,$S(UPDTYPE=0:"Nop ",UPDTYPE=1:"Upd ",UPDTYPE=2:"Add ",1:"??? "),FILE,":",IEN,?20
W X
Q
DELETES(TSTIEN) ; delete records no longer used by instrument
; expects YTXDRY,YTXVRB (if defined)
; uses "leftover" entries in ^TMP("YTXCHGI",$J,"ENTRY",file,ien)
N FILE,IEN,OWNED
; F FILE=601.76,601.79,601.81,601.83,601.86,601.93 S OWNED(FILE)=""
S FILE=0 F S FILE=$O(^TMP("YTXCHGI",$J,"ENTRY",FILE)) Q:'FILE D
. S IEN=0 F S IEN=$O(^TMP("YTXCHGI",$J,"ENTRY",FILE,IEN)) Q:'IEN D
. . D DELIDX^YTXCHGV(FILE,IEN,$G(TSTIEN))
. . ; only remove entry if no other instrument is referencing it
. . I $$ISONLY^YTXCHGV(FILE,IEN,TSTIEN) D
. . . D LOG^YTXCHGU("deleted") ; increment deleted count
. . . I $G(YTXVRB),($G(YTXDRY)'=2) W !,"Del ",FILE,":",IEN
. . . I $G(YTXDRY) QUIT ; if dry run don't delete
. . . D FMDEL^YTXCHGU(FILE,IEN)
. . E I $G(YTXVRB),($G(YTXDRY)'=2) W !,"Old ",FILE,":",IEN
Q
CHKNOTE(NAME) ; Return 1 if a default note should be added
N IEN
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN 1 ; new instrument, so add
Q:$P($G(^YTT(601.71,IEN,2)),U,2)="U" 1 ; moving from under development
Q 0
;
ADDNOTE(NAME) ; Add default note for this instrument
N IEN,NOTE,CSLT,REC
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
Q:$P($G(^YTT(601.71,IEN,2)),U,2)'="Y" ; must be operational
Q:$P($G(^YTT(601.71,IEN,8)),U,9)>0 ; note title already there
S NOTE=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH DIAGNOSTIC STUDY NOTE","TL")
S:'NOTE NOTE=+$$DDEFIEN^TIUFLF7("MH DIAGNOSTIC STUDY NOTE","TL")
S CSLT=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH CONSULT NOTE","TL")
S:'CSLT CSLT=+$$DDEFIEN^TIUFLF7("MH CONSULT NOTE","TL")
I 'NOTE,'CSLT QUIT ; neither title found
S REC(28)="Y"
S REC(29)=NOTE
S REC(30)=CSLT
D FMSAVE(1,601.71,.REC,IEN) ; FMSAVE in case dry run
D LOG^YTXCHGU("info","Linked note title.")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTXCHGI 9010 printed Sep 23, 2025@19:58:13 Page 2
YTXCHGI ;SLC/KCM - Instrument Specification Import ; 9/15/2015
+1 ;;5.01;MENTAL HEALTH;**121,202,250**;Dec 30, 1994;Build 26
+2 ;
+3 ; Reference to TIUFLF7 in ICR #5352
+4 QUIT
IMPTREE(TREE,YTXDRY) ; updates database from object tree source
+1 ; TREE : name of array containing object tree
+2 ; .YTXLOG: array of log info (count, errors)
+3 ; YTXDRY: 1 if just doing a dry run of the install
+4 ;
+5 ; get map file:field to array nodes
+6 ; MAP(file,field)=node subscripts for value
+7 ; MAP("store",seq,"file")=sequence for processing file entries
+8 ; MAP("store",seq,"loop")=name of subscript(s) if array
+9 NEW MAP,FILESEQ,FILE,LOOP,DONE,TSTIEN,YTXERRS,YTXNOTE
+10 KILL ^TMP("YTXCHGI",$JOB,"ENTRY")
+11 ; TSTIEN may change if instrument doesn't exist yet
+12 SET TSTIEN=$ORDER(^YTT(601.71,"B",@TREE@("info","name"),0))
+13 ; build list of all entries, leftovers are delete candidates
+14 IF TSTIEN
DO BLDTEST^YTXCHGV(TSTIEN,$NAME(^TMP("YTXCHGI",$JOB,"ENTRY")))
+15 SET YTXNOTE=$$CHKNOTE(@TREE@("info","name"))
+16 DO BLDMAP^YTXCHGM(.MAP)
+17 SET FILESEQ=0
FOR
SET FILESEQ=$ORDER(MAP("store",FILESEQ))
if 'FILESEQ
QUIT
Begin DoDot:1
+18 NEW ARRAY
+19 SET ARRAY=0
+20 SET FILE=MAP("store",FILESEQ,"file")
+21 SET LOOP=MAP("store",FILESEQ,"loop")
+22 IF $LENGTH(LOOP)
FOR I=1:1:$LENGTH(LOOP,":")
SET ARRAY(I)=$PIECE(LOOP,":",I)
SET ARRAY=ARRAY+1
+23 ; top level value
IF ARRAY=0
DO PROCESS(FILE)
+24 ; one array deep
IF ARRAY=1
DO DEPTH1(FILE,.ARRAY)
+25 ; two arrays deep
IF ARRAY=2
DO DEPTH2(FILE,.ARRAY)
+26 ; three arrays deep
IF ARRAY=3
DO DEPTH3(FILE,.ARRAY)
End DoDot:1
+27 DO DELETES(TSTIEN)
+28 IF YTXNOTE
DO ADDNOTE(@TREE@("info","name"))
+29 KILL ^TMP("YTXCHGI",$JOB,"ENTRY")
+30 QUIT
DEPTH1(FILE,ARRAY) ; loop 1 level deep in .ARRAY(1) to save in FILE
+1 ; FILE: file number
+2 ; ARRAY(n): subscript name for level n
+3 ;array of current index values
NEW I
+4 SET I(1)=0
+5 FOR
SET I(1)=$ORDER(@TREE@(ARRAY(1),I(1)))
if 'I(1)
QUIT
DO PROCESS(FILE,.I)
+6 QUIT
DEPTH2(FILE,ARRAY) ; loop 2 levels deep in .ARRAY to save in FILE
+1 ; FILE: file number
+2 ; ARRAY(n): subscript name for level n
+3 ;array of current index values
NEW I
+4 SET I(1)=0
FOR
SET I(1)=$ORDER(@TREE@(ARRAY(1),I(1)))
if 'I(1)
QUIT
Begin DoDot:1
+5 SET I(2)=0
FOR
SET I(2)=$ORDER(@TREE@(ARRAY(1),I(1),ARRAY(2),I(2)))
if 'I(2)
QUIT
DO PROCESS(FILE,.I)
End DoDot:1
+6 QUIT
DEPTH3(FILE,ARRAY) ; loop 3 levels deep in .ARRAY to save in FILE
+1 ; FILE: file number
+2 ; ARRAY(n): subscript name for level n
+3 ;array of current index values
NEW I
+4 SET I(1)=0
FOR
SET I(1)=$ORDER(@TREE@(ARRAY(1),I(1)))
if 'I(1)
QUIT
Begin DoDot:1
+5 SET I(2)=0
FOR
SET I(2)=$ORDER(@TREE@(ARRAY(1),I(1),ARRAY(2),I(2)))
if 'I(2)
QUIT
Begin DoDot:2
+6 SET I(3)=0
FOR
SET I(3)=$ORDER(@TREE@(ARRAY(1),I(1),ARRAY(2),I(2),ARRAY(3),I(3)))
if 'I(3)
QUIT
DO PROCESS(FILE,.I)
End DoDot:2
End DoDot:1
+7 QUIT
PROCESS(FILE,IDX) ; using instances identified in IDX to save values to FILE
+1 ; expects: MAP,DONE,TSTIEN
+2 ; FILE: file number
+3 ; IDX: index values used to replace ?n subscripts
+4 ;
+5 ; build REC array for compare and Fileman calls
+6 ; REC(fieldNum)=value
+7 ; REC(fieldNum)=^TMP("YTXCHG",$J,"WP",field) -- for word processing field
+8 ;
+9 ; get values from nodes in M array representation
+10 KILL ^TMP("YTXCHG",$JOB,"WP")
+11 NEW FIELD,SUBS,REF,REC,IEN,UPDTYPE
+12 SET FIELD=0
FOR
SET FIELD=$ORDER(MAP(FILE,FIELD))
if 'FIELD
QUIT
Begin DoDot:1
+13 SET SUBS=$$MKSUBS^YTXCHGU(FILE,FIELD,.IDX)
+14 SET REF=$EXTRACT(TREE,1,$LENGTH(TREE)-1)_","_SUBS_")"
+15 ; skip
IF $GET(MAP(FILE,FIELD,"type"))["e"
QUIT
+16 ; wp
IF $GET(MAP(FILE,FIELD,"type"))["w"
DO WP2REC(REF,FIELD,.REC)
QUIT
+17 IF $DATA(@REF)
Begin DoDot:2
+18 ; empty
IF @REF="null"
SET REC(FIELD)=""
QUIT
+19 ; date
IF $GET(MAP(FILE,FIELD,"type"))["t"
SET REC(FIELD)=$$ISO2FM^YTXCHGU(@REF)
QUIT
+20 ; bool
IF $GET(MAP(FILE,FIELD,"type"))["y"
SET REC(FIELD)=$SELECT(@REF="true":"Y",1:"N")
QUIT
+21 ; other
SET REC(FIELD)=@REF
End DoDot:2
End DoDot:1
+22 ; nothing for this record
if '$DATA(REC)
QUIT
+23 ;
+24 ; figure out IEN (.001 for cases where file is not DINUM'd)
+25 SET IEN=$SELECT($DATA(REC(.001)):REC(.001),1:REC(.01))
+26 KILL REC(.001)
+27 ; IEN is absent for empty pointer fields
if 'IEN
QUIT
+28 ; already dealt with this record
if $DATA(DONE(FILE,IEN))
QUIT
+29 ;
+30 ; compare with current record, do nothing if same (UPDTYPE=0)
+31 SET UPDTYPE=$$DIFFREC(FILE,IEN,.REC)
+32 DO FMSAVE(UPDTYPE,FILE,.REC,IEN)
+33 SET DONE(FILE,IEN)=""
+34 KILL ^TMP("YTXCHGI",$JOB,"ENTRY",FILE,IEN)
+35 KILL ^TMP("YTXCHG",$JOB,"WP")
+36 QUIT
FMSAVE(UPDTYPE,FILE,REC,IEN) ; add/update file
+1 NEW UPDOK
+2 ; no changes so quit
IF UPDTYPE=0
QUIT
+3 DO LOG^YTXCHGU("prog",".")
+4 DO LOG^YTXCHGU($SELECT(UPDTYPE=1:"updated",UPDTYPE=2:"added",1:"unknown"))
+5 IF UPDTYPE=1
SET UPDOK='$$COLLIDE^YTXCHGV(FILE,IEN)
+6 ; show change if verbose and not doing verify pass
+7 IF $GET(YTXVRB)
IF ($GET(YTXDRY)'=2)
DO SHOWREC(UPDTYPE,FILE,.REC,IEN)
+8 ; dry run so quit
IF $GET(YTXDRY)
QUIT
+9 ;
+10 ; update entry
+11 IF UPDTYPE=1
IF UPDOK
DO FMUPD^YTXCHGU(FILE,.REC,IEN)
+12 ; add new entry
+13 IF UPDTYPE=2
Begin DoDot:1
+14 DO FMADD^YTXCHGU(FILE,.REC,.IEN)
+15 ; in case instrument just added
IF FILE=601.71
SET TSTIEN=IEN
+16 DO ADDIDX^YTXCHGV(FILE,IEN,TSTIEN)
End DoDot:1
+17 QUIT
DIFFREC(FILE,IEN,REC) ; return 0 if identical, 1 if changed, 2 if absent
+1 ; expects MAP
+2 ; will modify .REC to remove empty fields that need no update
+3 ;
+4 ; new entry, so remove empty fields in .REC and return 2 (absent)
+5 IF '$DATA(^YTT(FILE,IEN))
Begin DoDot:1
+6 SET FLD=0
FOR
SET FLD=$ORDER(REC(FLD))
if 'FLD
QUIT
IF '$LENGTH(REC(FLD))
KILL REC(FLD)
End DoDot:1
QUIT 2
+7 ;
+8 NEW FLD,LN,OLD,NEW,FLDS,IENS,VALS,WPREF,ERRS
+9 SET IENS=IEN_","
SET FLDS=""
SET OLD=""
SET NEW=""
+10 ;
+11 ; build string OLD using current database values
+12 SET FLD=0
FOR
SET FLD=$ORDER(REC(FLD))
if 'FLD
QUIT
SET FLDS=FLDS_FLD_";"
+13 ; "IN"=internal, no nulls
DO GETS^DIQ(FILE,IENS,FLDS,"IN","VALS","ERRS")
+14 SET FLD=0
FOR
SET FLD=$ORDER(VALS(FILE,IENS,FLD))
if 'FLD
QUIT
Begin DoDot:1
+15 if '$DATA(MAP(FILE,FLD))
QUIT
+16 SET OLD=OLD_FLD_":"
+17 ; word processing
IF $ORDER(VALS(FILE,IENS,FLD,0))
Begin DoDot:2
+18 SET LN=0
FOR
SET LN=$ORDER(VALS(FILE,IENS,FLD,LN))
if 'LN
QUIT
SET OLD=OLD_VALS(FILE,IENS,FLD,LN)
End DoDot:2
+19 IF '$TEST
SET OLD=OLD_VALS(FILE,IENS,FLD,"I")
+20 SET OLD=OLD_$CHAR(9)
End DoDot:1
+21 ;
+22 ; remove empty values from .REC if not present in VALS
+23 SET FLD=0
FOR
SET FLD=$ORDER(REC(FLD))
if 'FLD
QUIT
IF '$LENGTH(REC(FLD))
Begin DoDot:1
+24 ; nothing to remove
IF '$DATA(VALS(FILE,IENS,FLD))
KILL REC(FLD)
End DoDot:1
+25 ;
+26 ; build string NEW using REC array
+27 SET FLD=0
FOR
SET FLD=$ORDER(REC(FLD))
if 'FLD
QUIT
Begin DoDot:1
+28 SET NEW=NEW_FLD_":"
+29 ; word processing
IF $EXTRACT(REC(FLD),1,5)="^TMP("
Begin DoDot:2
+30 SET WPREF=$NAME(^TMP("YTXCHG",$JOB,"WP",FLD))
+31 SET LN=0
FOR
SET LN=$ORDER(@WPREF@(LN))
if 'LN
QUIT
SET NEW=NEW_@WPREF@(LN,0)
End DoDot:2
+32 IF '$TEST
SET NEW=NEW_REC(FLD)
+33 SET NEW=NEW_$CHAR(9)
End DoDot:1
+34 ;
+35 ; return same
IF NEW=OLD
QUIT 0
+36 ; return different
QUIT 1
+37 ;
WP2REC(TREEREF,FIELD,REC) ; parse CRLF delimited JSON TREE text into ^TMP
+1 ; nothing in WP field
IF '$DATA(@TREEREF)
QUIT
+2 ; nothing in WP field
IF @TREEREF="null"
IF '$DATA(@TREEREF@("\s"))
QUIT
+3 ;
+4 KILL ^TMP("YTXCHG",$JOB,"WP",FIELD)
+5 DO TR2WP^YTXCHGT(TREEREF,$NAME(^TMP("YTXCHG",$JOB,"WP",FIELD)))
+6 SET REC(FIELD)=$NAME(^TMP("YTXCHG",$JOB,"WP",FIELD))
+7 QUIT
+8 ;
SHOWREC(UPDTYPE,FILE,REC,IEN) ; show record
+1 NEW FLD,X
+2 SET FLD=0
SET X=""
FOR
SET FLD=$ORDER(REC(FLD))
if 'FLD
QUIT
Begin DoDot:1
+3 IF $LENGTH(X)
SET X=X_", "
+4 SET X=X_FLD_"="
+5 IF $EXTRACT(REC(FLD))="^"
SET X=X_$EXTRACT($GET(^TMP("YTXCHG",$JOB,"WP",FLD,1)),1,30)_"..."
IF 1
+6 IF '$TEST
SET X=X_REC(FLD)
End DoDot:1
+7 WRITE !,$SELECT(UPDTYPE=0:"Nop ",UPDTYPE=1:"Upd ",UPDTYPE=2:"Add ",1:"??? "),FILE,":",IEN,?20
+8 WRITE X
+9 QUIT
DELETES(TSTIEN) ; delete records no longer used by instrument
+1 ; expects YTXDRY,YTXVRB (if defined)
+2 ; uses "leftover" entries in ^TMP("YTXCHGI",$J,"ENTRY",file,ien)
+3 NEW FILE,IEN,OWNED
+4 ; F FILE=601.76,601.79,601.81,601.83,601.86,601.93 S OWNED(FILE)=""
+5 SET FILE=0
FOR
SET FILE=$ORDER(^TMP("YTXCHGI",$JOB,"ENTRY",FILE))
if 'FILE
QUIT
Begin DoDot:1
+6 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("YTXCHGI",$JOB,"ENTRY",FILE,IEN))
if 'IEN
QUIT
Begin DoDot:2
+7 DO DELIDX^YTXCHGV(FILE,IEN,$GET(TSTIEN))
+8 ; only remove entry if no other instrument is referencing it
+9 IF $$ISONLY^YTXCHGV(FILE,IEN,TSTIEN)
Begin DoDot:3
+10 ; increment deleted count
DO LOG^YTXCHGU("deleted")
+11 IF $GET(YTXVRB)
IF ($GET(YTXDRY)'=2)
WRITE !,"Del ",FILE,":",IEN
+12 ; if dry run don't delete
IF $GET(YTXDRY)
QUIT
+13 DO FMDEL^YTXCHGU(FILE,IEN)
End DoDot:3
+14 IF '$TEST
IF $GET(YTXVRB)
IF ($GET(YTXDRY)'=2)
WRITE !,"Old ",FILE,":",IEN
End DoDot:2
End DoDot:1
+15 QUIT
CHKNOTE(NAME) ; Return 1 if a default note should be added
+1 NEW IEN
+2 ; new instrument, so add
SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT 1
+3 ; moving from under development
if $PIECE($GET(^YTT(601.71,IEN,2)),U,2)="U"
QUIT 1
+4 QUIT 0
+5 ;
ADDNOTE(NAME) ; Add default note for this instrument
+1 NEW IEN,NOTE,CSLT,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 ; must be operational
if $PIECE($GET(^YTT(601.71,IEN,2)),U,2)'="Y"
QUIT
+4 ; note title already there
if $PIECE($GET(^YTT(601.71,IEN,8)),U,9)>0
QUIT
+5 SET NOTE=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH DIAGNOSTIC STUDY NOTE","TL")
+6 if 'NOTE
SET NOTE=+$$DDEFIEN^TIUFLF7("MH DIAGNOSTIC STUDY NOTE","TL")
+7 SET CSLT=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH CONSULT NOTE","TL")
+8 if 'CSLT
SET CSLT=+$$DDEFIEN^TIUFLF7("MH CONSULT NOTE","TL")
+9 ; neither title found
IF 'NOTE
IF 'CSLT
QUIT
+10 SET REC(28)="Y"
+11 SET REC(29)=NOTE
+12 SET REC(30)=CSLT
+13 ; FMSAVE in case dry run
DO FMSAVE(1,601.71,.REC,IEN)
+14 DO LOG^YTXCHGU("info","Linked note title.")
+15 QUIT
