- YS224PST ;BAL/KTL - Patch 224 Post-init ; 10/03/2023
- ;;5.01;MENTAL HEALTH;**224**;Dec 30, 1994;Build 17
- ;
- ; Reference to EN^XPAR in ICR #2263
- ; Reference to GETLST^XPAR in ICR #2263
- ; Reference to XLFSTR in ICR #10104
- Q
- EDTDATE ; date used to update 601.71:18
- ;;3240405.2159
- Q
- PRE ; nothing necessary
- Q
- POST ; post-init
- D INSTALLQ^YTXCHG("XCHGLST","YS224PST")
- D SETCAT("SIP-AD-START_V2","Addiction-SUD")
- D SETCAT("SIP-AD-30_V2","Addiction-SUD")
- D DROPTST("SIP-AD-START")
- D DROPTST("SIP-AD-30")
- D DROPTST("SCL90R")
- D UPDURL
- Q
- ;
- RENAME(OLD,NEW) ; Rename Instrument
- S IEN=$O(^YTT(601.71,"B",OLD,0)) Q:'IEN ; old name not found
- S REC(.01)=NEW
- D FMUPD^YTXCHGU(601.71,.REC,IEN)
- 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
- ;
- INACT(OLD,NEW) ; INACTIVATE test left in Development - Change test name *AND* set OPERATIONAL to NO
- N REC,IEN
- S IEN=$O(^YTT(601.71,"B",OLD,0))
- I 'IEN QUIT ; already updated
- S REC(.01)=NEW
- S REC(10)="N"
- S REC(18)=$P($T(EDTDATE+1),";;",2)
- D FMUPD^YTXCHGU(601.71,.REC,IEN)
- K REC,IEN
- S IEN=$O(^YTT(601,"B",OLD,0))
- I 'IEN QUIT
- S REC(.01)=NEW
- S REC(32)="N"
- D FMUPD^YTXCHGU(601,.REC,IEN)
- Q
- DROPTST(NAME) ; Change OPERATIONAL to dropped
- N IEN,REC
- S IEN=$O(^YTT(601.71,"B",NAME,0))
- I +IEN'=0 D
- . S REC(10)="D"
- . 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)
- 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
- DELCAT(TEST,CATNM) ; remove category from test if it is there
- N CAT,DIK,DA
- 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
- S DA=$O(^YTT(601.71,TEST,10,"B",CAT,0)) Q:'DA
- S DA(1)=TEST
- S DIK="^YTT(601.71,"_TEST_",10,"
- D ^DIK
- 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
- ;
- 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","YS224PST")
- 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
- ;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("YS224-TOOLS",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"MH Backup Tools Menu"
- M ^XTMP("YS224-TOOLS","XPAR")=^TMP($J,"XPAR")
- S SPEC("/home?")="/home/p224/?",SPEC("/home/?")="/home/p224/?" ;In case URL entered home/? Patch 224
- S SPEC("/home/p239/?")="/home/p224/?" ;Patch 224
- 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
- ENTRIES ; New MHA instruments ^ Exchange Entry Date
- ;;YS*5.01*224 EDE-Q^10/03/2023@13:27:53
- ;;YS*5.01*224 MBMD^12/19/2023@13:42:18
- ;;YS*5.01*224 SIP-AD-30_V2^02/06/2024@13:55:46
- ;;YS*5.01*224 SIP-AD-START_V2^02/01/2024@14:37:06
- ;;zzzzz
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYS224PST 4461 printed Feb 18, 2025@23:39:02 Page 2
- YS224PST ;BAL/KTL - Patch 224 Post-init ; 10/03/2023
- +1 ;;5.01;MENTAL HEALTH;**224**;Dec 30, 1994;Build 17
- +2 ;
- +3 ; Reference to EN^XPAR in ICR #2263
- +4 ; Reference to GETLST^XPAR in ICR #2263
- +5 ; Reference to XLFSTR in ICR #10104
- +6 QUIT
- EDTDATE ; date used to update 601.71:18
- +1 ;;3240405.2159
- +2 QUIT
- PRE ; nothing necessary
- +1 QUIT
- POST ; post-init
- +1 DO INSTALLQ^YTXCHG("XCHGLST","YS224PST")
- +2 DO SETCAT("SIP-AD-START_V2","Addiction-SUD")
- +3 DO SETCAT("SIP-AD-30_V2","Addiction-SUD")
- +4 DO DROPTST("SIP-AD-START")
- +5 DO DROPTST("SIP-AD-30")
- +6 DO DROPTST("SCL90R")
- +7 DO UPDURL
- +8 QUIT
- +9 ;
- RENAME(OLD,NEW) ; Rename Instrument
- +1 ; old name not found
- SET IEN=$ORDER(^YTT(601.71,"B",OLD,0))
- if 'IEN
- QUIT
- +2 SET REC(.01)=NEW
- +3 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
- +4 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
- +6 ;
- INACT(OLD,NEW) ; INACTIVATE test left in Development - Change test name *AND* set OPERATIONAL to NO
- +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(10)="N"
- +6 SET REC(18)=$PIECE($TEXT(EDTDATE+1),";;",2)
- +7 DO FMUPD^YTXCHGU(601.71,.REC,IEN)
- +8 KILL REC,IEN
- +9 SET IEN=$ORDER(^YTT(601,"B",OLD,0))
- +10 IF 'IEN
- QUIT
- +11 SET REC(.01)=NEW
- +12 SET REC(32)="N"
- +13 DO FMUPD^YTXCHGU(601,.REC,IEN)
- +14 QUIT
- DROPTST(NAME) ; Change OPERATIONAL to dropped
- +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)="D"
- +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
- 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
- DELCAT(TEST,CATNM) ; remove category from test if it is there
- +1 NEW CAT,DIK,DA
- +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 SET DA=$ORDER(^YTT(601.71,TEST,10,"B",CAT,0))
- if 'DA
- QUIT
- +5 SET DA(1)=TEST
- +6 SET DIK="^YTT(601.71,"_TEST_",10,"
- +7 DO ^DIK
- +8 QUIT
- +9 ;
- 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 ;
- 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","YS224PST")
- +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
- 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("YS224-TOOLS",0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"MH Backup Tools Menu"
- +8 MERGE ^XTMP("YS224-TOOLS","XPAR")=^TMP($JOB,"XPAR")
- +9 ;In case URL entered home/? Patch 224
- SET SPEC("/home?")="/home/p224/?"
- SET SPEC("/home/?")="/home/p224/?"
- +10 ;Patch 224
- SET SPEC("/home/p239/?")="/home/p224/?"
- +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
- ENTRIES ; New MHA instruments ^ Exchange Entry Date
- +1 ;;YS*5.01*224 EDE-Q^10/03/2023@13:27:53
- +2 ;;YS*5.01*224 MBMD^12/19/2023@13:42:18
- +3 ;;YS*5.01*224 SIP-AD-30_V2^02/06/2024@13:55:46
- +4 ;;YS*5.01*224 SIP-AD-START_V2^02/01/2024@14:37:06
- +5 ;;zzzzz
- +6 ;
- +7 QUIT