Routine: YS250PST

YS250PST ;BAL/KTL - Patch 250 Post-init ;June 25, 2024@13:55:37

 ;;5.01;MENTAL HEALTH;**250**;Dec 30, 1994;Build 26

 ; Reference to EN^XPAR in ICR #2263

 ; Reference to GETLST^XPAR in ICR #2263

 ; Reference to XLFSTR in ICR #10104

 ; Reference to TIUFLF7 in ICR #5352

EDTDATE ; date used to update 601.71:18

 ;;3241009.2159

PRE ; nothing necessary

POST ; post-init

 D INSTALLQ^YTXCHG("XCHGLST","YS250PST")

 D SETCAT("AAQ-II-7","EBP")

 D SETCAT("ALSFRS-R","ADL/Func Status")

 D SETCAT("ALSFRS-R","Pain/Health")

 D SETCAT("ALSSQOL-SF","Quality of Life")

 D SETCAT("ALSSQOL-SF","Pain/Health")

 D REACTTST("BBHI-2")

 D UPDURL

 D FIXINST

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

REACTTST(NAME) ; Change OPERATIONAL to YES

 N IEN,REC

 S IEN=$O(^YTT(601.71,"B",NAME,0))

 I +IEN'=0 D

 . S REC(10)="Y"

 . S REC(18)=$P($T(EDTDATE+1),";;",2)

 . D FMUPD^YTXCHGU(601.71,.REC,IEN)

 K REC,IEN

 S IEN=$O(^YTT(601,"B",NAME,0))

 I 'IEN QUIT

 S REC(32)="N"

 D FMUPD^YTXCHGU(601,.REC,IEN)

UPDURL ; Update GUI TOOLS URL for MHA Web

;Z

 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("YS250-TOOLS",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"MH Backup Tools Menu"

 M ^XTMP("YS250-TOOLS","XPAR")=^TMP($J,"XPAR")

 S SPEC("/home?")="/home/p250/?",SPEC("/home/?")="/home/p250/?"  ;In case URL entered home/? Patch 250

 S SPEC("/home/p249/?")="/home/p250/?"  ;Patch 250

 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")

FIXINST ; Fix instrument note titles for sites that do not have

 ; MENTAL HEALTH DIAGNOSTIC STUDY NOTE and MENTAL HEALTH CONSULT NOTE

 N YSIEN,NOTE,CSLT,YSOPER,ARRAY,ALTNOTE,ALTCSLT,REC,YSPRIV

 S NOTE=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH DIAGNOSTIC STUDY NOTE","TL")

 S CSLT=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH CONSULT NOTE","TL")

 I NOTE'=0!(CSLT'=0) QUIT  ;Only fix if both note titles are not available

 S ALTNOTE=+$$DDEFIEN^TIUFLF7("MH DIAGNOSTIC STUDY NOTE","TL")

 S ALTCSLT=+$$DDEFIEN^TIUFLF7("MH CONSULT NOTE","TL")

 I 'ALTNOTE!'ALTCSLT QUIT  ;Both must be defined

 S YSIEN=0 F  S YSIEN=$O(^YTT(601.71,YSIEN)) Q:+YSIEN=0  D

 . S YSOPER=$$GET1^DIQ(601.71,YSIEN_",",10,"I")

 . Q:(YSOPER'="Y")

 . S YSPRIV=$$GET1^DIQ(601.71,YSIEN_",",9,"I")

 . Q:YSPRIV'=""

 . K ARRAY

 . D GETS^DIQ(601.71,YSIEN_",","29;30","I","ARRAY")

 . K REC

 . I ARRAY(601.71,YSIEN_",",29,"I")'>0 S REC(29)=ALTNOTE

 . I ARRAY(601.71,YSIEN_",",30,"I")'>0 S REC(30)=ALTCSLT

 . I $D(REC) S REC(28)="Y"

 . Q:'$D(REC)

 . D FMSAVE^YTXCHGI(1,601.71,.REC,YSIEN)                 ; FMSAVE in case dry run

SCREEN ; line to put in DATA SCREEN of KIDS build

 ; $$INCLUDE^YTXCHG(Y,"TAG","RTN") calls TAG^RTN to get an array of

 ; instrument exchange entries to include in the build.  It sets Y

 ; to true if the entry should be included.

 I $$INCLUDE^YTXCHG(Y,"XCHGLST","YS250PST")

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)

ENTRIES ; New MHA instruments ^ Exchange Entry Date

 ;;YS*5.01*250 AAQ-II-7^07/22/2024@15:38:34

 ;;YS*5.01*250 ALSFRS-R^07/22/2024@15:39:05

 ;;YS*5.01*250 ALSSQOL-SF^07/24/2024@17:53:40

 ;;YS*5.01*250 AUDC^07/19/2024@11:27:45

 ;;YS*5.01*250 BOMC^07/19/2024@11:29:29

 ;;YS*5.01*250 BSS^07/19/2024@11:28:09

 ;;YS*5.01.250 PSS-3 2ND^07/19/2024@11:28:48

 ;;YS*5.01*250 YMRS^07/26/2024@10:12:27

 ;;zzzzz

 ;;YS*5.01*250 WHYMPI^07/19/2024@11:30

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS250PST   4546     printed  Apr 23, 2025@18:27:17                                                                                                                                                                                                    Page 2

YS250PST  ;BAL/KTL - Patch 250 Post-init ;June 25, 2024@13:55:37

 +1       ;;5.01;MENTAL HEALTH;**250**;Dec 30, 1994;Build 26

 +2       ;

 +3       ;

 +4       ; Reference to EN^XPAR in ICR #2263

 +5       ; Reference to GETLST^XPAR in ICR #2263

 +6       ; Reference to XLFSTR in ICR #10104

 +7       ; Reference to TIUFLF7 in ICR #5352

 +8        QUIT

 +9       ;

EDTDATE   ; date used to update 601.71:18

 +1       ;;3241009.2159

 +2        QUIT

 +3       ;

PRE       ; nothing necessary

 +1        QUIT

 +2       ;

POST      ; post-init

 +1        DO INSTALLQ^YTXCHG("XCHGLST","YS250PST")

 +2        DO SETCAT("AAQ-II-7","EBP")

 +3        DO SETCAT("ALSFRS-R","ADL/Func Status")

 +4        DO SETCAT("ALSFRS-R","Pain/Health")

 +5        DO SETCAT("ALSSQOL-SF","Quality of Life")

 +6        DO SETCAT("ALSSQOL-SF","Pain/Health")

 +7        DO REACTTST("BBHI-2")

 +8        DO UPDURL

 +9        DO FIXINST

 +10       QUIT

 +11      ;

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

 +12      ;

REACTTST(NAME) ; Change OPERATIONAL to YES

 +1        NEW IEN,REC

 +2        SET IEN=$ORDER(^YTT(601.71,"B",NAME,0))

 +3        IF +IEN'=0

               Begin DoDot:1

 +4                SET REC(10)="Y"

 +5                SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)

 +6                DO FMUPD^YTXCHGU(601.71,.REC,IEN)

               End DoDot:1

 +7        KILL REC,IEN

 +8        SET IEN=$ORDER(^YTT(601,"B",NAME,0))

 +9        IF 'IEN

               QUIT

 +10       SET REC(32)="N"

 +11       DO FMUPD^YTXCHGU(601,.REC,IEN)

 +12       QUIT

 +13      ;

UPDURL    ; Update GUI TOOLS URL for MHA Web

 +1       ;Z

 +2        NEW LIST,PARM,ERR,ENT,INST,VAL,TITL,CMD,SPEC,NEWVAL

 +3        KILL ^TMP($JOB,"XPAR")

 +4        SET LIST=$NAME(^TMP($JOB,"XPAR"))

 +5        SET PARM="ORWT TOOLS MENU"

 +6        DO ENVAL^XPAR(LIST,PARM,"",.ERR,1)

 +7        SET ^XTMP("YS250-TOOLS",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"MH Backup Tools Menu"

 +8        MERGE ^XTMP("YS250-TOOLS","XPAR")=^TMP($JOB,"XPAR")

 +9       ;In case URL entered home/? Patch 250

           SET SPEC("/home?")="/home/p250/?"

           SET SPEC("/home/?")="/home/p250/?"

 +10      ;Patch 250

           SET SPEC("/home/p249/?")="/home/p250/?"

 +11       SET ENT=""

FOR

               SET ENT=$ORDER(^TMP($JOB,"XPAR",ENT))

               if ENT=""

                   QUIT

               Begin DoDot:1

 +12               SET INST=0

FOR

                       SET INST=$ORDER(^TMP($JOB,"XPAR",ENT,INST))

                       if +INST=0

                           QUIT

                       Begin DoDot:2

 +13                       SET VAL=^TMP($JOB,"XPAR",ENT,INST)

 +14                       IF (VAL["mha.domain.ext/app/home?"!(VAL["mha.domain.ext/app/home/"))

                               Begin DoDot:3

 +15                               SET TITL=$PIECE(VAL,"=")

                                   SET CMD=$PIECE(VAL,"=",2,99)

 +16                               SET CMD=$$REPLACE^XLFSTR(CMD,.SPEC)

 +17                               SET NEWVAL=TITL_"="_CMD

 +18                               DO BMES^XPDUTL("Updating "_CMD_" for "_ENT)

 +19                               DO EN^XPAR(ENT,PARM,INST,NEWVAL,.ERR)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +20       KILL ^TMP($JOB,"XPAR")

 +21       QUIT

 +22      ;

FIXINST   ; Fix instrument note titles for sites that do not have

 +1       ; MENTAL HEALTH DIAGNOSTIC STUDY NOTE and MENTAL HEALTH CONSULT NOTE

 +2        NEW YSIEN,NOTE,CSLT,YSOPER,ARRAY,ALTNOTE,ALTCSLT,REC,YSPRIV

 +3        SET NOTE=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH DIAGNOSTIC STUDY NOTE","TL")

 +4        SET CSLT=+$$DDEFIEN^TIUFLF7("MENTAL HEALTH CONSULT NOTE","TL")

 +5       ;Only fix if both note titles are not available

           IF NOTE'=0!(CSLT'=0)

               QUIT

 +6        SET ALTNOTE=+$$DDEFIEN^TIUFLF7("MH DIAGNOSTIC STUDY NOTE","TL")

 +7        SET ALTCSLT=+$$DDEFIEN^TIUFLF7("MH CONSULT NOTE","TL")

 +8       ;Both must be defined

           IF 'ALTNOTE!'ALTCSLT

               QUIT

 +9        SET YSIEN=0

FOR

               SET YSIEN=$ORDER(^YTT(601.71,YSIEN))

               if +YSIEN=0

                   QUIT

               Begin DoDot:1

 +10               SET YSOPER=$$GET1^DIQ(601.71,YSIEN_",",10,"I")

 +11               if (YSOPER'="Y")

                       QUIT

 +12               SET YSPRIV=$$GET1^DIQ(601.71,YSIEN_",",9,"I")

 +13               if YSPRIV'=""

                       QUIT

 +14               KILL ARRAY

 +15               DO GETS^DIQ(601.71,YSIEN_",","29;30","I","ARRAY")

 +16               KILL REC

 +17               IF ARRAY(601.71,YSIEN_",",29,"I")'>0

                       SET REC(29)=ALTNOTE

 +18               IF ARRAY(601.71,YSIEN_",",30,"I")'>0

                       SET REC(30)=ALTCSLT

 +19               IF $DATA(REC)

                       SET REC(28)="Y"

 +20               if '$DATA(REC)

                       QUIT

 +21      ; FMSAVE in case dry run

                   DO FMSAVE^YTXCHGI(1,601.71,.REC,YSIEN)

               End DoDot:1

 +22       QUIT

SCREEN    ; line to put in DATA SCREEN of KIDS build

 +1       ; $$INCLUDE^YTXCHG(Y,"TAG","RTN") calls TAG^RTN to get an array of

 +2       ; instrument exchange entries to include in the build.  It sets Y

 +3       ; to true if the entry should be included.

 +4       ;

 +5        IF $$INCLUDE^YTXCHG(Y,"XCHGLST","YS250PST")

 +6        QUIT

 +7       ;

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

 +9       ;

ENTRIES   ; New MHA instruments ^ Exchange Entry Date

 +1       ;;YS*5.01*250 AAQ-II-7^07/22/2024@15:38:34

 +2       ;;YS*5.01*250 ALSFRS-R^07/22/2024@15:39:05

 +3       ;;YS*5.01*250 ALSSQOL-SF^07/24/2024@17:53:40

 +4       ;;YS*5.01*250 AUDC^07/19/2024@11:27:45

 +5       ;;YS*5.01*250 BOMC^07/19/2024@11:29:29

 +6       ;;YS*5.01*250 BSS^07/19/2024@11:28:09

 +7       ;;YS*5.01.250 PSS-3 2ND^07/19/2024@11:28:48

 +8       ;;YS*5.01*250 YMRS^07/26/2024@10:12:27

 +9       ;;zzzzz

 +10      ;

 +11       QUIT

 +12      ;;YS*5.01*250 WHYMPI^07/19/2024@11:30

YS250PST.m