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

YTXCHGI.m

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