YTXCHGU ;SLC/KCM - Instrument Specification Utilities ; 9/15/2015
;;5.01;MENTAL HEALTH;**121,123**;Dec 30, 1994;Build 73
;
SPLTDIR(X,DIR,FILE) ; Split entry into directory and filename
N PATHCHAR
S X=$RE(X)
S PATHCHAR="\/]:"
F I=1:1:$L(X) I PATHCHAR[$E(X,I) Q
S FILE=$RE($E(X,1,I-1)),DIR=$RE($E(X,I,$L(X)))
Q
MKSUBS(FILE,FIELD,NUMS) ; return subscript string for file:field
; expects: MAP
; NUMS(n)=array index for level n
N SUBSTR
S SUBSTR=MAP(FILE,FIELD)
Q $$SUBNUMS(SUBSTR,.NUMS)
;
SUBNUMS(SUBSTR,NUMS) ; make substitutions using NUMS array
N I,REPLACE
S I=0 F S I=$O(NUMS(I)) Q:'I S REPLACE("?"_I)=NUMS(I)
I $D(REPLACE) S SUBSTR=$$REPLACE^XLFSTR(SUBSTR,.REPLACE)
Q SUBSTR
;
NEWDATE(NAME,DATE) ; Change date for test
N IEN,REC
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
S REC(18)=$S($G(DATE):DATE,1:$$NOW^XLFDT)
D FMUPD(601.71,.REC,IEN)
Q
FM2ISO(FMDT) ; Convert Fileman Date/Time to ISO 8601
N X,Y,M,D,H,N,S,ISODT
S X=+$$FMTHL7^XLFDT(FMDT) Q:'X ""
S Y=$E(X,1,4),M=$E(X,5,6),D=$E(X,7,8)
S ISODT=Y
I +M S ISODT=ISODT_"-"_M I +D S ISODT=ISODT_"-"_D
I +$E(X,9,14) D
. S H=$E(X,9,10),N=$E(X,11,12),S=$E(X,13,14)
. S ISODT=ISODT_"T"_H
. I $L(N) S ISODT=ISODT_":"_N I $L(S) S ISODT=ISODT_":"_S
Q ISODT
;
ISO2FM(ISODT) ; Convert ISO 8601 Date/Time to Fileman
S D=$TR($P(ISODT,"T"),"-","")_"000000"
S D=$E(D,1,8)-17000000
S T=$TR($P($P(ISODT,"T",2),"-"),":","")
Q +(D_$S(+T:"."_T,1:""))
;
FMADD(FILE,RECORD,IEN) ; Add new record to FILE
; RECORD(field#)=value
; RECORD(field#)=global reference to word processing value
; IEN=optional IEN to attempt to use
Q:+$P(FILE,".")'=601 ; restrict to MHA
N YTIEN,YTFDA,YTWP,YTERR,DIERR
M YTFDA(FILE,"+1,")=RECORD
I $G(IEN) S YTIEN(1)=IEN
D UPDATE^DIE("","YTFDA","YTIEN","YTERR")
S IEN=YTIEN(1)
I $D(DIERR) S IEN=-1 D LOG("error","Add "_$G(^TMP("DIERR",$J,1,"TEXT",1)))
D CLEAN^DILF
Q
FMUPD(FILE,RECORD,IEN) ; Add new record to FILE
; RECORD(field#)=value
; RECORD(field#)=global reference to word processing value
; IEN=record to update
Q:+$P(FILE,".")'=601 ; restrict to MHA
N YTIEN,YTFDA,YTWP,YTERR,DIERR
M YTFDA(FILE,IEN_",")=RECORD
D FILE^DIE("","YTFDA","YTERR")
I $D(DIERR) D LOG("error","Upd "_$G(^TMP("DIERR",$J,1,"TEXT",1)))
D CLEAN^DILF
Q
;
FMDEL(FILE,IEN) ; Delete record from FILE
; IEN=record to delete
Q:+$P(FILE,".")'=601 ; restrict to MHA
Q:IEN<1
N DIK,DA
S DIK="^YTT("_FILE_",",DA=IEN
D ^DIK
Q
LOG(TYPE,MSG) ; update statistics
; optionally expects YTXLOG array -- uses it if defined
I $G(YTXLOG) S YTXLOG(TYPE)=$G(YTXLOG(TYPE),0)+1
I TYPE="error" D
. I $G(YTXLOG) S YTXLOG("error",YTXLOG("error"))=MSG
. D BMES^XPDUTL("ERROR: "_MSG)
I TYPE="conflict" S YTXLOG("conflict",YTXLOG("conflict"))=MSG
I TYPE="info" D MES^XPDUTL(MSG) ; informational, line break
I TYPE="prog" W MSG ; progress, no line break
Q
LOGINST(XCHGIEN) ; log installation
N YTFDA,YTIEN,YTERR,DIERR
S YTFDA(601.953,"+1,"_XCHGIEN_",",.01)=$$NOW^XLFDT()
S YTFDA(601.953,"+1,"_XCHGIEN_",",.02)=DUZ
D UPDATE^DIE("","YTFDA","YTIEN","YTERR")
I $D(DIERR) D LOG("error","History "_$G(^TMP("DIERR",$J,1,"TEXT",1)))
D CLEAN^DILF
Q
BACKUP(TESTNM) ; backup an instrument for later recovery, if necessary
N TESTS,IEN,REC
K ^TMP("YTXCHG",$J,"WP",2)
S TESTS(1)=$O(^YTT(601.71,"B",TESTNM,0)) Q:'TESTS(1)
S REC(.01)="YTBackup"_TESTNM_"-"_$TR($$HTE^XLFDT($H,"7DZ"),"/","-")
S REC(.02)=$$NOW^XLFDT
S REC(.03)="backup copy"
S REC(2)=$NA(^TMP("YTXCHG",$J,"WP",2))
S ^TMP("YTXCHG",$J,"WP",2,1,0)="backup copy of "_TESTNM
S IEN=$$CREATE^YTXCHG(.TESTS,.REC)
K ^TMP("YTXCHG",$J,"WP",2)
D QDEL(IEN,REC(.01),REC(.02),3)
Q
QDEL(XCHGIEN,XCHGNM,XCHGDT,DAYS) ; Queue a task to delete an exchange entry
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
S ZTIO=""
S ZTRTN="DQDEL^YTXCHGU"
S ZTDESC="Remove "_XCHGNM
S ZTDTH=$$HADD^XLFDT($H,DAYS)
S ZTSAVE("XCHGIEN")="",ZTSAVE("XCHGNM")="",ZTSAVE("XCHGDT")=""
D ^%ZTLOAD
I '$G(ZTSK) D LOG("error","Unsuccessful queue "_XCHGNM)
Q
DQDEL ; Dequeue of instrument exchange entry removal
S ZTREQ="@"
N X0 S X0=^YTT(601.95,XCHGIEN,0)
I ($P(X0,U)'=XCHGNM)!($P(X0,U,2)'=XCHGDT) Q ; no longer same entry
D FMDEL(601.95,XCHGIEN)
Q
TREEOUT ; Save tree representation to file
K ^TMP("YTXCHG",$J,"TREE")
K ^TMP("YTXCHG",$J,"HFS")
N XCHGIEN,FULLNM,NUM
S XCHGIEN=$$LKUP^YTXCHGP(601.95)
I 'XCHGIEN QUIT
S FULLNM=$$PRMTNAME^YTXCHGP("Enter file name","Enter full path and filename.",245)
I '$L(FULLNM) QUIT
D SPEC2TR^YTXCHGT(XCHGIEN,$NA(^TMP("YTXCHG",$J,"TREE")))
S NUM=$$PICKTEST^YTXCHGP($NA(^TMP("YTXCHG",$J,"TREE"))) G:'NUM XTREEOUT
;
N X,I,ROOT,LROOT,CNT,SUB,LINE,ESC
S X=$NA(^TMP("YTXCHG",$J,"TREE","test",NUM))
S ROOT=$E(X,1,$L(X)-1),LROOT=$L(ROOT),CNT=0
F S X=$Q(@X) Q:$E(X,1,LROOT)'=ROOT D
. S LINE="",ESC=0
. F I=6:1:$QL(X) D
. . S SUB=$QS(X,I)
. . I SUB="\s" S ESC=1 QUIT ; JSON "treat number as string"
. . I +SUB,(+SUB=SUB) S SUB="["_SUB_"]" I 1
. . E S:$L(LINE) LINE=LINE_"."
. . S LINE=LINE_SUB
. Q:ESC ; skip line if it is just a string "escape"
. ; W !,LINE_"="_@X ; uncomment to write to screen
. S CNT=CNT+1,^TMP("YTXCHG",$J,"HFS",CNT,0)=LINE_"="_@X
;
N PATH,FILE,OK
D SPLTDIR^YTXCHGU(FULLNM,.PATH,.FILE)
S OK=$$GTF^%ZISH($NA(^TMP("YTXCHG",$J,"HFS",1,0)),4,PATH,FILE)
W !,"File "_$S(OK:"",1:"not ")_"saved."
XTREEOUT ; exit TREEOUT
K ^TMP("YTXCHG",$J,"TREE")
K ^TMP("YTXCHG",$J,"HFS")
Q
FSZ(FNUM) ; return size of Fileman file in bytes (uncompressed)
N ROOT,SIZE,I
S ROOT=$$ROOT^DILFD(FNUM,"",1) ; get global root in closed form
S SIZE=0
I $D(@ROOT)#2 S SIZE=$L(@ROOT)
I $D(@ROOT)>1 S I=0 F S I=$O(@ROOT@(I)) Q:'I S SIZE=SIZE+$L(@ROOT@(I,0))
Q SIZE
;
TFM2ISO ; test Fileman to ISO Date/Time
W !,$$FM2ISO("3100900")
W !,$$FM2ISO("3120415")
W !,$$FM2ISO("3120415.1")
W !,$$FM2ISO("3120415.102")
W !,$$FM2ISO("3120415.100001")
W !,$$FM2ISO("3120415.170001")
W !,$$FM2ISO("3160620.111")
Q
TISO2FM ; test ISO to Fileman date/time
W !,$$ISO2FM("2010-09")
W !,$$ISO2FM("2012-04-15")
W !,$$ISO2FM("2012-04-15T10:00")
W !,$$ISO2FM("2012-04-15T10:20")
W !,$$ISO2FM("2012-04-15T10:00:01")
W !,$$ISO2FM("2012-04-15T17:00:01")
W !,$$ISO2FM("2012-04-15T17:00:01-0600")
W !,$$ISO2FM("2016-06-20T11:10")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTXCHGU 6400 printed Sep 23, 2025@19:58:19 Page 2
YTXCHGU ;SLC/KCM - Instrument Specification Utilities ; 9/15/2015
+1 ;;5.01;MENTAL HEALTH;**121,123**;Dec 30, 1994;Build 73
+2 ;
SPLTDIR(X,DIR,FILE) ; Split entry into directory and filename
+1 NEW PATHCHAR
+2 SET X=$REVERSE(X)
+3 SET PATHCHAR="\/]:"
+4 FOR I=1:1:$LENGTH(X)
IF PATHCHAR[$EXTRACT(X,I)
QUIT
+5 SET FILE=$REVERSE($EXTRACT(X,1,I-1))
SET DIR=$REVERSE($EXTRACT(X,I,$LENGTH(X)))
+6 QUIT
MKSUBS(FILE,FIELD,NUMS) ; return subscript string for file:field
+1 ; expects: MAP
+2 ; NUMS(n)=array index for level n
+3 NEW SUBSTR
+4 SET SUBSTR=MAP(FILE,FIELD)
+5 QUIT $$SUBNUMS(SUBSTR,.NUMS)
+6 ;
SUBNUMS(SUBSTR,NUMS) ; make substitutions using NUMS array
+1 NEW I,REPLACE
+2 SET I=0
FOR
SET I=$ORDER(NUMS(I))
if 'I
QUIT
SET REPLACE("?"_I)=NUMS(I)
+3 IF $DATA(REPLACE)
SET SUBSTR=$$REPLACE^XLFSTR(SUBSTR,.REPLACE)
+4 QUIT SUBSTR
+5 ;
NEWDATE(NAME,DATE) ; Change date for test
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 SET REC(18)=$SELECT($GET(DATE):DATE,1:$$NOW^XLFDT)
+4 DO FMUPD(601.71,.REC,IEN)
+5 QUIT
FM2ISO(FMDT) ; Convert Fileman Date/Time to ISO 8601
+1 NEW X,Y,M,D,H,N,S,ISODT
+2 SET X=+$$FMTHL7^XLFDT(FMDT)
if 'X
QUIT ""
+3 SET Y=$EXTRACT(X,1,4)
SET M=$EXTRACT(X,5,6)
SET D=$EXTRACT(X,7,8)
+4 SET ISODT=Y
+5 IF +M
SET ISODT=ISODT_"-"_M
IF +D
SET ISODT=ISODT_"-"_D
+6 IF +$EXTRACT(X,9,14)
Begin DoDot:1
+7 SET H=$EXTRACT(X,9,10)
SET N=$EXTRACT(X,11,12)
SET S=$EXTRACT(X,13,14)
+8 SET ISODT=ISODT_"T"_H
+9 IF $LENGTH(N)
SET ISODT=ISODT_":"_N
IF $LENGTH(S)
SET ISODT=ISODT_":"_S
End DoDot:1
+10 QUIT ISODT
+11 ;
ISO2FM(ISODT) ; Convert ISO 8601 Date/Time to Fileman
+1 SET D=$TRANSLATE($PIECE(ISODT,"T"),"-","")_"000000"
+2 SET D=$EXTRACT(D,1,8)-17000000
+3 SET T=$TRANSLATE($PIECE($PIECE(ISODT,"T",2),"-"),":","")
+4 QUIT +(D_$SELECT(+T:"."_T,1:""))
+5 ;
FMADD(FILE,RECORD,IEN) ; Add new record to FILE
+1 ; RECORD(field#)=value
+2 ; RECORD(field#)=global reference to word processing value
+3 ; IEN=optional IEN to attempt to use
+4 ; restrict to MHA
if +$PIECE(FILE,".")'=601
QUIT
+5 NEW YTIEN,YTFDA,YTWP,YTERR,DIERR
+6 MERGE YTFDA(FILE,"+1,")=RECORD
+7 IF $GET(IEN)
SET YTIEN(1)=IEN
+8 DO UPDATE^DIE("","YTFDA","YTIEN","YTERR")
+9 SET IEN=YTIEN(1)
+10 IF $DATA(DIERR)
SET IEN=-1
DO LOG("error","Add "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
+11 DO CLEAN^DILF
+12 QUIT
FMUPD(FILE,RECORD,IEN) ; Add new record to FILE
+1 ; RECORD(field#)=value
+2 ; RECORD(field#)=global reference to word processing value
+3 ; IEN=record to update
+4 ; restrict to MHA
if +$PIECE(FILE,".")'=601
QUIT
+5 NEW YTIEN,YTFDA,YTWP,YTERR,DIERR
+6 MERGE YTFDA(FILE,IEN_",")=RECORD
+7 DO FILE^DIE("","YTFDA","YTERR")
+8 IF $DATA(DIERR)
DO LOG("error","Upd "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
+9 DO CLEAN^DILF
+10 QUIT
+11 ;
FMDEL(FILE,IEN) ; Delete record from FILE
+1 ; IEN=record to delete
+2 ; restrict to MHA
if +$PIECE(FILE,".")'=601
QUIT
+3 if IEN<1
QUIT
+4 NEW DIK,DA
+5 SET DIK="^YTT("_FILE_","
SET DA=IEN
+6 DO ^DIK
+7 QUIT
LOG(TYPE,MSG) ; update statistics
+1 ; optionally expects YTXLOG array -- uses it if defined
+2 IF $GET(YTXLOG)
SET YTXLOG(TYPE)=$GET(YTXLOG(TYPE),0)+1
+3 IF TYPE="error"
Begin DoDot:1
+4 IF $GET(YTXLOG)
SET YTXLOG("error",YTXLOG("error"))=MSG
+5 DO BMES^XPDUTL("ERROR: "_MSG)
End DoDot:1
+6 IF TYPE="conflict"
SET YTXLOG("conflict",YTXLOG("conflict"))=MSG
+7 ; informational, line break
IF TYPE="info"
DO MES^XPDUTL(MSG)
+8 ; progress, no line break
IF TYPE="prog"
WRITE MSG
+9 QUIT
LOGINST(XCHGIEN) ; log installation
+1 NEW YTFDA,YTIEN,YTERR,DIERR
+2 SET YTFDA(601.953,"+1,"_XCHGIEN_",",.01)=$$NOW^XLFDT()
+3 SET YTFDA(601.953,"+1,"_XCHGIEN_",",.02)=DUZ
+4 DO UPDATE^DIE("","YTFDA","YTIEN","YTERR")
+5 IF $DATA(DIERR)
DO LOG("error","History "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
+6 DO CLEAN^DILF
+7 QUIT
BACKUP(TESTNM) ; backup an instrument for later recovery, if necessary
+1 NEW TESTS,IEN,REC
+2 KILL ^TMP("YTXCHG",$JOB,"WP",2)
+3 SET TESTS(1)=$ORDER(^YTT(601.71,"B",TESTNM,0))
if 'TESTS(1)
QUIT
+4 SET REC(.01)="YTBackup"_TESTNM_"-"_$TRANSLATE($$HTE^XLFDT($HOROLOG,"7DZ"),"/","-")
+5 SET REC(.02)=$$NOW^XLFDT
+6 SET REC(.03)="backup copy"
+7 SET REC(2)=$NAME(^TMP("YTXCHG",$JOB,"WP",2))
+8 SET ^TMP("YTXCHG",$JOB,"WP",2,1,0)="backup copy of "_TESTNM
+9 SET IEN=$$CREATE^YTXCHG(.TESTS,.REC)
+10 KILL ^TMP("YTXCHG",$JOB,"WP",2)
+11 DO QDEL(IEN,REC(.01),REC(.02),3)
+12 QUIT
QDEL(XCHGIEN,XCHGNM,XCHGDT,DAYS) ; Queue a task to delete an exchange entry
+1 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
+2 SET ZTIO=""
+3 SET ZTRTN="DQDEL^YTXCHGU"
+4 SET ZTDESC="Remove "_XCHGNM
+5 SET ZTDTH=$$HADD^XLFDT($HOROLOG,DAYS)
+6 SET ZTSAVE("XCHGIEN")=""
SET ZTSAVE("XCHGNM")=""
SET ZTSAVE("XCHGDT")=""
+7 DO ^%ZTLOAD
+8 IF '$GET(ZTSK)
DO LOG("error","Unsuccessful queue "_XCHGNM)
+9 QUIT
DQDEL ; Dequeue of instrument exchange entry removal
+1 SET ZTREQ="@"
+2 NEW X0
SET X0=^YTT(601.95,XCHGIEN,0)
+3 ; no longer same entry
IF ($PIECE(X0,U)'=XCHGNM)!($PIECE(X0,U,2)'=XCHGDT)
QUIT
+4 DO FMDEL(601.95,XCHGIEN)
+5 QUIT
TREEOUT ; Save tree representation to file
+1 KILL ^TMP("YTXCHG",$JOB,"TREE")
+2 KILL ^TMP("YTXCHG",$JOB,"HFS")
+3 NEW XCHGIEN,FULLNM,NUM
+4 SET XCHGIEN=$$LKUP^YTXCHGP(601.95)
+5 IF 'XCHGIEN
QUIT
+6 SET FULLNM=$$PRMTNAME^YTXCHGP("Enter file name","Enter full path and filename.",245)
+7 IF '$LENGTH(FULLNM)
QUIT
+8 DO SPEC2TR^YTXCHGT(XCHGIEN,$NAME(^TMP("YTXCHG",$JOB,"TREE")))
+9 SET NUM=$$PICKTEST^YTXCHGP($NAME(^TMP("YTXCHG",$JOB,"TREE")))
if 'NUM
GOTO XTREEOUT
+10 ;
+11 NEW X,I,ROOT,LROOT,CNT,SUB,LINE,ESC
+12 SET X=$NAME(^TMP("YTXCHG",$JOB,"TREE","test",NUM))
+13 SET ROOT=$EXTRACT(X,1,$LENGTH(X)-1)
SET LROOT=$LENGTH(ROOT)
SET CNT=0
+14 FOR
SET X=$QUERY(@X)
if $EXTRACT(X,1,LROOT)'=ROOT
QUIT
Begin DoDot:1
+15 SET LINE=""
SET ESC=0
+16 FOR I=6:1:$QLENGTH(X)
Begin DoDot:2
+17 SET SUB=$QSUBSCRIPT(X,I)
+18 ; JSON "treat number as string"
IF SUB="\s"
SET ESC=1
QUIT
+19 IF +SUB
IF (+SUB=SUB)
SET SUB="["_SUB_"]"
IF 1
+20 IF '$TEST
if $LENGTH(LINE)
SET LINE=LINE_"."
+21 SET LINE=LINE_SUB
End DoDot:2
+22 ; skip line if it is just a string "escape"
if ESC
QUIT
+23 ; W !,LINE_"="_@X ; uncomment to write to screen
+24 SET CNT=CNT+1
SET ^TMP("YTXCHG",$JOB,"HFS",CNT,0)=LINE_"="_@X
End DoDot:1
+25 ;
+26 NEW PATH,FILE,OK
+27 DO SPLTDIR^YTXCHGU(FULLNM,.PATH,.FILE)
+28 SET OK=$$GTF^%ZISH($NAME(^TMP("YTXCHG",$JOB,"HFS",1,0)),4,PATH,FILE)
+29 WRITE !,"File "_$SELECT(OK:"",1:"not ")_"saved."
XTREEOUT ; exit TREEOUT
+1 KILL ^TMP("YTXCHG",$JOB,"TREE")
+2 KILL ^TMP("YTXCHG",$JOB,"HFS")
+3 QUIT
FSZ(FNUM) ; return size of Fileman file in bytes (uncompressed)
+1 NEW ROOT,SIZE,I
+2 ; get global root in closed form
SET ROOT=$$ROOT^DILFD(FNUM,"",1)
+3 SET SIZE=0
+4 IF $DATA(@ROOT)#2
SET SIZE=$LENGTH(@ROOT)
+5 IF $DATA(@ROOT)>1
SET I=0
FOR
SET I=$ORDER(@ROOT@(I))
if 'I
QUIT
SET SIZE=SIZE+$LENGTH(@ROOT@(I,0))
+6 QUIT SIZE
+7 ;
TFM2ISO ; test Fileman to ISO Date/Time
+1 WRITE !,$$FM2ISO("3100900")
+2 WRITE !,$$FM2ISO("3120415")
+3 WRITE !,$$FM2ISO("3120415.1")
+4 WRITE !,$$FM2ISO("3120415.102")
+5 WRITE !,$$FM2ISO("3120415.100001")
+6 WRITE !,$$FM2ISO("3120415.170001")
+7 WRITE !,$$FM2ISO("3160620.111")
+8 QUIT
TISO2FM ; test ISO to Fileman date/time
+1 WRITE !,$$ISO2FM("2010-09")
+2 WRITE !,$$ISO2FM("2012-04-15")
+3 WRITE !,$$ISO2FM("2012-04-15T10:00")
+4 WRITE !,$$ISO2FM("2012-04-15T10:20")
+5 WRITE !,$$ISO2FM("2012-04-15T10:00:01")
+6 WRITE !,$$ISO2FM("2012-04-15T17:00:01")
+7 WRITE !,$$ISO2FM("2012-04-15T17:00:01-0600")
+8 WRITE !,$$ISO2FM("2016-06-20T11:10")
+9 QUIT
