Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTXCHGU

YTXCHGU.m

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