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

YS234PST.m

Go to the documentation of this file. 
  1. YS234PST ;BAL/KTL - Patch 234 Post-init ; 06/05/2023
  1.  ;;5.01;MENTAL HEALTH;**234**;Dec 30, 1994;Build 38
  1.  ;
  1.  ; Reference to EN^XPAR in ICR #2263
  1.  ; Reference to GETLST^XPAR in ICR #2263
  1.  ; Reference to XLFSTR in ICR #10104
  1.  ; Reference to TIUFLF7 in ICR #5352
  1.  Q
  1. EDTDATE ; date used to update 601.71:18
  1.  ;;3231127.2159
  1.  Q
  1. PRE ; nothing necessary
  1.  Q
  1. POST ; post-init
  1.  N OLD,NEW
  1.  S OLD="MDQ",NEW="ZZMDQ-OLD" D INACT(OLD,NEW)
  1.  D RENAME("VFQ20","LVVFQ")
  1.  D CHGCAT("Depression","Depression/Mood")
  1.  D CHGCAT("Pain / Health","Pain/Health")
  1.  D INSTALLQ^YTXCHG("XCHGLST","YS234PST")
  1.  D SETCAT("EAT-26","Eating/Nutrition")
  1.  ;D SETCAT("ESS","Sleep")
  1.  D SETCAT("MDQ","Depression/Mood")
  1.  D SETCAT("PEG","Pain/Health")
  1.  D SETCAT("BAM-C-CBT-SUD","Addiction-SUD")
  1.  D SETCAT("BAM-R-CSG-SUD","Addiction-SUD")
  1.  D SETCAT("BAM-IOP-CSG-SUD","Addiction-SUD")
  1.  D SETCAT("CMAI","General Symptoms")
  1.  D SETCAT("CMAI","Cognitive/Learning")
  1.  D SETCAT("LVVFQ","General Symptoms")
  1.  D SETCAT("LVVFQ","Screening")
  1.  D SETCAT("PSEQ-2","Pain/Health")
  1.  D SETCAT("NPI-Q","General Symptoms")
  1.  ;D DROPTST("MMPI2")
  1.  D ADDNOTE("LVVFQ")  ;Add TIU TITLE and CONSULT NOTE TITLE
  1.  D SETNAT("LVVFQ","Y")
  1.  D DROPTST("MCMI3")
  1.  D DROPTST("ASSIST-NIDA")
  1.  D UPDURL
  1.  Q
  1.  ;
  1. RENAME(OLD,NEW) ; Rename Instrument
  1.  S IEN=$O(^YTT(601.71,"B",OLD,0)) Q:'IEN  ; old name not found
  1.  S REC(.01)=NEW
  1.  D FMUPD^YTXCHGU(601.71,.REC,IEN)
  1.  Q
  1. UPDTST(NAME) ; Update Date Edited
  1.  N IEN,REC
  1.  S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
  1.  S REC(18)=$P($T(EDTDATE+1),";;",2)
  1.  D FMUPD^YTXCHGU(601.71,.REC,IEN)
  1.  Q
  1. SETNAT(NAME,NAT) ; SET NATIONAL FLAG
  1.  N IEN,REC
  1.  S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
  1.  S NAT=$G(NAT) Q:"YN"'[NAT
  1.  S REC(19)=NAT
  1.  D FMUPD^YTXCHGU(601.71,.REC,IEN)
  1.  Q
  1.  ;
  1. INACT(OLD,NEW) ; INACTIVATE test left in Development - Change test name *AND* set OPERATIONAL to NO
  1.  N REC,IEN
  1.  S IEN=$O(^YTT(601.71,"B",OLD,0))
  1.  I 'IEN QUIT  ; already updated
  1.  S REC(.01)=NEW
  1.  S REC(10)="N"
  1.  S REC(18)=$P($T(EDTDATE+1),";;",2)
  1.  D FMUPD^YTXCHGU(601.71,.REC,IEN)
  1.  K REC,IEN
  1.  S IEN=$O(^YTT(601,"B",OLD,0))
  1.  I 'IEN QUIT
  1.  S REC(.01)=NEW
  1.  S REC(32)="N"
  1.  D FMUPD^YTXCHGU(601,.REC,IEN)
  1.  Q
  1. DROPTST(NAME) ; Change OPERATIONAL to dropped
  1.  N IEN,REC
  1.  S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
  1.  S REC(10)="D"
  1.  S REC(18)=$P($T(EDTDATE+1),";;",2)
  1.  D FMUPD^YTXCHGU(601.71,.REC,IEN)
  1.  Q
  1. NEWCAT(CATNM) ; add new category
  1.  I $D(^YTT(601.97,"B",CATNM)) QUIT  ; already there
  1.  N REC
  1.  S REC(.01)=CATNM
  1.  D FMADD^YTXCHGU(601.97,.REC)
  1.  Q
  1. SETCAT(TEST,CATNM) ; add category to TEST if not already there
  1.  N CAT
  1.  I TEST'=+TEST S TEST=$O(^YTT(601.71,"B",TEST,0)) QUIT:'TEST
  1.  S CAT=$O(^YTT(601.97,"B",CATNM,0)) QUIT:'CAT
  1.  I $D(^YTT(601.71,TEST,10,"B",CAT))=10 QUIT  ; already there
  1.  ;
  1.  N YTFDA,YTIEN,DIERR
  1.  S YTFDA(601.71101,"+1,"_TEST_",",.01)=CATNM
  1.  D UPDATE^DIE("E","YTFDA","YTIEN")
  1.  I $D(DIERR) D MES^XPDUTL(CATNM_": "_$G(^TMP("DIERR",$J,1,"TEXT",1)))
  1.  D CLEAN^DILF
  1.  Q
  1. DELCAT(TEST,CATNM) ; remove category from test if it is there
  1.  N CAT,DIK,DA
  1.  I TEST'=+TEST S TEST=$O(^YTT(601.71,"B",TEST,0)) QUIT:'TEST
  1.  S CAT=$O(^YTT(601.97,"B",CATNM,0)) QUIT:'CAT
  1.  S DA=$O(^YTT(601.71,TEST,10,"B",CAT,0)) Q:'DA
  1.  S DA(1)=TEST
  1.  S DIK="^YTT(601.71,"_TEST_",10,"
  1.  D ^DIK
  1.  Q
  1.  ;
  1. CHGCAT(OLD,NEW) ; change category name
  1.  N IEN,REC
  1.  S IEN=$O(^YTT(601.97,"B",OLD,0)) Q:'IEN
  1.  S REC(.01)=NEW
  1.  D FMUPD^YTXCHGU(601.97,.REC,IEN)
  1.  Q
  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 CSLT=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH CONSULT NOTE","TL")
  1.  S:CSLT=0 CSLT=+$$DDEFIEN^TIUFLF7("MH CONSULT NOTE","TL")
  1.  S:NOTE=0 NOTE="@"
  1.  S:CSLT=0 CSLT="@"
  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^YTXCHGI(1,601.71,.REC,IEN)                 ; FMSAVE in case dry run
  1.  D LOG^YTXCHGU("info","Linked note title.")
  1.  Q
  1.  ;
  1. SCREEN ; line to put in DATA SCREEN of KIDS build
  1.  ; $$INCLUDE^YTXCHG(Y,"TAG","RTN") calls TAG^RTN to get an array of
  1.  ; instrument exchange entries to include in the build.  It sets Y
  1.  ; to true if the entry should be included.
  1.  ; 
  1.  I $$INCLUDE^YTXCHG(Y,"XCHGLST","YS234PST")
  1.  Q
  1.  ;
  1. XCHGLST(ARRAY) ; return array of instrument exchange entries
  1.  ; ARRAY(cnt,1)=instrument exchange entry name
  1.  ; ARRAY(cnt,2)=instrument exchange entry creation date
  1.  ;
  1.  N I,X
  1.  F I=1:1 S X=$P($T(ENTRIES+I),";;",2,99) Q:X="zzzzz"  D
  1.  . S ARRAY(I,1)=$P(X,U)
  1.  . S ARRAY(I,2)=$P(X,U,2)
  1.  Q
  1. UPDURL ; Update GUI TOOLS URL for MHA Web
  1.  ;Z
  1.  N LIST,PARM,ERR,ENT,INST,VAL,TITL,CMD,SPEC,NEWVAL
  1.  K ^TMP($J,"XPAR")
  1.  S LIST=$NA(^TMP($J,"XPAR"))
  1.  S PARM="ORWT TOOLS MENU"
  1.  D ENVAL^XPAR(LIST,PARM,"",.ERR,1)
  1.  S ^XTMP("YS234-TOOLS",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"MH Backup Tools Menu"
  1.  M ^XTMP("YS234-TOOLS","XPAR")=^TMP($J,"XPAR")
  1.  S SPEC("/home?")="/home/c/?",SPEC("/home/?")="/home/c/?"  ;In case URL entered home/? Patch 234
  1.  S SPEC("/home/a/?")="/home/c/?"  ;Patch 234
  1.  S ENT="" F  S ENT=$O(^TMP($J,"XPAR",ENT)) Q:ENT=""  D
  1.  . S INST=0 F  S INST=$O(^TMP($J,"XPAR",ENT,INST)) Q:+INST=0  D
  1.  .. S VAL=^TMP($J,"XPAR",ENT,INST)
  1.  .. I (VAL["mha.domain.ext/app/home?"!(VAL["mha.domain.ext/app/home/")) D
  1.  ... S TITL=$P(VAL,"="),CMD=$P(VAL,"=",2,99)
  1.  ... S CMD=$$REPLACE^XLFSTR(CMD,.SPEC)
  1.  ... S NEWVAL=TITL_"="_CMD
  1.  ... D BMES^XPDUTL("Updating "_CMD_" for "_ENT)
  1.  ... D EN^XPAR(ENT,PARM,INST,NEWVAL,.ERR)
  1.  K ^TMP($J,"XPAR")
  1.  Q
  1. ENTRIES ; New MHA instruments ^ Exchange Entry Date
  1.  ;;YS*5.01*234 MDQ^06/29/2023@12:28:56
  1.  ;;YS*5.01*234 BAM-C-CBT-SUD^07/11/2023@12:14:57
  1.  ;;YS*5.01*234 BAM-R-CSG-SUD^07/12/2023@00:03:16
  1.  ;;YS*5.01*234 BAM-IOP-CSG-SUD^07/27/2023@16:57:29
  1.  ;;YS*5.01*234 CMAI^08/02/2023@12:53:58
  1.  ;;YS*5.01*234 PEG^08/02/2023@14:27:01
  1.  ;;YS*5.01*234 LVVFQ^08/07/2023@23:37:21
  1.  ;;YS*5.01*234 MINICOG^08/15/2023@12:06:32
  1.  ;;YS*5.01*234 PSEQ-2^08/24/2023@15:36:43
  1.  ;;YS*5.01*234 NPI-Q^08/26/2023@01:03:01
  1.  ;;YS*5.01*234 EAT-26^08/29/2023@23:17:52
  1.  ;;YS*5.01*234 AUDC^08/30/2023@00:12:52
  1.  ;;YS*5.01*234 PC-PTSD-5^09/12/2023@13:03:46
  1.  ;;YS*5.01*234 WBS_V2^10/18/2023@12:02:43
  1.  ;;YS*5.01*234 D.ERS^10/27/2023@14:43:17
  1.  ;;zzzzz
  1.  ;
  1.  Q
  1.  ;;YS*5.01*234 ESS^06/29/2023@12:29:33