BLRKIDS2 ; IHS/OIT/MKK - IHS Lab KIDS utilities, part 2 ; 20-May-2016 07:03 ; MKK
;;5.2;LR;**1035,1039**;Nov 1, 1997;Build 38
;
EEP ; EP - Ersatz EP
D EEP^BLRGMENU
Q
;
;
BOKAY(MSG,TAB) ; EP -- Write out Blank line, then "OKAY" message
; MSG = Message String
; TAB = Indent Amount
;
D BMES^XPDUTL($J("",+$G(TAB))_MSG_" OK.")
Q
;
;
ENVHEADR(CP,RPMSVER,RPMS) ; EP -- Environment Header
; CP = Patch Number to be installed
; RPMSVER = RPMS Version of Module (e.g.: for Lab, it's 5.2)
; RPMS = RPMS Module (i.e., LA, LR, etc.)
;
NEW STARS,STR,TIMESTR
S STARS=$TR($J("",IOM)," ","*")
;
S STR="@Checking@Environment@for@Patch@"
S STR=STR_CP_"@of@Version@"
S STR=STR_RPMSVER_"@of@"
S STR=STR_$TR(RPMS," ","@")_".@"
;
S TIMESTR=$TR($$CJ^XLFSTR("At "_$$UP^XLFSTR($$HTE^XLFDT($H,"5MPZ")),$L(STR))," ","@")
;
D ^XBCLS
W STARS,!
W $TR($$CJ^XLFSTR(STR,IOM)," @","* "),!
W $TR($$CJ^XLFSTR(TIMESTR,IOM)," @","* "),!
W STARS,!
Q
;
ENVIVARS(CP,BLRVERN) ; EP - Setup the Environment variables
; CP = Patch Number to be installed
; BLRVERN = Current Routine Name
;
S TODAY=$$DT^XLFDT
S WOTCNT=$$WOTCNT(BLRVERN)
S ROWSTARS=$TR($J("",65)," ","*") ; Row of asterisks
;
S ^XTMP(BLRVERN,0)=$$HTFM^XLFDT(+$H+90)_"^"_$$DT^XLFDT_"^IHS Lab Patch "_CPSTR
M ^XTMP(BLRVERN,TODAY,WOTCNT,"DUZ")=DUZ
S ^XTMP(BLRVERN,TODAY,WOTCNT,"BEGIN")=$$NOW^XLFDT
;
S XUMF=1
;
I $G(XPDNM)="" D SORRY(CP,"XPDNM not defined or 0.") Q "Q"
;
S RPMS=$P(XPDNM,"*",1) ; RPMS Module
S RPMSVER=$P(XPDNM,"*",2) ; RPMS Version
;
I +$G(DUZ)<1 D SORRY(CP,"DUZ UNDEFINED OR 0.") Q "Q"
I $$GET1^DIQ(200,DUZ,"NAME")="" D SORRY(CP,"Installer cannot be identified!") Q "Q"
;
S XPDNOQUE=1 ; No Queuing Allowed
;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0,XPDDIQ(X,"B")="NO"
;
S XPDABORT=0 ; KIDS install Flag
;
D HOME^%ZIS ; Reset/Initialize IO variables
D DTNOLF^DICRW ; Set DT variable without a Line Feed
;
Q "OK"
;
;
BLANK ; EP - Blank Line using XPDUTL
D MES^XPDUTL(" ")
Q
;
NLBLANK ; EP - Newline, then Blank Line using XPDUTL
D BMES^XPDUTL(" ")
Q
;
TABLINE(LINE,TAB) ; EP - Use XPDUTL to display line, tabbed over TAB spaces. Default 5 spaces.
S TAB=$G(TAB,5)
D MES^XPDUTL($J("",TAB)_LINE)
Q
;
NTABLINE(LINE,TAB) ; EP - Newline, then use XPDUTL to display line, tabbed over TAB spaces. Default 5 spaces.
S TAB=$G(TAB,5)
D BMES^XPDUTL($J("",TAB)_LINE)
Q
;
MESCNTR(STR) ; EP - Center a line and use XPDUTL to display it
D MES^XPDUTL($$CJ^XLFSTR(STR,IOM))
Q
;
NMESCNTR(STR) ; EP - Newline, then Center a line and use XPDUTL to display it
D MES^XPDUTL($$CJ^XLFSTR(STR,IOM))
Q
;
;
WOTCNT(BLRVERN) ; EP - Counter for ^XTMP
; BLRVERN = Current Routine Name
;
NEW CNT,TODAY
;
S TODAY=$$DT^XLFDT
;
S CNT=1+$G(^XTMP(BLRVERN,0,TODAY))
S ^XTMP(BLRVERN,0,TODAY)=CNT
Q $TR($J(CNT,3)," ","0")
;
;
NOSNAPS(QUIET) ; EP - Make certain TAKE SNAPSHOTS field in BLR MASTER CONTROL file is OFF
; QUIET = Boolean. If YES (1), then do NOT print any information.
; If NO (0), then do print information.
NEW CNT,DESC,FDA,IEN
;
S (CNT,IEN)=0
F S IEN=$O(^BLRSITE(IEN)) Q:IEN<1 D
. Q:+$$GET1^DIQ(9009029,IEN,"TAKE SNAPSHOTS","I")<1
. ;
. S CNT=CNT+1,CNT(IEN)=""
. K FDA
. S FDA(9009029,IEN_",",1)=0
. D FILE^DIE(,"FDA","ERRS")
;
Q:CNT<1 ; If no update, just return
Q:+$G(QUIET) ; If QUIET is true, just return
;
D BMES^XPDUTL("File 9009029 'TAKE SNAPSHOTS' Field Set to OFF for the following:")
S IEN=0
F S IEN=$O(CNT(IEN)) Q:IEN<1 D TABMENU^BLRKIDSU($$GET1^DIQ(9009029,IEN,.01),5)
D BMES^XPDUTL
Q
;
; Generic "Find RPMS Module's Version and (perhaps) Patch number"
; The MODULE variable MUST be the PREFIX name from the PACKAGE file (9.4).
NEEDIT(CP,MODULE,VERSION,PATCH,ERRARRAY) ; EP
; CP = Patch Number to be installed
; MODULE = RPMS Module (i.e., LA, LR, etc.)
; VERSION = RPMS Version of Module (e.g.: for Lab, it's 5.2)
; PATCH = Patch Number to Check
; ERRARRAY = Error Array. Pass by Reference.
;
NEW NAME ; NAME of PACKAGE
NEW PTR ; PoinTeR to PACKAGE file
NEW HEREYAGO,STR1,STR2 ; Scratch variables/arrays
NEW SYSVER,SYSPATCH ; System Version & System Patch variables
NEW NAMEVER,NAMESYS
;
D FIND^DIC(9.4,"",,,MODULE,,"C",,,"HEREYAGO")
S PTR=$G(HEREYAGO("DILIST",2,1))
S NAME=$G(HEREYAGO("DILIST",1,1))
;
S SYSVER=+$$VERSION^XPDUTL(MODULE) ; Get Current Version #
;
S NAMEVER=NAME_" "_VERSION,NAMESYS=NAME_" "_SYSVER
;
; If Current Version < Needed Version, write message and quit
I SYSVER<VERSION D Q
. S ERRARRAY(MODULE,NAME,VERSION)=SYSVER_"^VERSION"
. D:SYSVER>0 NEEDMSG("Need "_NAMEVER_" & "_NAMESYS_" found!")
. D:SYSVER<1 NEEDMSG("Need "_MODULE_" & "_MODULE_" Not Installed!")
;
; If System Version > Needed Version, write message and quit
I VERSION<SYSVER D OKAY^BLRKIDSU("Need "_NAMEVER_" & "_NAMESYS_" found.",5) Q
;
I $G(PATCH)="" D Q ; If no Patch check, write message and quit
. D OKAY^BLRKIDSU(NAMEVER_" found.",5)
;
S SYSPATCH=$$PATCH^XPDUTL(MODULE_"*"_VERSION_"*"_PATCH)
I SYSPATCH'=1 D Q
. S ERRARRAY(MODULE,NAME,VERSION)=$G(PATCH)_"^PATCH"
. D NEEDMSG(NAMEVER_" ("_MODULE_") & Patch "_PATCH_" WAS NOT installed!")
;
D OKAY^BLRKIDSU(NAMEVER_" Patch "_PATCH_" found.",5)
;
Q
;
PASSMESG(WOT) ; EP -- Splash message
; WOT = String to display
;
NEW CRTLINE,MAXIT,AROUND
;
F CRTLINE=1:1:20 W $J("",80),!
D EN^XBVIDEO("HOM")
S MAXIT="@"
F J=1:1:$L(WOT) S MAXIT=MAXIT_$E(WOT,J,J)_"@"
S AROUND=$TR($J("",8+$L(MAXIT))," ","@")
S MAXIT="@@!!"_$TR(MAXIT," ","@")_"!!@@"
;
W !!
W $TR($J("",IOM)," ","*"),!
W $TR($J("",IOM)," ","*"),!
W $TR($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
W $TR($$CJ^XLFSTR(MAXIT,IOM)," @","* "),!
W $TR($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
W $TR($J("",IOM)," ","*"),!
W $TR($J("",IOM)," ","*"),!
Q
;
NEEDMSG(MESSAGE) ; EP
; MESSAGE = String to display
;
NEW STR1,STR2
;
S STR1=MESSAGE
I $L(STR1)<58 D SORRY(CP,STR1) Q
;
S STR1=$P(MESSAGE,"&")_" &"
S STR2=$$TRIM^XLFSTR($P(MESSAGE,"&",2),"L"," ")
D SORRY(CP,STR1,,STR2)
Q
;
; Error Message routine.
SORRY(CP,MSG,MODE,MSG2) ; EP
; CP = Patch Number to be installed
; MSG = String to display
; MODE = Type of message. FATAL or WARNING.
; MSG2 = Additional Line of Message. (If Needed.)
;
NEW MESSAGE,ROWSTARS
;
S ROWSTARS=$TR($J("",65)," ","*") ; Row of asterisks
;
S MODE=$G(MODE,"FATAL")
;
I $G(MODE)="FATAL" D
. S MESSAGE="Install Aborting due to the following Systems Environment issue:"
. S XPDABORT=1 ; Fatal Error Flag Set
;
I $G(MODE)["NONFATAL" S MESSAGE="*** WARNING *** WARNING *** WARNING ***"
;
K DIFQ
;
; STR Array will be used to write to the screen, send E-Mail & Alert
NEW STR,LINECNT,MODESTR
S LINECNT=1
D ADDLINE(.LINECNT)
D ADDLINE(.LINECNT,ROWSTARS)
D ADDLINE(.LINECNT)
D ADDLINE(.LINECNT,"Site: "_$$LOC^XBFUNC,"YES")
D ADDLINE(.LINECNT)
D ADDLINE(.LINECNT,MESSAGE,"YES")
D ADDLINE(.LINECNT)
D BANNERL(.LINECNT,MSG)
D:$D(MSG2) BANNERL(.LINECNT,MSG2)
D ADDLINE(.LINECNT)
;
I $G(MODE)["NONFATAL" D ADDLINE(.LINECNT,MESSAGE,"YES")
;
I $G(MODE)="FATAL" D
. D ADDLINE(.LINECNT,"Please print/capture this screen and","YES")
. D ADDLINE(.LINECNT,"notify the Support Center at","YES")
. D ADDLINE(.LINECNT)
. D ADDLINE(.LINECNT,"1-888-830-7280.","YES")
. D ADDLINE(.LINECNT)
;
D ADDLINE(.LINECNT,ROWSTARS)
D ADDLINE(.LINECNT)
;
D BMES^XPDUTL(.STR)
;
I $G(DEBUG)="YES" Q
;
D MAILALMI^BLRUTIL3("IHS Lab Patch "_CP_" Install "_MODE_" Error",.STR,"Laboratory Patch "_CP)
Q
;
ADDLINE(LC,ASTR,CENTER) ; EP -- Add a line to the STR array; CENTER if requested
; LC = Line Counter. Pass by Reference.
; ASTR = String to Add to STR array
; CENTER = Boolean. If YES, then Center ASTR, else don't.
;
I $G(ASTR)="" S ASTR=" "
S STR(LC)=$S($G(CENTER)="YES":$$CJ^XLFSTR(ASTR,65),1:$G(ASTR))
S LC=LC+1
Q
;
BANNERL(LC,ASTR) ; EP -- Stores "Banner" Line in STR array
; LC = Line Counter. Pass by Reference.
; ASTR = String to Add to STR array
;
S STR(LC)=$$MKBANNRL(ASTR)
S LC=LC+1
Q
;
MKBANNRL(ASTR) ; EP - MaKe the BANNeR Line
; ASTR = String to Manipulate
;
NEW HALFLEN,J,RM,STRLEN,TMPSTR
;
S RM=65 ; Right Margin
;
S HALFLEN=(RM\2)-(($L(ASTR)+2)\2)
S TMPSTR=$TR($J("",HALFLEN)," ",">")
S TMPSTR=TMPSTR_" "_ASTR_" "
S STRLEN=$L(TMPSTR)
F J=STRLEN:1:(RM-1) S TMPSTR=TMPSTR_"<"
Q TMPSTR
;
SORRYEND(WOTERR,CP) ; EP -- ALL the errors detected during the environment check.
; WOTERR = Error Array. Pass by Reference.
; CP = Patch Number to be installed
;
NEW STR,MODULE,NAME,VERSION,PATCH,LINECNT,TMP
;
D SORRYHED
;
S (MODULE,NAME,VERSION)=""
F S MODULE=$O(WOTERR(MODULE)) Q:MODULE="" D
. F S NAME=$O(WOTERR(MODULE,NAME)) Q:NAME="" D
.. F S VERSION=$O(WOTERR(MODULE,NAME,VERSION)) Q:VERSION="" D ADDMESG
;
D SORRYFIN
;
D BMES^XPDUTL(.STR)
;
Q
;
SORRYHED ; EP -- "Header" of Final Fatal Message
S LINECNT=1
D ADDLINE(.LINECNT)
D ADDLINE(.LINECNT,ROWSTARS)
D ADDLINE(.LINECNT)
D ADDLINE(.LINECNT,"Systems Environment Error Detected","YES")
D ADDLINE(.LINECNT,"KIDS build will be deleted","YES")
D ADDLINE(.LINECNT)
D ADDLINE(.LINECNT,"Modules with Version or Patch errors","YES")
D ADDLINE(.LINECNT)
Q
;
ADDMESG ; EP
NEW WOT,WOTWRONG
;
D ADDLINE(.LINECNT,NAME_" ("_MODULE_")","YES")
;
S WOT=$G(WOTERR(MODULE,NAME,VERSION))
S TMP="Version:"_VERSION
S WOTWRONG=$P(WOT,"^",2)
;
I WOTWRONG="VERSION" D
. S TMP="Needed Version:"_VERSION
. S TMP=TMP_" Found Version:"_$P(WOT,"^")
;
I WOTWRONG="PATCH" D
. S TMP=TMP_" Needed Patch:"_$P(WOT,"^")
;
I WOTWRONG'="PATCH"&(WOTWRONG'="VERSION") D
. D ADDLINE(.LINECNT,TMP,"YES")
. S TMP=WOT
;
D ADDLINE(.LINECNT,TMP,"YES")
D ADDLINE(.LINECNT)
Q
;
SORRYFIN ; EP -- "Fin" of Final Fatal Message
D ADDLINE(.LINECNT,"Re-Installation will be necessary.","YES")
D ADDLINE(.LINECNT)
D ADDLINE(.LINECNT,"If assistance is needed, please call","YES")
D ADDLINE(.LINECNT,"1-888-830-7280.","YES")
D ADDLINE(.LINECNT)
D ADDLINE(.LINECNT,ROWSTARS)
D ADDLINE(.LINECNT)
Q
;
;
DEBUG(PATCH,ROUTINE) ; EP - Debug Environment/Backup/Post Install sections of ROUTINE
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PATCH,ROUTINE,U,XPARSYS,XQXFLG)
;
; ROUTINE **MUST** have the following line Labels:
; ENVICHEK - Environment Checking Section
; BACKUP - Backup Section
; POST - Post Install Section
;
S (CP,PATCHNUM)=$P(PATCH,"*",3)
S CPSTR=PATCH
S BLRVERN=ROUTINE
S DEBUG=1 ; ROUTINE must handle DEBUG = 1
S XPDNM=PATCH
S XPDENV=0
S ROWPLUS=$TR($J("",IOM)," ","+")
;
D ^XBCLS,PASSMESG^BLRKIDS2("DEBUG: ENVCHK Check")
;
D @("ENVICHEK^"_ROUTINE)
;
W !!,"DEBUG: ENVCHK^",ROUTINE," Completed."
W !!,ROWPLUS
D PRESSKEY^BLRGMENU
;
D ^XBCLS,PASSMESG^BLRKIDS2("DEBUG: BACKUP Check.")
D @("BACKUP^"_ROUTINE)
W !!,"DEBUG: BACKUP^",ROUTINE," Completed."
W !!,ROWPLUS
D PRESSKEY^BLRGMENU
;
D ^XBCLS,PASSMESG^BLRKIDS2("DEBUG: POST Check")
D @("POST^"_ROUTINE)
W !!,"DEBUG: POST^",ROUTINE," Completed."
W !!,ROWPLUS
D PRESSKEY^BLRGMENU
;
D ^XBCLS,PASSMESG^BLRKIDS2("DEBUG: COMPLETED")
D PRESSKEY^BLRGMENU
Q
;
ADDOPTS(TOMENU,OPTION,SYNONYM,TAB) ; EP - Add new OPTION to TOMENU with SYNONYM synonym
Q:$$DEONARDY(TOMENU,OPTION,SYNONYM)
;
; Add it
; S TAB=$J(" ",$G(TAB,5))
S TAB=$G(TAB,$J("",5)) ; IHS/MSC/MKK - LR*5.2*1039
S X="Adding '"_OPTION_"' option"
S:$D(SYNONYM) X=X_" with "_SYNONYM_" synonym"
S X=X_" to "_TOMENU_"."
D BMES^XPDUTL(X)
S X=$$ADD^XPDMENU(TOMENU,OPTION,SYNONYM)
; D:X=1 BMES^XPDUTL(TAB_"'"_OPTION_"' added to "_TOMENU_". OK.")
D:X=1 MES^XPDUTL(TAB_"'"_OPTION_"' added to "_TOMENU_". OK.") ; IHS/MSC/MKK - LR*5.2*1039
I X'=1 D
. ; D BMES^XPDUTL(TAB_"Error in adding '"_OPTION_"' option to "_TOMENU_".")
. D MES^XPDUTL(TAB_"Error in adding '"_OPTION_"' option to "_TOMENU_".") ; IHS/MSC/MKK - LR*5.2*1039
. D MES^XPDUTL(TAB_TAB_"Error Message: "_$$UP^XLFSTR($P(X,"^",2)))
;
; D MES^XPDUTL("") ; IHS/MSC/MKK - LR*5.2*1039
Q
;
DEONARDY(TOMENU,OPTION,SYNONYM) ; EP - Checks Options
; Returns 1 if TOMENU doesn't exist OR
; if OPTION doesn't exist OR
; if OPTION already on TOMENU with SYNONYM
;
NEW OPTIEN,SYNIEN,TOIEN
S TOIEN=$$LKOPT^XPDMENU(TOMENU)
Q:TOIEN<1 1 ; Return 1 if TOMENU doesn't exist
;
S OPTIEN=$$LKOPT^XPDMENU(OPTION)
Q:OPTIEN<1 1 ; Return 1 if OPTION doesn't exist
;
S SYNIEN=+$O(^DIC(19,TOIEN,10,"C",$G(SYNONYM),0))
; Q $S($G(^DIC(19,TOIEN,10,SYNIEN,0))=OPTIEN:1,1:0)
; Return 1 if SYNONYM already on option
Q $S(+$G(^DIC(19,TOIEN,10,SYNIEN,0))=OPTIEN:1,1:0) ; IHS/MSC/MKK - LR*5.2*1039
;
;
INACTOPT(SEED,OUTMSG,EXCPTION) ; EP - Inactivate/Activate options.
; If the OUTMSG variable is NOT NULL, then the the OUT^XPDMENU routine
; will put the string into the OUT OF ORDER MESSAGE field of the options.
;
; If the OUTMSG variable is NULL, then the OUT^XPDMENU routine will
; remove any text from the OUT OF ORDER field of the options.
;
NEW OPTION,SEEDLEN
;
S OPTION=SEED,SEEDLEN=$L(SEED)
F S OPTION=$O(^DIC(19,"B",OPTION)) Q:OPTION=""!($E(OPTION,1,SEEDLEN)'=SEED) D
. Q:OPTION=$G(EXCPTION) ; Exception: Do not modify this option.
. Q:$D(EXCPTION(OPTION)) ; If EXCPTION is an array, Do not modify if option is in the array.
. ;
. D OUT^XPDMENU(OPTION,$G(OUTMSG))
Q
BLRKIDS2 ; IHS/OIT/MKK - IHS Lab KIDS utilities, part 2 ; 20-May-2016 07:03 ; MKK
+1 ;;5.2;LR;**1035,1039**;Nov 1, 1997;Build 38
+2 ;
EEP ; EP - Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ;
BOKAY(MSG,TAB) ; EP -- Write out Blank line, then "OKAY" message
+1 ; MSG = Message String
+2 ; TAB = Indent Amount
+3 ;
+4 DO BMES^XPDUTL($JUSTIFY("",+$GET(TAB))_MSG_" OK.")
+5 QUIT
+6 ;
+7 ;
ENVHEADR(CP,RPMSVER,RPMS) ; EP -- Environment Header
+1 ; CP = Patch Number to be installed
+2 ; RPMSVER = RPMS Version of Module (e.g.: for Lab, it's 5.2)
+3 ; RPMS = RPMS Module (i.e., LA, LR, etc.)
+4 ;
+5 NEW STARS,STR,TIMESTR
+6 SET STARS=$TRANSLATE($JUSTIFY("",IOM)," ","*")
+7 ;
+8 SET STR="@Checking@Environment@for@Patch@"
+9 SET STR=STR_CP_"@of@Version@"
+10 SET STR=STR_RPMSVER_"@of@"
+11 SET STR=STR_$TRANSLATE(RPMS," ","@")_".@"
+12 ;
+13 SET TIMESTR=$TRANSLATE($$CJ^XLFSTR("At "_$$UP^XLFSTR($$HTE^XLFDT($HOROLOG,"5MPZ")),$LENGTH(STR))," ","@")
+14 ;
+15 DO ^XBCLS
+16 WRITE STARS,!
+17 WRITE $TRANSLATE($$CJ^XLFSTR(STR,IOM)," @","* "),!
+18 WRITE $TRANSLATE($$CJ^XLFSTR(TIMESTR,IOM)," @","* "),!
+19 WRITE STARS,!
+20 QUIT
+21 ;
ENVIVARS(CP,BLRVERN) ; EP - Setup the Environment variables
+1 ; CP = Patch Number to be installed
+2 ; BLRVERN = Current Routine Name
+3 ;
+4 SET TODAY=$$DT^XLFDT
+5 SET WOTCNT=$$WOTCNT(BLRVERN)
+6 ; Row of asterisks
SET ROWSTARS=$TRANSLATE($JUSTIFY("",65)," ","*")
+7 ;
+8 SET ^XTMP(BLRVERN,0)=$$HTFM^XLFDT(+$HOROLOG+90)_"^"_$$DT^XLFDT_"^IHS Lab Patch "_CPSTR
+9 MERGE ^XTMP(BLRVERN,TODAY,WOTCNT,"DUZ")=DUZ
+10 SET ^XTMP(BLRVERN,TODAY,WOTCNT,"BEGIN")=$$NOW^XLFDT
+11 ;
+12 SET XUMF=1
+13 ;
+14 IF $GET(XPDNM)=""
DO SORRY(CP,"XPDNM not defined or 0.")
QUIT "Q"
+15 ;
+16 ; RPMS Module
SET RPMS=$PIECE(XPDNM,"*",1)
+17 ; RPMS Version
SET RPMSVER=$PIECE(XPDNM,"*",2)
+18 ;
+19 IF +$GET(DUZ)<1
DO SORRY(CP,"DUZ UNDEFINED OR 0.")
QUIT "Q"
+20 IF $$GET1^DIQ(200,DUZ,"NAME")=""
DO SORRY(CP,"Installer cannot be identified!")
QUIT "Q"
+21 ;
+22 ; No Queuing Allowed
SET XPDNOQUE=1
+23 ;
+24 ; The following line prevents the "Disable Options..." and "Move
+25 ; Routines..." questions from being asked during the install.
+26 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
SET XPDDIQ(X,"B")="NO"
+27 ;
+28 ; KIDS install Flag
SET XPDABORT=0
+29 ;
+30 ; Reset/Initialize IO variables
DO HOME^%ZIS
+31 ; Set DT variable without a Line Feed
DO DTNOLF^DICRW
+32 ;
+33 QUIT "OK"
+34 ;
+35 ;
BLANK ; EP - Blank Line using XPDUTL
+1 DO MES^XPDUTL(" ")
+2 QUIT
+3 ;
NLBLANK ; EP - Newline, then Blank Line using XPDUTL
+1 DO BMES^XPDUTL(" ")
+2 QUIT
+3 ;
TABLINE(LINE,TAB) ; EP - Use XPDUTL to display line, tabbed over TAB spaces. Default 5 spaces.
+1 SET TAB=$GET(TAB,5)
+2 DO MES^XPDUTL($JUSTIFY("",TAB)_LINE)
+3 QUIT
+4 ;
NTABLINE(LINE,TAB) ; EP - Newline, then use XPDUTL to display line, tabbed over TAB spaces. Default 5 spaces.
+1 SET TAB=$GET(TAB,5)
+2 DO BMES^XPDUTL($JUSTIFY("",TAB)_LINE)
+3 QUIT
+4 ;
MESCNTR(STR) ; EP - Center a line and use XPDUTL to display it
+1 DO MES^XPDUTL($$CJ^XLFSTR(STR,IOM))
+2 QUIT
+3 ;
NMESCNTR(STR) ; EP - Newline, then Center a line and use XPDUTL to display it
+1 DO MES^XPDUTL($$CJ^XLFSTR(STR,IOM))
+2 QUIT
+3 ;
+4 ;
WOTCNT(BLRVERN) ; EP - Counter for ^XTMP
+1 ; BLRVERN = Current Routine Name
+2 ;
+3 NEW CNT,TODAY
+4 ;
+5 SET TODAY=$$DT^XLFDT
+6 ;
+7 SET CNT=1+$GET(^XTMP(BLRVERN,0,TODAY))
+8 SET ^XTMP(BLRVERN,0,TODAY)=CNT
+9 QUIT $TRANSLATE($JUSTIFY(CNT,3)," ","0")
+10 ;
+11 ;
NOSNAPS(QUIET) ; EP - Make certain TAKE SNAPSHOTS field in BLR MASTER CONTROL file is OFF
+1 ; QUIET = Boolean. If YES (1), then do NOT print any information.
+2 ; If NO (0), then do print information.
+3 NEW CNT,DESC,FDA,IEN
+4 ;
+5 SET (CNT,IEN)=0
+6 FOR
SET IEN=$ORDER(^BLRSITE(IEN))
IF IEN<1
QUIT
Begin DoDot:1
+7 IF +$$GET1^DIQ(9009029,IEN,"TAKE SNAPSHOTS","I")<1
QUIT
+8 ;
+9 SET CNT=CNT+1
SET CNT(IEN)=""
+10 KILL FDA
+11 SET FDA(9009029,IEN_",",1)=0
+12 DO FILE^DIE(,"FDA","ERRS")
End DoDot:1
+13 ;
+14 ; If no update, just return
IF CNT<1
QUIT
+15 ; If QUIET is true, just return
IF +$GET(QUIET)
QUIT
+16 ;
+17 DO BMES^XPDUTL("File 9009029 'TAKE SNAPSHOTS' Field Set to OFF for the following:")
+18 SET IEN=0
+19 FOR
SET IEN=$ORDER(CNT(IEN))
IF IEN<1
QUIT
DO TABMENU^BLRKIDSU($$GET1^DIQ(9009029,IEN,.01),5)
+20 DO BMES^XPDUTL
+21 QUIT
+22 ;
+23 ; Generic "Find RPMS Module's Version and (perhaps) Patch number"
+24 ; The MODULE variable MUST be the PREFIX name from the PACKAGE file (9.4).
NEEDIT(CP,MODULE,VERSION,PATCH,ERRARRAY) ; EP
+1 ; CP = Patch Number to be installed
+2 ; MODULE = RPMS Module (i.e., LA, LR, etc.)
+3 ; VERSION = RPMS Version of Module (e.g.: for Lab, it's 5.2)
+4 ; PATCH = Patch Number to Check
+5 ; ERRARRAY = Error Array. Pass by Reference.
+6 ;
+7 ; NAME of PACKAGE
NEW NAME
+8 ; PoinTeR to PACKAGE file
NEW PTR
+9 ; Scratch variables/arrays
NEW HEREYAGO,STR1,STR2
+10 ; System Version & System Patch variables
NEW SYSVER,SYSPATCH
+11 NEW NAMEVER,NAMESYS
+12 ;
+13 DO FIND^DIC(9.4,"",,,MODULE,,"C",,,"HEREYAGO")
+14 SET PTR=$GET(HEREYAGO("DILIST",2,1))
+15 SET NAME=$GET(HEREYAGO("DILIST",1,1))
+16 ;
+17 ; Get Current Version #
SET SYSVER=+$$VERSION^XPDUTL(MODULE)
+18 ;
+19 SET NAMEVER=NAME_" "_VERSION
SET NAMESYS=NAME_" "_SYSVER
+20 ;
+21 ; If Current Version < Needed Version, write message and quit
+22 IF SYSVER<VERSION
Begin DoDot:1
+23 SET ERRARRAY(MODULE,NAME,VERSION)=SYSVER_"^VERSION"
+24 IF SYSVER>0
DO NEEDMSG("Need "_NAMEVER_" & "_NAMESYS_" found!")
+25 IF SYSVER<1
DO NEEDMSG("Need "_MODULE_" & "_MODULE_" Not Installed!")
End DoDot:1
QUIT
+26 ;
+27 ; If System Version > Needed Version, write message and quit
+28 IF VERSION<SYSVER
DO OKAY^BLRKIDSU("Need "_NAMEVER_" & "_NAMESYS_" found.",5)
QUIT
+29 ;
+30 ; If no Patch check, write message and quit
IF $GET(PATCH)=""
Begin DoDot:1
+31 DO OKAY^BLRKIDSU(NAMEVER_" found.",5)
End DoDot:1
QUIT
+32 ;
+33 SET SYSPATCH=$$PATCH^XPDUTL(MODULE_"*"_VERSION_"*"_PATCH)
+34 IF SYSPATCH'=1
Begin DoDot:1
+35 SET ERRARRAY(MODULE,NAME,VERSION)=$GET(PATCH)_"^PATCH"
+36 DO NEEDMSG(NAMEVER_" ("_MODULE_") & Patch "_PATCH_" WAS NOT installed!")
End DoDot:1
QUIT
+37 ;
+38 DO OKAY^BLRKIDSU(NAMEVER_" Patch "_PATCH_" found.",5)
+39 ;
+40 QUIT
+41 ;
PASSMESG(WOT) ; EP -- Splash message
+1 ; WOT = String to display
+2 ;
+3 NEW CRTLINE,MAXIT,AROUND
+4 ;
+5 FOR CRTLINE=1:1:20
WRITE $JUSTIFY("",80),!
+6 DO EN^XBVIDEO("HOM")
+7 SET MAXIT="@"
+8 FOR J=1:1:$LENGTH(WOT)
SET MAXIT=MAXIT_$EXTRACT(WOT,J,J)_"@"
+9 SET AROUND=$TRANSLATE($JUSTIFY("",8+$LENGTH(MAXIT))," ","@")
+10 SET MAXIT="@@!!"_$TRANSLATE(MAXIT," ","@")_"!!@@"
+11 ;
+12 WRITE !!
+13 WRITE $TRANSLATE($JUSTIFY("",IOM)," ","*"),!
+14 WRITE $TRANSLATE($JUSTIFY("",IOM)," ","*"),!
+15 WRITE $TRANSLATE($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
+16 WRITE $TRANSLATE($$CJ^XLFSTR(MAXIT,IOM)," @","* "),!
+17 WRITE $TRANSLATE($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
+18 WRITE $TRANSLATE($JUSTIFY("",IOM)," ","*"),!
+19 WRITE $TRANSLATE($JUSTIFY("",IOM)," ","*"),!
+20 QUIT
+21 ;
NEEDMSG(MESSAGE) ; EP
+1 ; MESSAGE = String to display
+2 ;
+3 NEW STR1,STR2
+4 ;
+5 SET STR1=MESSAGE
+6 IF $LENGTH(STR1)<58
DO SORRY(CP,STR1)
QUIT
+7 ;
+8 SET STR1=$PIECE(MESSAGE,"&")_" &"
+9 SET STR2=$$TRIM^XLFSTR($PIECE(MESSAGE,"&",2),"L"," ")
+10 DO SORRY(CP,STR1,,STR2)
+11 QUIT
+12 ;
+13 ; Error Message routine.
SORRY(CP,MSG,MODE,MSG2) ; EP
+1 ; CP = Patch Number to be installed
+2 ; MSG = String to display
+3 ; MODE = Type of message. FATAL or WARNING.
+4 ; MSG2 = Additional Line of Message. (If Needed.)
+5 ;
+6 NEW MESSAGE,ROWSTARS
+7 ;
+8 ; Row of asterisks
SET ROWSTARS=$TRANSLATE($JUSTIFY("",65)," ","*")
+9 ;
+10 SET MODE=$GET(MODE,"FATAL")
+11 ;
+12 IF $GET(MODE)="FATAL"
Begin DoDot:1
+13 SET MESSAGE="Install Aborting due to the following Systems Environment issue:"
+14 ; Fatal Error Flag Set
SET XPDABORT=1
End DoDot:1
+15 ;
+16 IF $GET(MODE)["NONFATAL"
SET MESSAGE="*** WARNING *** WARNING *** WARNING ***"
+17 ;
+18 KILL DIFQ
+19 ;
+20 ; STR Array will be used to write to the screen, send E-Mail & Alert
+21 NEW STR,LINECNT,MODESTR
+22 SET LINECNT=1
+23 DO ADDLINE(.LINECNT)
+24 DO ADDLINE(.LINECNT,ROWSTARS)
+25 DO ADDLINE(.LINECNT)
+26 DO ADDLINE(.LINECNT,"Site: "_$$LOC^XBFUNC,"YES")
+27 DO ADDLINE(.LINECNT)
+28 DO ADDLINE(.LINECNT,MESSAGE,"YES")
+29 DO ADDLINE(.LINECNT)
+30 DO BANNERL(.LINECNT,MSG)
+31 IF $DATA(MSG2)
DO BANNERL(.LINECNT,MSG2)
+32 DO ADDLINE(.LINECNT)
+33 ;
+34 IF $GET(MODE)["NONFATAL"
DO ADDLINE(.LINECNT,MESSAGE,"YES")
+35 ;
+36 IF $GET(MODE)="FATAL"
Begin DoDot:1
+37 DO ADDLINE(.LINECNT,"Please print/capture this screen and","YES")
+38 DO ADDLINE(.LINECNT,"notify the Support Center at","YES")
+39 DO ADDLINE(.LINECNT)
+40 DO ADDLINE(.LINECNT,"1-888-830-7280.","YES")
+41 DO ADDLINE(.LINECNT)
End DoDot:1
+42 ;
+43 DO ADDLINE(.LINECNT,ROWSTARS)
+44 DO ADDLINE(.LINECNT)
+45 ;
+46 DO BMES^XPDUTL(.STR)
+47 ;
+48 IF $GET(DEBUG)="YES"
QUIT
+49 ;
+50 DO MAILALMI^BLRUTIL3("IHS Lab Patch "_CP_" Install "_MODE_" Error",.STR,"Laboratory Patch "_CP)
+51 QUIT
+52 ;
ADDLINE(LC,ASTR,CENTER) ; EP -- Add a line to the STR array; CENTER if requested
+1 ; LC = Line Counter. Pass by Reference.
+2 ; ASTR = String to Add to STR array
+3 ; CENTER = Boolean. If YES, then Center ASTR, else don't.
+4 ;
+5 IF $GET(ASTR)=""
SET ASTR=" "
+6 SET STR(LC)=$SELECT($GET(CENTER)="YES":$$CJ^XLFSTR(ASTR,65),1:$GET(ASTR))
+7 SET LC=LC+1
+8 QUIT
+9 ;
BANNERL(LC,ASTR) ; EP -- Stores "Banner" Line in STR array
+1 ; LC = Line Counter. Pass by Reference.
+2 ; ASTR = String to Add to STR array
+3 ;
+4 SET STR(LC)=$$MKBANNRL(ASTR)
+5 SET LC=LC+1
+6 QUIT
+7 ;
MKBANNRL(ASTR) ; EP - MaKe the BANNeR Line
+1 ; ASTR = String to Manipulate
+2 ;
+3 NEW HALFLEN,J,RM,STRLEN,TMPSTR
+4 ;
+5 ; Right Margin
SET RM=65
+6 ;
+7 SET HALFLEN=(RM\2)-(($LENGTH(ASTR)+2)\2)
+8 SET TMPSTR=$TRANSLATE($JUSTIFY("",HALFLEN)," ",">")
+9 SET TMPSTR=TMPSTR_" "_ASTR_" "
+10 SET STRLEN=$LENGTH(TMPSTR)
+11 FOR J=STRLEN:1:(RM-1)
SET TMPSTR=TMPSTR_"<"
+12 QUIT TMPSTR
+13 ;
SORRYEND(WOTERR,CP) ; EP -- ALL the errors detected during the environment check.
+1 ; WOTERR = Error Array. Pass by Reference.
+2 ; CP = Patch Number to be installed
+3 ;
+4 NEW STR,MODULE,NAME,VERSION,PATCH,LINECNT,TMP
+5 ;
+6 DO SORRYHED
+7 ;
+8 SET (MODULE,NAME,VERSION)=""
+9 FOR
SET MODULE=$ORDER(WOTERR(MODULE))
IF MODULE=""
QUIT
Begin DoDot:1
+10 FOR
SET NAME=$ORDER(WOTERR(MODULE,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+11 FOR
SET VERSION=$ORDER(WOTERR(MODULE,NAME,VERSION))
IF VERSION=""
QUIT
DO ADDMESG
End DoDot:2
End DoDot:1
+12 ;
+13 DO SORRYFIN
+14 ;
+15 DO BMES^XPDUTL(.STR)
+16 ;
+17 QUIT
+18 ;
SORRYHED ; EP -- "Header" of Final Fatal Message
+1 SET LINECNT=1
+2 DO ADDLINE(.LINECNT)
+3 DO ADDLINE(.LINECNT,ROWSTARS)
+4 DO ADDLINE(.LINECNT)
+5 DO ADDLINE(.LINECNT,"Systems Environment Error Detected","YES")
+6 DO ADDLINE(.LINECNT,"KIDS build will be deleted","YES")
+7 DO ADDLINE(.LINECNT)
+8 DO ADDLINE(.LINECNT,"Modules with Version or Patch errors","YES")
+9 DO ADDLINE(.LINECNT)
+10 QUIT
+11 ;
ADDMESG ; EP
+1 NEW WOT,WOTWRONG
+2 ;
+3 DO ADDLINE(.LINECNT,NAME_" ("_MODULE_")","YES")
+4 ;
+5 SET WOT=$GET(WOTERR(MODULE,NAME,VERSION))
+6 SET TMP="Version:"_VERSION
+7 SET WOTWRONG=$PIECE(WOT,"^",2)
+8 ;
+9 IF WOTWRONG="VERSION"
Begin DoDot:1
+10 SET TMP="Needed Version:"_VERSION
+11 SET TMP=TMP_" Found Version:"_$PIECE(WOT,"^")
End DoDot:1
+12 ;
+13 IF WOTWRONG="PATCH"
Begin DoDot:1
+14 SET TMP=TMP_" Needed Patch:"_$PIECE(WOT,"^")
End DoDot:1
+15 ;
+16 IF WOTWRONG'="PATCH"&(WOTWRONG'="VERSION")
Begin DoDot:1
+17 DO ADDLINE(.LINECNT,TMP,"YES")
+18 SET TMP=WOT
End DoDot:1
+19 ;
+20 DO ADDLINE(.LINECNT,TMP,"YES")
+21 DO ADDLINE(.LINECNT)
+22 QUIT
+23 ;
SORRYFIN ; EP -- "Fin" of Final Fatal Message
+1 DO ADDLINE(.LINECNT,"Re-Installation will be necessary.","YES")
+2 DO ADDLINE(.LINECNT)
+3 DO ADDLINE(.LINECNT,"If assistance is needed, please call","YES")
+4 DO ADDLINE(.LINECNT,"1-888-830-7280.","YES")
+5 DO ADDLINE(.LINECNT)
+6 DO ADDLINE(.LINECNT,ROWSTARS)
+7 DO ADDLINE(.LINECNT)
+8 QUIT
+9 ;
+10 ;
DEBUG(PATCH,ROUTINE) ; EP - Debug Environment/Backup/Post Install sections of ROUTINE
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PATCH,ROUTINE,U,XPARSYS,XQXFLG)
+2 ;
+3 ; ROUTINE **MUST** have the following line Labels:
+4 ; ENVICHEK - Environment Checking Section
+5 ; BACKUP - Backup Section
+6 ; POST - Post Install Section
+7 ;
+8 SET (CP,PATCHNUM)=$PIECE(PATCH,"*",3)
+9 SET CPSTR=PATCH
+10 SET BLRVERN=ROUTINE
+11 ; ROUTINE must handle DEBUG = 1
SET DEBUG=1
+12 SET XPDNM=PATCH
+13 SET XPDENV=0
+14 SET ROWPLUS=$TRANSLATE($JUSTIFY("",IOM)," ","+")
+15 ;
+16 DO ^XBCLS
DO PASSMESG^BLRKIDS2("DEBUG: ENVCHK Check")
+17 ;
+18 DO @("ENVICHEK^"_ROUTINE)
+19 ;
+20 WRITE !!,"DEBUG: ENVCHK^",ROUTINE," Completed."
+21 WRITE !!,ROWPLUS
+22 DO PRESSKEY^BLRGMENU
+23 ;
+24 DO ^XBCLS
DO PASSMESG^BLRKIDS2("DEBUG: BACKUP Check.")
+25 DO @("BACKUP^"_ROUTINE)
+26 WRITE !!,"DEBUG: BACKUP^",ROUTINE," Completed."
+27 WRITE !!,ROWPLUS
+28 DO PRESSKEY^BLRGMENU
+29 ;
+30 DO ^XBCLS
DO PASSMESG^BLRKIDS2("DEBUG: POST Check")
+31 DO @("POST^"_ROUTINE)
+32 WRITE !!,"DEBUG: POST^",ROUTINE," Completed."
+33 WRITE !!,ROWPLUS
+34 DO PRESSKEY^BLRGMENU
+35 ;
+36 DO ^XBCLS
DO PASSMESG^BLRKIDS2("DEBUG: COMPLETED")
+37 DO PRESSKEY^BLRGMENU
+38 QUIT
+39 ;
ADDOPTS(TOMENU,OPTION,SYNONYM,TAB) ; EP - Add new OPTION to TOMENU with SYNONYM synonym
+1 IF $$DEONARDY(TOMENU,OPTION,SYNONYM)
QUIT
+2 ;
+3 ; Add it
+4 ; S TAB=$J(" ",$G(TAB,5))
+5 ; IHS/MSC/MKK - LR*5.2*1039
SET TAB=$GET(TAB,$JUSTIFY("",5))
+6 SET X="Adding '"_OPTION_"' option"
+7 IF $DATA(SYNONYM)
SET X=X_" with "_SYNONYM_" synonym"
+8 SET X=X_" to "_TOMENU_"."
+9 DO BMES^XPDUTL(X)
+10 SET X=$$ADD^XPDMENU(TOMENU,OPTION,SYNONYM)
+11 ; D:X=1 BMES^XPDUTL(TAB_"'"_OPTION_"' added to "_TOMENU_". OK.")
+12 ; IHS/MSC/MKK - LR*5.2*1039
IF X=1
DO MES^XPDUTL(TAB_"'"_OPTION_"' added to "_TOMENU_". OK.")
+13 IF X'=1
Begin DoDot:1
+14 ; D BMES^XPDUTL(TAB_"Error in adding '"_OPTION_"' option to "_TOMENU_".")
+15 ; IHS/MSC/MKK - LR*5.2*1039
DO MES^XPDUTL(TAB_"Error in adding '"_OPTION_"' option to "_TOMENU_".")
+16 DO MES^XPDUTL(TAB_TAB_"Error Message: "_$$UP^XLFSTR($PIECE(X,"^",2)))
End DoDot:1
+17 ;
+18 ; D MES^XPDUTL("") ; IHS/MSC/MKK - LR*5.2*1039
+19 QUIT
+20 ;
DEONARDY(TOMENU,OPTION,SYNONYM) ; EP - Checks Options
+1 ; Returns 1 if TOMENU doesn't exist OR
+2 ; if OPTION doesn't exist OR
+3 ; if OPTION already on TOMENU with SYNONYM
+4 ;
+5 NEW OPTIEN,SYNIEN,TOIEN
+6 SET TOIEN=$$LKOPT^XPDMENU(TOMENU)
+7 ; Return 1 if TOMENU doesn't exist
IF TOIEN<1
QUIT 1
+8 ;
+9 SET OPTIEN=$$LKOPT^XPDMENU(OPTION)
+10 ; Return 1 if OPTION doesn't exist
IF OPTIEN<1
QUIT 1
+11 ;
+12 SET SYNIEN=+$ORDER(^DIC(19,TOIEN,10,"C",$GET(SYNONYM),0))
+13 ; Q $S($G(^DIC(19,TOIEN,10,SYNIEN,0))=OPTIEN:1,1:0)
+14 ; Return 1 if SYNONYM already on option
+15 ; IHS/MSC/MKK - LR*5.2*1039
QUIT $SELECT(+$GET(^DIC(19,TOIEN,10,SYNIEN,0))=OPTIEN:1,1:0)
+16 ;
+17 ;
INACTOPT(SEED,OUTMSG,EXCPTION) ; EP - Inactivate/Activate options.
+1 ; If the OUTMSG variable is NOT NULL, then the the OUT^XPDMENU routine
+2 ; will put the string into the OUT OF ORDER MESSAGE field of the options.
+3 ;
+4 ; If the OUTMSG variable is NULL, then the OUT^XPDMENU routine will
+5 ; remove any text from the OUT OF ORDER field of the options.
+6 ;
+7 NEW OPTION,SEEDLEN
+8 ;
+9 SET OPTION=SEED
SET SEEDLEN=$LENGTH(SEED)
+10 FOR
SET OPTION=$ORDER(^DIC(19,"B",OPTION))
IF OPTION=""!($EXTRACT(OPTION,1,SEEDLEN)'=SEED)
QUIT
Begin DoDot:1
+11 ; Exception: Do not modify this option.
IF OPTION=$GET(EXCPTION)
QUIT
+12 ; If EXCPTION is an array, Do not modify if option is in the array.
IF $DATA(EXCPTION(OPTION))
QUIT
+13 ;
+14 DO OUT^XPDMENU(OPTION,$GET(OUTMSG))
End DoDot:1
+15 QUIT
