YS202PST ;BAL/KTL - Patch 202 Post-Init ; Apr 01, 2021@16:31
;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
;
; Reference to OPTION in ICR #10075
; Reference to XPAR in ICR #2263
; Reference to DIQ in ICR #2056
Q
EDTDATE ; date used to update 601.71:18
;;3220909.1029
Q
POST ; Post-init for YS*5.01*202
N YNOW,YSDT,NDX
D DEQUEUE
D RMPARM
D RMWIDG
S NDX="YSB-DASH-"
F S NDX=$O(^XTMP(NDX)) Q:NDX=""!(NDX'["YSB-DASH") D
. K ^XTMP(NDX) ;Clear cached data if present
D INSTALLQ^YTXCHG("XCHGLST","YS202PST")
D UPDTST("PCL-5")
D UPDTST("PCL-5 WEEKLY")
D UPDTST("CSI PARTNER VERSION")
D UPDTST("CAD-PTSD-DX")
D UPDTST("MCMI4")
D CHGCAT("Cognitive","Cognitive/Learning")
D SETCAT("CAT-PSYCHOSIS","CAT/CAD")
D SETCAT("CAT-PSYCHOSIS","Psychosis")
D SETCAT("EHS-14","Employment")
D SETCAT("PEBS-20","Employment")
D SETCAT("PEBS-27","Employment")
D SETCAT("WBS","Screening")
D SETCAT("WBS","Quality of Life")
D SETCAT("ASRS","Screening")
D SETCAT("ASRS","Cognitive/Learning")
D SETCAT("DAR-5","Screening")
D SETCAT("DAR-5","Frequent MBCs")
D UPDREV("FAST",2)
D DROPTST("CAT-PTSD")
D DROPTST("CAT-ADHD")
D DROPTST("CAT-SDOH")
D RMBLNK("BASIS-24")
D UPDURL
S OLD="SCL90R",NEW="SCL9R" D CHGNM(OLD,NEW) ;Revert back the name if it was changed
D UPDINTRP^YS202TXT
;D UPD^YS202UPT ;Update Print Titles in MH TEST/SURVEY SPEC file.
Q
UPDTST(NAME) ; Update Date Edited
N IEN,REC
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
RMBLNK(NAME) ; Remove blank fields from instrument
N YSIEN,IEN,REC,YSTMP,DIERR,FLD
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
S YSIEN=IEN_","
D GETS^DIQ(601.71,YSIEN,"4;5;7.5;12;13;14","","YSTMP","DIERR")
Q:+$G(DIERR)'=0
F FLD=4,5,7.5,12,13,14 D
. I $G(YSTMP(601.71,YSIEN,FLD))=" " S REC(FLD)="@"
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
DEQUEUE ;Dequeue Old Taskman job if present
N YSRET,YST,ZTSK
K ^TMP($J)
D RTN^%ZTLOAD("VST^YSBBKG",.YSRET)
S YST=0 F S YST=$O(^TMP($J,YST)) Q:YST="" D
. S ZTSK=YST
. D STAT^%ZTLOAD
. I $G(ZTSK(1))=1 D REM(YST) ;Remove Active
K ^TMP($J)
Q
REM(TSK) ;
N ZTSK
S ZTSK=TSK
D KILL^%ZTLOAD
Q
RMPARM ;Remove Parameters no longer used
N ERR
D EN^XPAR("SYS","YSB CSRE HF CATEGORY",1,"@",.ERR)
D EN^XPAR("SYS","YSB SAFETY PLAN HF CATEGORY",1,"@",.ERR)
Q
RMWIDG ;Remove MBC Widget
N FDA,YSIEN
S YSIEN=$O(^YSD(605.1,"B","MBC",""))
Q:YSIEN=""
S FDA(605.1,YSIEN_",",.01)="@"
D FILE^DIE("","FDA")
Q
UPDREV(NAME,REV) ; Update scoring revision
N IEN,REC
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
S REC(93)=REV
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
DROPTST(NAME) ; Change OPERATIONAL to dropped
N IEN,REC
S IEN=$O(^YTT(601.71,"B",NAME,0)) Q:'IEN
S REC(10)="D"
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
NEWCAT(CATNM) ; add new category
I $D(^YTT(601.97,"B",CATNM)) QUIT ; already there
N REC
S REC(.01)=CATNM
D FMADD^YTXCHGU(601.97,.REC)
Q
SETCAT(TEST,CATNM) ; add category to TEST if not already there
N CAT
I TEST'=+TEST S TEST=$O(^YTT(601.71,"B",TEST,0)) QUIT:'TEST
S CAT=$O(^YTT(601.97,"B",CATNM,0)) QUIT:'CAT
I $D(^YTT(601.71,TEST,10,"B",CAT))=10 QUIT ; already there
;
N YTFDA,YTIEN,DIERR
S YTFDA(601.71101,"+1,"_TEST_",",.01)=CATNM
D UPDATE^DIE("E","YTFDA","YTIEN")
I $D(DIERR) D MES^XPDUTL(CATNM_": "_$G(^TMP("DIERR",$J,1,"TEXT",1)))
D CLEAN^DILF
Q
CHGCAT(OLD,NEW) ; change category name
N IEN,REC
S IEN=$O(^YTT(601.97,"B",OLD,0)) Q:'IEN
S REC(.01)=NEW
D FMUPD^YTXCHGU(601.97,.REC,IEN)
Q
;
XCHGLST(ARRAY) ; return array of instrument exchange entries
; ARRAY(cnt,1)=instrument exchange entry name
; ARRAY(cnt,2)=instrument exchange entry creation date
;
N I,X
F I=1:1 S X=$P($T(ENTRIES+I),";;",2,99) Q:X="zzzzz" D
. S ARRAY(I,1)=$P(X,U)
. S ARRAY(I,2)=$P(X,U,2)
Q
UPDURL ; Update GUI TOOLS URL for MHA Web
N LIST,PARM,ERR,ENT,INST,VAL,TITL,CMD,SPEC,NEWVAL
K ^TMP($J,"XPAR")
S LIST=$NA(^TMP($J,"XPAR"))
S PARM="ORWT TOOLS MENU"
D ENVAL^XPAR(LIST,PARM,"",.ERR,1)
S ^XTMP("YS202-TOOLS",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"MH Backup Tools Menu"
M ^XTMP("YS202-TOOLS","XPAR")=^TMP($J,"XPAR")
S SPEC("/home?")="/home/b/?",SPEC("/home/?")="/home/b/?" ;In case URL entered home/? Patch 187 to 202
S SPEC("/home/a/?")="/home/b/?" ;Patch 199 to 202
S ENT="" F S ENT=$O(^TMP($J,"XPAR",ENT)) Q:ENT="" D
. S INST=0 F S INST=$O(^TMP($J,"XPAR",ENT,INST)) Q:+INST=0 D
.. S VAL=^TMP($J,"XPAR",ENT,INST)
.. I (VAL["mha.domain.ext/app/home?"!(VAL["mha.domain.ext/app/home/")) D
... S TITL=$P(VAL,"="),CMD=$P(VAL,"=",2,99)
... S CMD=$$REPLACE^XLFSTR(CMD,.SPEC)
... S NEWVAL=TITL_"="_CMD
... D BMES^XPDUTL("Updating "_CMD_" for "_ENT)
... D EN^XPAR(ENT,PARM,INST,NEWVAL,.ERR)
K ^TMP($J,"XPAR")
Q
CHGNM(OLD,NEW) ; Change test name
N REC,IEN
S IEN=$O(^YTT(601.71,"B",OLD,0))
I 'IEN QUIT ; already updated
S REC(.01)=NEW
S REC(18)=$P($T(EDTDATE+1),";;",2)
D FMUPD^YTXCHGU(601.71,.REC,IEN)
Q
;
ENTRIES ; New MHA instruments^Exchange Entry Date
;;YS*5.01*202 PRINT TITLE UPDATE^04/08/2022@16:02:13
;;YS*5.01*202 NEW INSTRUMENTS^05/31/2022@11:02:45
;;YS*5.01*202 MCMI4 UPDATE^06/08/2022@17:49:11
;;zzzzz
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS202PST 5411 printed Dec 13, 2024@02:12:38 Page 2
YS202PST ;BAL/KTL - Patch 202 Post-Init ; Apr 01, 2021@16:31
+1 ;;5.01;MENTAL HEALTH;**202**;Dec 30, 1994;Build 47
+2 ;
+3 ; Reference to OPTION in ICR #10075
+4 ; Reference to XPAR in ICR #2263
+5 ; Reference to DIQ in ICR #2056
+6 QUIT
EDTDATE ; date used to update 601.71:18
+1 ;;3220909.1029
+2 QUIT
POST ; Post-init for YS*5.01*202
+1 NEW YNOW,YSDT,NDX
+2 DO DEQUEUE
+3 DO RMPARM
+4 DO RMWIDG
+5 SET NDX="YSB-DASH-"
+6 FOR
SET NDX=$ORDER(^XTMP(NDX))
if NDX=""!(NDX'["YSB-DASH")
QUIT
Begin DoDot:1
+7 ;Clear cached data if present
KILL ^XTMP(NDX)
End DoDot:1
+8 DO INSTALLQ^YTXCHG("XCHGLST","YS202PST")
+9 DO UPDTST("PCL-5")
+10 DO UPDTST("PCL-5 WEEKLY")
+11 DO UPDTST("CSI PARTNER VERSION")
+12 DO UPDTST("CAD-PTSD-DX")
+13 DO UPDTST("MCMI4")
+14 DO CHGCAT("Cognitive","Cognitive/Learning")
+15 DO SETCAT("CAT-PSYCHOSIS","CAT/CAD")
+16 DO SETCAT("CAT-PSYCHOSIS","Psychosis")
+17 DO SETCAT("EHS-14","Employment")
+18 DO SETCAT("PEBS-20","Employment")
+19 DO SETCAT("PEBS-27","Employment")
+20 DO SETCAT("WBS","Screening")
+21 DO SETCAT("WBS","Quality of Life")
+22 DO SETCAT("ASRS","Screening")
+23 DO SETCAT("ASRS","Cognitive/Learning")
+24 DO SETCAT("DAR-5","Screening")
+25 DO SETCAT("DAR-5","Frequent MBCs")
+26 DO UPDREV("FAST",2)
+27 DO DROPTST("CAT-PTSD")
+28 DO DROPTST("CAT-ADHD")
+29 DO DROPTST("CAT-SDOH")
+30 DO RMBLNK("BASIS-24")
+31 DO UPDURL
+32 ;Revert back the name if it was changed
SET OLD="SCL90R"
SET NEW="SCL9R"
DO CHGNM(OLD,NEW)
+33 DO UPDINTRP^YS202TXT
+34 ;D UPD^YS202UPT ;Update Print Titles in MH TEST/SURVEY SPEC file.
+35 QUIT
UPDTST(NAME) ; Update Date Edited
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+4 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+5 QUIT
RMBLNK(NAME) ; Remove blank fields from instrument
+1 NEW YSIEN,IEN,REC,YSTMP,DIERR,FLD
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 SET YSIEN=IEN_","
+4 DO GETS^DIQ(601.71,YSIEN,"4;5;7.5;12;13;14","","YSTMP","DIERR")
+5 if +$GET(DIERR)'=0
QUIT
+6 FOR FLD=4,5,7.5,12,13,14
Begin DoDot:1
+7 IF $GET(YSTMP(601.71,YSIEN,FLD))=" "
SET REC(FLD)="@"
End DoDot:1
+8 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+9 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+10 QUIT
DEQUEUE ;Dequeue Old Taskman job if present
+1 NEW YSRET,YST,ZTSK
+2 KILL ^TMP($JOB)
+3 DO RTN^%ZTLOAD("VST^YSBBKG",.YSRET)
+4 SET YST=0
FOR
SET YST=$ORDER(^TMP($JOB,YST))
if YST=""
QUIT
Begin DoDot:1
+5 SET ZTSK=YST
+6 DO STAT^%ZTLOAD
+7 ;Remove Active
IF $GET(ZTSK(1))=1
DO REM(YST)
End DoDot:1
+8 KILL ^TMP($JOB)
+9 QUIT
REM(TSK) ;
+1 NEW ZTSK
+2 SET ZTSK=TSK
+3 DO KILL^%ZTLOAD
+4 QUIT
RMPARM ;Remove Parameters no longer used
+1 NEW ERR
+2 DO EN^XPAR("SYS","YSB CSRE HF CATEGORY",1,"@",.ERR)
+3 DO EN^XPAR("SYS","YSB SAFETY PLAN HF CATEGORY",1,"@",.ERR)
+4 QUIT
RMWIDG ;Remove MBC Widget
+1 NEW FDA,YSIEN
+2 SET YSIEN=$ORDER(^YSD(605.1,"B","MBC",""))
+3 if YSIEN=""
QUIT
+4 SET FDA(605.1,YSIEN_",",.01)="@"
+5 DO FILE^DIE("","FDA")
+6 QUIT
UPDREV(NAME,REV) ; Update scoring revision
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 SET REC(93)=REV
+4 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+5 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+6 QUIT
DROPTST(NAME) ; Change OPERATIONAL to dropped
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))
if 'IEN
QUIT
+3 SET REC(10)="D"
+4 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+5 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+6 QUIT
NEWCAT(CATNM) ; add new category
+1 ; already there
IF $DATA(^YTT(601.97,"B",CATNM))
QUIT
+2 NEW REC
+3 SET REC(.01)=CATNM
+4 DO FMADD^YTXCHGU(601.97,.REC)
+5 QUIT
SETCAT(TEST,CATNM) ; add category to TEST if not already there
+1 NEW CAT
+2 IF TEST'=+TEST
SET TEST=$ORDER(^YTT(601.71,"B",TEST,0))
if 'TEST
QUIT
+3 SET CAT=$ORDER(^YTT(601.97,"B",CATNM,0))
if 'CAT
QUIT
+4 ; already there
IF $DATA(^YTT(601.71,TEST,10,"B",CAT))=10
QUIT
+5 ;
+6 NEW YTFDA,YTIEN,DIERR
+7 SET YTFDA(601.71101,"+1,"_TEST_",",.01)=CATNM
+8 DO UPDATE^DIE("E","YTFDA","YTIEN")
+9 IF $DATA(DIERR)
DO MES^XPDUTL(CATNM_": "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1)))
+10 DO CLEAN^DILF
+11 QUIT
CHGCAT(OLD,NEW) ; change category name
+1 NEW IEN,REC
+2 SET IEN=$ORDER(^YTT(601.97,"B",OLD,0))
if 'IEN
QUIT
+3 SET REC(.01)=NEW
+4 DO FMUPD^YTXCHGU(601.97,.REC,IEN)
+5 QUIT
+6 ;
XCHGLST(ARRAY) ; return array of instrument exchange entries
+1 ; ARRAY(cnt,1)=instrument exchange entry name
+2 ; ARRAY(cnt,2)=instrument exchange entry creation date
+3 ;
+4 NEW I,X
+5 FOR I=1:1
SET X=$PIECE($TEXT(ENTRIES+I),";;",2,99)
if X="zzzzz"
QUIT
Begin DoDot:1
+6 SET ARRAY(I,1)=$PIECE(X,U)
+7 SET ARRAY(I,2)=$PIECE(X,U,2)
End DoDot:1
+8 QUIT
UPDURL ; Update GUI TOOLS URL for MHA Web
+1 NEW LIST,PARM,ERR,ENT,INST,VAL,TITL,CMD,SPEC,NEWVAL
+2 KILL ^TMP($JOB,"XPAR")
+3 SET LIST=$NAME(^TMP($JOB,"XPAR"))
+4 SET PARM="ORWT TOOLS MENU"
+5 DO ENVAL^XPAR(LIST,PARM,"",.ERR,1)
+6 SET ^XTMP("YS202-TOOLS",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"MH Backup Tools Menu"
+7 MERGE ^XTMP("YS202-TOOLS","XPAR")=^TMP($JOB,"XPAR")
+8 ;In case URL entered home/? Patch 187 to 202
SET SPEC("/home?")="/home/b/?"
SET SPEC("/home/?")="/home/b/?"
+9 ;Patch 199 to 202
SET SPEC("/home/a/?")="/home/b/?"
+10 SET ENT=""
FOR
SET ENT=$ORDER(^TMP($JOB,"XPAR",ENT))
if ENT=""
QUIT
Begin DoDot:1
+11 SET INST=0
FOR
SET INST=$ORDER(^TMP($JOB,"XPAR",ENT,INST))
if +INST=0
QUIT
Begin DoDot:2
+12 SET VAL=^TMP($JOB,"XPAR",ENT,INST)
+13 IF (VAL["mha.domain.ext/app/home?"!(VAL["mha.domain.ext/app/home/"))
Begin DoDot:3
+14 SET TITL=$PIECE(VAL,"=")
SET CMD=$PIECE(VAL,"=",2,99)
+15 SET CMD=$$REPLACE^XLFSTR(CMD,.SPEC)
+16 SET NEWVAL=TITL_"="_CMD
+17 DO BMES^XPDUTL("Updating "_CMD_" for "_ENT)
+18 DO EN^XPAR(ENT,PARM,INST,NEWVAL,.ERR)
End DoDot:3
End DoDot:2
End DoDot:1
+19 KILL ^TMP($JOB,"XPAR")
+20 QUIT
CHGNM(OLD,NEW) ; Change test name
+1 NEW REC,IEN
+2 SET IEN=$ORDER(^YTT(601.71,"B",OLD,0))
+3 ; already updated
IF 'IEN
QUIT
+4 SET REC(.01)=NEW
+5 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
+6 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
+7 QUIT
+8 ;
ENTRIES ; New MHA instruments^Exchange Entry Date
+1 ;;YS*5.01*202 PRINT TITLE UPDATE^04/08/2022@16:02:13
+2 ;;YS*5.01*202 NEW INSTRUMENTS^05/31/2022@11:02:45
+3 ;;YS*5.01*202 MCMI4 UPDATE^06/08/2022@17:49:11
+4 ;;zzzzz
+5 ;
+6 QUIT
