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

BLRPRE31.m

Go to the documentation of this file. 
  1. BLRPRE31 ; IHS/MSC/MKK - IHS Lab Patch 1031 Pre/Post/Environment Routine ;   [ February 29, 2012 8:00 AM ]
  1.  ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997
  1.  ;
  1. PRE ; EP
  1.  NEW CP,PREREQ,RPMS,RPMSVER,QFLG,ROWSTARS,STR
  1.  NEW ERRARRAY                 ; Errors array
  1.  ;
  1.  S XUMF=1
  1.  ;
  1.  I $G(XPDNM)="" D  Q
  1.  . S CP=$TR($P($T(+2),";",5),"*")
  1.  . D SORRY(CP,"XPDNM not defined or 0.")
  1.  ;
  1.  S CP=$P(XPDNM,"*",3)        ; Patch Number
  1.  S RPMS=$P(XPDNM,"*",1)      ; RPMS Module
  1.  S RPMSVER=$P(XPDNM,"*",2)   ; RPMS Version
  1.  ;
  1.  S ROWSTARS=$TR($J("",65)," ","*")     ; Row of asterisks
  1.  ;
  1. USERID ; EP - CHECK FOR USER ID
  1.  I +$G(DUZ)<1 D SORRY(CP,"DUZ UNDEFINED OR 0.")  Q
  1.  ;
  1.  I $P($G(^VA(200,DUZ,0)),U)="" D SORRY(CP,"Installer cannot be identified!")  Q
  1.  ;
  1. GETREADY ; EP
  1.  S XPDNOQUE=1           ; No Queuing Allowed
  1.  ;
  1.  ; The following line prevents the "Disable Options..." and "Move
  1.  ; Routines..." questions from being asked during the install.
  1.  F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0,XPDDIQ(X,"B")="NO"
  1.  ;
  1.  S XPDABORT=0           ; KIDS install Flag
  1.  ;
  1.  D HOME^%ZIS            ; Reset/Initialize IO variables
  1.  D DTNOLF^DICRW         ; Set DT variable without a Line Feed
  1.  ;
  1. ENVICHEK ; Environment Checker
  1.  D ENVHEADR(CP,RPMSVER,RPMS)
  1.  ;
  1.  D CHKMAILG(CP,"LMI",.ERRARRAY)              ; Check for LMI Mail Group
  1.  D CHKMAILG(CP,"LAB MESSAGING",.ERRARRAY)    ; Check for LAB MESSAGING Mail Group
  1.  ;
  1.  ; Sites are skipping Patch 1028 and installing 1029 then 1030.  1029 doesn't
  1.  ; look for 1028, so they can get away with doing that.
  1.  F Y=1028:1:1030 D NEEDIT(CP,"LR","5.2",Y,.ERRARRAY)    ; Lab Pre-Requisites
  1.  D MES^XPDUTL("")
  1.  ;
  1.  D NEEDIT(CP,"USR","1.0",25,.ERRARRAY)       ; USR*1.0*25 (AUTHORIZATION/SUBSCRIPTION)
  1.  ;
  1.  I $$VER^LR7OU1>2.5 D                        ; Only OERR 3.0 & up
  1.  . D NEEDIT(CP,"OR","3.0",141,.ERRARRAY)     ; OR*3.0*141 (ORDER ENTRY/RESULTS REPORTING)
  1.  ;
  1.  D NEEDIT(CP,"DI","22.0",149,.ERRARRAY)      ; DI*22.0*149 (VA FILEMAN)
  1.  ;
  1.  I XPDABORT>0 D SORRYEND(.ERRARRAY,CP)   Q   ; ENVIRONMENT HAS ERROR(S)
  1.  ;
  1.  D BOKAY("ENVIRONMENT")
  1.  ;
  1.  S XUMF=1
  1.  ;
  1.  Q
  1.  ;
  1. POST ; EP -- POST INSTALL
  1.  NEW CHKIT,CP,STR,TAB
  1.  ;
  1.  S CP=$P($T(+2),"*",3)  ; Current Patch
  1.  ;
  1.  ; Clear ^XTMP.
  1.  K ^XTMP("BLRLINKU")
  1.  ;
  1.  ; D BMES^XPDUTL("Adding BLRAUTOM to LR DO!.")
  1.  S CHKIT=$$DELETE^XPDMENU("LR DO!","BLRAUTOM")
  1.  ; I CHKIT=1 D OKAY^BLRKIDSU("BLRAUTOM added to LRD DO!.",5)
  1.  ; I CHKIT'=1 D TABMESG^BLRKIDSU("BLRAUTOM NOT added to LRD DO!.",5)
  1.  ; D MES^XPDUTL(" ")
  1.  ;
  1.  D BMES^XPDUTL("Running Post-Install BLR138PO Routine.")
  1.  D EN^BLR138PO          ; Fix for VA Patch LR*5.2*138 mistake
  1.  ;
  1.  D ENDINSTL(CP)
  1.  ;
  1.  D BMES^XPDUTL("Laboratory Patch "_CP_" INSTALL complete.")
  1.  ;
  1.  D SNDALERT("Laboratory Patch "_CP_" INSTALL complete.")
  1.  ;
  1.  S STR(1)=" "
  1.  S STR(2)=$J("",10)_"POST INSTALL of BLRPRE31 Routine."
  1.  S STR(3)=" "
  1.  S STR(4)=$J("",15)_"Laboratory Patch "_CP_" INSTALL completed."
  1.  S STR(5)=" "
  1.  D SENDMAIL("Laboratory Patch "_CP_" INSTALL complete.")
  1.  ;
  1.  Q
  1.  ;
  1. DEBUG ; EP - Debugging Line Label for environment checker
  1.  NEW CP,DEBUG,RPMS,RPMSVER,QFLG,STR
  1.  W !!
  1.  W "Debug BLRPRE31.",!!
  1.  ;
  1.  ; Note -- DEBUG is a negative flag:
  1.  ;         YES="Don't Send Alerts"; NO="Send Alerts"
  1.  S DEBUG="YES"
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("B")="NO"
  1.  S DIR("A")="Send Alerts/E-Mails"
  1.  D ^DIR
  1.  S:+$G(Y)=1 DEBUG="NO"
  1.  ;
  1.  ; No matter what, set the DEBUG flag
  1.  S:$L($G(DEBUG))<1 DEBUG="YES"
  1.  ;
  1.  W !
  1.  S XPDNM="LR*5.2*1031"
  1.  S XPDENV=0
  1.  ;
  1.  D PREINS
  1.  D PRESSKEY^BLRGMENU(4)
  1.  ;
  1.  D PRE
  1.  W !!!
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="YO"
  1.  S DIR("B")="NO"
  1.  S DIR("A")="Test Post Install Code"
  1.  D ^DIR
  1.  ;
  1.  D:+$G(Y)=1 POST
  1.  W !!!
  1.  ;
  1.  Q
  1.  ;
  1. PRESSKEY(TAB,MSGSTR)                          ; EP
  1.  NEW TABSTR
  1.  S TABSTR=$J("",+$G(TAB))_$S(+$L($G(MSGSTR)):$G(MSGSTR),1:"Press RETURN Key")
  1.  ;
  1.  W !
  1.  D ^XBFMK
  1.  S DIR(0)="E"
  1.  S DIR("A")=TABSTR
  1.  D ^DIR
  1.  I $G(DUOUT) S QFLG="Q"      ; If Fileman quit, then set Quit Flag
  1.  ;
  1.  Q
  1.  ;
  1. ENVHEADR(CP,RPMSVER,RPMS) ; EP -- Environment Header
  1.  NEW STARS,STR,TIMESTR
  1.  S STARS=$TR($J("",IOM)," ","*")
  1.  ;
  1.  S STR="@Checking@Environment@for@Patch@"
  1.  S STR=STR_CP_"@of@Version@"
  1.  S STR=STR_RPMSVER_"@of@"
  1.  S STR=STR_$TR(RPMS," ","@")_".@"
  1.  ;
  1.  S TIMESTR=$TR($$CJ^XLFSTR("At "_$$UP^XLFSTR($$HTE^XLFDT($H,"5MPZ")),$L(STR))," ","@")
  1.  ;
  1.  D ^XBCLS
  1.  W STARS,!
  1.  W $TR($$CJ^XLFSTR(STR,IOM)," @","* "),!
  1.  W $TR($$CJ^XLFSTR(TIMESTR,IOM)," @","* "),!
  1.  W STARS,!
  1.  Q
  1.  ;
  1. BOKAY(MSG,TAB)       ; EP -- Write out Blank line, then "OKAY" message
  1.  D BMES^XPDUTL($J("",+$G(TAB))_MSG_" OK.")
  1.  Q
  1.  ;
  1. ENDINSTL(CURPATCH)       ; EP
  1.  NEW INSTCNT                        ; Installation count
  1.  ;
  1.  S INSTCNT=1+$O(^BLRINSTL("LAB PATCH",CURPATCH,"INSTALLED BY",""),-1)
  1.  ;
  1.  S ^BLRINSTL("LAB PATCH",CURPATCH,"INSTALLED BY",INSTCNT)=$P($G(^VA(200,DUZ,0)),U)
  1.  S ^BLRINSTL("LAB PATCH",CURPATCH,"INSTALLED BY",INSTCNT,"DATE/TIME")=$$HTE^XLFDT($H,"5Z")
  1.  Q
  1.  ;
  1.  ; Error Message routine.
  1. SORRY(CP,MSG,MODE,MSG2)    ; EP
  1.  NEW MESSAGE,ROWSTARS
  1.  ;
  1.  S ROWSTARS=$TR($J("",65)," ","*")     ; Row of asterisks
  1.  ;
  1.  S MODE=$G(MODE,"FATAL")
  1.  ;
  1.  I $G(MODE)="FATAL" D
  1.  . S MESSAGE="Install Aborting due to the following Systems Environment issue:"
  1.  . S XPDABORT=1    ; Fatal Error Flag Set
  1.  ;
  1.  I $G(MODE)["NONFATAL" S MESSAGE="*** WARNING *** WARNING *** WARNING ***"
  1.  ;
  1.  K DIFQ
  1.  ;
  1.  ; STR Array will be used to write to the screen, send E-Mail & Alert
  1.  NEW STR,LINECNT,MODESTR
  1.  S LINECNT=1
  1.  D ADDLINE(.LINECNT)
  1.  D ADDLINE(.LINECNT,ROWSTARS)
  1.  D ADDLINE(.LINECNT)
  1.  D ADDLINE(.LINECNT,"Site: "_$$LOC^XBFUNC,"YES")
  1.  D ADDLINE(.LINECNT)
  1.  D ADDLINE(.LINECNT,MESSAGE,"YES")
  1.  D ADDLINE(.LINECNT)
  1.  D BANNERL(.LINECNT,MSG)
  1.  D:$D(MSG2) BANNERL(.LINECNT,MSG2)
  1.  D ADDLINE(.LINECNT)
  1.  ;
  1.  I $G(MODE)["NONFATAL" D ADDLINE(.LINECNT,MESSAGE,"YES")
  1.  ;
  1.  I $G(MODE)="FATAL" D
  1.  . D ADDLINE(.LINECNT,"Please print/capture this screen and","YES")
  1.  . D ADDLINE(.LINECNT,"notify the Support Center at","YES")
  1.  . D ADDLINE(.LINECNT)
  1.  . D ADDLINE(.LINECNT,"1-888-830-7280.","YES")
  1.  . D ADDLINE(.LINECNT)
  1.   ;
  1.  D ADDLINE(.LINECNT,ROWSTARS)
  1.  D ADDLINE(.LINECNT)
  1.  ;
  1.  D BMES^XPDUTL(.STR)
  1.  ;
  1.  I $G(DEBUG)="YES" Q
  1.  ;
  1.  S MODESTR=$S(MODE="FATAL":" >> FATAL << ",1:" - NONFATAL - ")
  1.  D SNDALERT("Laboratory Patch "_CP_MODESTR_MSG)
  1.  D SENDMAIL("IHS Lab Patch "_CP_" Install "_MODE_" Error")
  1.  Q
  1.  ;
  1. SNDALERT(ALERTMSG) ; EP - Send alert to LMI group AND Installer
  1.  Q:$G(DEBUG)="YES"
  1.  ;
  1.  S XQAMSG=ALERTMSG
  1.  S XQA("G.LMI")=""
  1.  ;
  1.  ; If installer not part of LMI Mail Group, send them alert also
  1.  S:$$NINLMI(DUZ) XQA(DUZ)=""
  1.  ;
  1.  D SETUP^XQALERT
  1.  K XQA,XQAMSG
  1.  Q
  1.  ;
  1. NINLMI(CHKDUZ) ; EP -- Check to see if DUZ is NOT part of LMI Mail Group
  1.  NEW MGRPIEN,XMDUZ
  1.  ;
  1.  ; Get IEN of LMI MaiL Group
  1.  D CHKGROUP^XMBGRP("LMI",.MGRPIEN)     ; VA DBIA 1146
  1.  Q:+(MGRPIEN)<1 1                      ; If no Mail Group, return TRUE
  1.  ;
  1.  ; XMDUZ = DUZ of the user
  1.  ; Y     = IEN of the mail group
  1.  S XMDUZ=DUZ
  1.  S Y=MGRPIEN
  1.  D CHK^XMA21                           ; VA DBIA 10067
  1.  ;
  1.  Q $S($T=1:0,1:1)
  1.  ;
  1. SENDMAIL(SUBJECT) ; EP -- Send MailMan E-mail to LMI group AND Installer
  1.  Q:$G(DEBUG)="YES"
  1.  ;
  1.  NEW DIFROM
  1.  ;
  1.  K XMY
  1.  S XMY("G.LMI")=""
  1.  ;
  1.  ; If installer not part of LMI Mail Group, send them e-mail also
  1.  S:$$NINLMI(DUZ) XMY(DUZ)=""
  1.  ;
  1.  S LRBLNOW=$E($$NOW^XLFDT,1,12)
  1.  ;
  1.  S XMSUB=SUBJECT
  1.  S XMTEXT="STR("
  1.  S XMDUZ="Lab Patch "_$P($T(+2),"*",3)      ; Current Patch
  1.  S XMZ="NOT OKAY"
  1.  D ^XMD
  1.  ;
  1.  I $G(XMMG)'=""!(XMZ="NOT OKAY") D
  1.  . D BMES^XPDUTL($J("",5)_"MAILMAN ERROR.")
  1.  . D BMES^XPDUTL($J("",10)_"XMZ:"_XMZ)
  1.  . D BMES^XPDUTL($J("",10)_"XMMG:"_XMMG)
  1.  ;
  1.  K X,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,Y   ; Cleanup
  1.  Q
  1.  ;
  1. ADDLINE(LC,ASTR,CENTER) ; EP -- Add a line to the STR array; CENTER if requested
  1.  I $G(ASTR)="" S ASTR=" "
  1.  S STR(LC)=$S($G(CENTER)="YES":$$CJ^XLFSTR(ASTR,65),1:$G(ASTR))
  1.  S LC=LC+1
  1.  Q
  1.  ;
  1. SORRYEND(WOTERR,CP) ; EP -- ALL the errors detected during the environment check.
  1.  NEW STR,MODULE,NAME,VERSION,PATCH,LINECNT,TMP
  1.  ;
  1.  D SORRYHED
  1.  ;
  1.  S (MODULE,NAME,VERSION)=""
  1.  F  S MODULE=$O(WOTERR(MODULE))  Q:MODULE=""  D
  1.  . F  S NAME=$O(WOTERR(MODULE,NAME))  Q:NAME=""  D
  1.  .. F  S VERSION=$O(WOTERR(MODULE,NAME,VERSION))  Q:VERSION=""  D
  1.  ... D ADDMESG
  1.  ;
  1.  D SORRYFIN
  1.  ;
  1.  D BMES^XPDUTL(.STR)
  1.  ;
  1.  Q
  1.  ;
  1. SORRYHED ; EP -- "Header" of Final Fatal Message
  1.  S LINECNT=1
  1.  D ADDLINE(.LINECNT)
  1.  D ADDLINE(.LINECNT,ROWSTARS)
  1.  D ADDLINE(.LINECNT)
  1.  D ADDLINE(.LINECNT,"Systems Environment Error Detected","YES")
  1.  D ADDLINE(.LINECNT,"KIDS build will be deleted","YES")
  1.  D ADDLINE(.LINECNT)
  1.  D ADDLINE(.LINECNT,"Modules with Version or Patch errors","YES")
  1.  D ADDLINE(.LINECNT)
  1.  Q
  1.  ;
  1. ADDMESG ; EP
  1.  NEW WOT
  1.  ;
  1.  D ADDLINE(.LINECNT,NAME_" ("_MODULE_")","YES")
  1.  ;
  1.  S WOT=$G(WOTERR(MODULE,NAME,VERSION))
  1.  S TMP="Version:"_VERSION
  1.  I $P(WOT,"^",2)="VERSION" D
  1.  . S TMP="Needed Version:"_VERSION
  1.  . S TMP=TMP_"  Found Version:"_$P(WOT,"^")
  1.  I $P(WOT,"^",2)="PATCH" D
  1.  . S TMP=TMP_"  Needed Patch:"_$P(WOT,"^")
  1.  ;
  1.  D ADDLINE(.LINECNT,TMP,"YES")
  1.  D ADDLINE(.LINECNT)
  1.  Q
  1.  ;
  1. SORRYFIN ; EP -- "Fin" of Final Fatal Message
  1.  D ADDLINE(.LINECNT,"Re-Installation will be necessary.","YES")
  1.  D ADDLINE(.LINECNT)
  1.  D ADDLINE(.LINECNT,"If assistance is needed, please call 1-888-830-7280.","YES")
  1.  D ADDLINE(.LINECNT)
  1.  D ADDLINE(.LINECNT,ROWSTARS)
  1.  D ADDLINE(.LINECNT)
  1.  Q
  1.  ;
  1. CHKMAILG(CP,MAILGRP,ERRARRAY)   ; Determine if required Mail Group Exists
  1.  NEW MGRPIEN
  1.  D CHKGROUP^XMBGRP(MAILGRP,.MGRPIEN)   ; VA DBIA 1146
  1.  I MGRPIEN D  Q
  1.  . D OKAY^BLRKIDSU(MAILGRP_" Mail Group Exists.")
  1.  ;
  1.  D BMES^XPDUTL("")
  1.  D SORRY(CP,MAILGRP_" Mail Group Does NOT Exist!")
  1.  S ERRARRAY("XMB","Mail Group","3.8")=MAILGRP_" Mail Group"
  1.  Q
  1.  ;
  1. BANNERL(LC,ASTR) ; EP -- Stores "Banner" Line in STR array
  1.  ;
  1.  S STR(LC)=$$MKBANNRL(ASTR)
  1.  S LC=LC+1
  1.  Q
  1.  ;
  1. MKBANNRL(ASTR) ; EP - MaKe the BANNeR Line
  1.  NEW HALFLEN,J,RM,STRLEN,TMPSTR
  1.  ;
  1.  S RM=65      ; Right Margin
  1.  ;
  1.  S HALFLEN=(RM\2)-(($L(ASTR)+2)\2)
  1.  S TMPSTR=$TR($J("",HALFLEN)," ",">")
  1.  S TMPSTR=TMPSTR_" "_ASTR_" "
  1.  S STRLEN=$L(TMPSTR)
  1.  F J=STRLEN:1:(RM-1) S TMPSTR=TMPSTR_"<"
  1.  Q TMPSTR
  1.  ;
  1.  ; Generic "Find RPMS Module's Version and (perhaps) Patch number"
  1.  ; The MODULE variable MUST be the PREFIX name from the PACKAGE file (9.4).
  1. NEEDIT(CP,MODULE,VERSION,PATCH,ERRARRAY)      ; EP
  1.  NEW NAME                    ; NAME of PACKAGE
  1.  NEW PTR                     ; PoinTeR to PACKAGE file
  1.  NEW HEREYAGO,STR1,STR2      ; Scratch variables/arrays
  1.  NEW SYSVER,SYSPATCH         ; System Version & System Patch variables
  1.  NEW NAMEVER,NAMESYS
  1.  ;
  1.  D FIND^DIC(9.4,"",,,MODULE,,"C",,,"HEREYAGO")
  1.  S PTR=$G(HEREYAGO("DILIST",2,1))
  1.  S NAME=$G(HEREYAGO("DILIST",1,1))
  1.  ;
  1.  S SYSVER=+$$VERSION^XPDUTL(MODULE)    ; Get Current Version #
  1.  ;
  1.  S NAMEVER=NAME_" "_VERSION,NAMESYS=NAME_" "_SYSVER
  1.  ;
  1.  ; If Current Version < Needed Version, write message and quit
  1.  I SYSVER<VERSION D  Q
  1.  . S ERRARRAY(MODULE,NAME,VERSION)=SYSVER_"^VERSION"
  1.  . D:SYSVER>0 NEEDMSG("Need "_NAMEVER_" & "_NAMESYS_" found!")
  1.  . D:SYSVER<1 NEEDMSG("Need "_MODULE_" & "_MODULE_" Not Installed!")
  1.  ;
  1.  ; If System Version > Needed Version, write message and quit
  1.  I VERSION<SYSVER D OKAY^BLRKIDSU("Need "_NAMEVER_" & "_NAMESYS_" found.",5)  Q
  1.  ;
  1.  I $G(PATCH)="" D  Q   ; If no Patch check, write message and quit
  1.  . D OKAY^BLRKIDSU(NAMEVER_" found.",5)
  1.  ;
  1.  S SYSPATCH=$$PATCH^XPDUTL(MODULE_"*"_VERSION_"*"_PATCH)
  1.  I SYSPATCH'=1 D  Q
  1.  . S ERRARRAY(MODULE,NAME,VERSION)=$G(PATCH)_"^PATCH"
  1.  . D NEEDMSG(NAMEVER_" ("_MODULE_") & Patch "_PATCH_" WAS NOT installed!")
  1.  ;
  1.  D OKAY^BLRKIDSU(NAMEVER_" Patch "_PATCH_" found.",5)
  1.  ;
  1.  Q
  1.  ;
  1. NEEDMSG(MESSAGE) ; EP
  1.  NEW STR1,STR2
  1.  ;
  1.  S STR1=MESSAGE
  1.  I $L(STR1)<58 D SORRY(CP,STR1)  Q
  1.  ;
  1.  S STR1=$P(MESSAGE,"&")_" &"
  1.  S STR2=$$TRIM^XLFSTR($P(MESSAGE,"&",2),"L"," ")
  1.  D SORRY(CP,STR1,,STR2)
  1.  Q
  1.  ;
  1. PASSMESG(WOT) ; EP -- Splash message
  1.  NEW CRTLINE,MAXIT,AROUND
  1.  ;
  1.  F CRTLINE=1:1:20 W $J("",80),!
  1.  D EN^XBVIDEO("HOM")
  1.  S MAXIT="@"
  1.  F J=1:1:$L(WOT) S MAXIT=MAXIT_$E(WOT,J,J)_"@"
  1.  S AROUND=$TR($J("",8+$L(MAXIT))," ","@")
  1.  S MAXIT="@@!!"_$TR(MAXIT," ","@")_"!!@@"
  1.  ;
  1.  W !!
  1.  W $TR($J("",IOM)," ","*"),!
  1.  W $TR($J("",IOM)," ","*"),!
  1.  W $TR($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
  1.  W $TR($$CJ^XLFSTR(MAXIT,IOM)," @","* "),!
  1.  W $TR($$CJ^XLFSTR(AROUND,IOM)," @","* "),!
  1.  W $TR($J("",IOM)," ","*"),!
  1.  W $TR($J("",IOM)," ","*"),!
  1.  Q
  1.  ;
  1. PREINS ; EP -- Ask for confirmation of Backup
  1.  NEW CNT,FDAROOT,IEN,IENS,MSGROOT
  1.  NEW BCKUPCNT                   ; Current Patch,Backup count
  1.  ;
  1.  S XUMF=1
  1.  ;
  1.  S CP=$TR($P($T(+2),";",5),"*")
  1.  D BMES^XPDUTL("")
  1.  D BMES^XPDUTL("PRE-INSTALL of BLRPRE31 Begins.")
  1.  ;
  1.  D PASSMESG("ATTENTION")
  1.  W !
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="Y"
  1.  S DIR("B")="NO"
  1.  S DIR("A")=$J("",10)_"Has a "_$C(27)_"[1;7;5m"_">> SUCCESSFUL <<"_$C(27)_"[0m"_" backup been performed?"
  1.  D ^DIR
  1.  W !
  1.  ;
  1.  I +$G(Y)'=1 D  Q
  1.  . S XPDABORT=1
  1.  . D PASSMESG("ATTENTION")
  1.  . D BMES^XPDUTL("")
  1.  . D BMES^XPDUTL("")
  1.  . D BMES^XPDUTL($J("",15)_"SUCCESSFUL system backup has >>> NOT <<< been confirmed.")
  1.  . D BMES^XPDUTL($J("",15)_"Install Aborting.")
  1.  ;
  1.  ; Store backup confirmation person & date/time
  1.  S BCKUPCNT=1+$O(^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",""),-1)
  1.  S ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT)=DUZ_"^"_$P($G(^VA(200,DUZ,0)),U)
  1.  S ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT,"DATE/TIME")=$$HTE^XLFDT($H,"5MZ")
  1.  ;
  1.  D BMES^XPDUTL("")
  1.  D BMES^XPDUTL($J("",5)_"SUCCESSFUL system backup CONFIRMED by: "_$P($G(^VA(200,DUZ,0)),U))
  1.  ;
  1.  Q:$L($G(DEBUG))             ; Don't do anything if in DEBUG mode
  1.  ;
  1.  D DISABLE^%NOJRN            ; Disable Journaling prior to deletions
  1.  ;
  1.  S XUMF=1          ; Trick from VistA programmers.  Supposedly allows updating "locked down" dictionaries
  1.  ;
  1.  ; The following deletions are necessatry in order to prevent errors during installation
  1.  D BMES^XPDUTL("")
  1.  D BMES^XPDUTL($J("",5)_"Pre-Install Processing Begins.")
  1.  ;
  1.  ; Delete All LAB LOINC entries
  1.  S IEN=.9999999,CNT=0
  1.  W !,?4
  1.  F  S IEN=$O(^LAB(95.3,IEN))  Q:IEN<1  D
  1.  . I CNT#100=0  W "."  W:$X>75 !,?4
  1.  . S CNT=CNT+1
  1.  . D ^XBFMK
  1.  . S DIK="^LAB(95.3,",DA=IEN
  1.  . D ^DIK
  1.  ;
  1.  ; Delete ALL UCUM entries
  1.  S IEN=.9999999,CNT=0
  1.  F  S IEN=$O(^BLRUCUM(IEN))  Q:IEN<1!(IEN>899999)  D
  1.  . I CNT#100=0  W "."  W:$X>75 !,?4
  1.  . S CNT=CNT+1
  1.  . D ^XBFMK
  1.  . S DIK="^BLRUCUM(",DA=IEN
  1.  . D ^DIK
  1.  ;
  1.  ; Delete All LAB LOINC COMPONENT entries
  1.  S IEN=.9999999,CNT=0
  1.  W !,?4
  1.  F  S IEN=$O(^LAB(95.31,IEN))  Q:IEN<1  D
  1.  . I CNT#100=0  W "."  W:$X>75 !,?4
  1.  . S CNT=CNT+1
  1.  . D ^XBFMK
  1.  . S DIK="^LAB(95.31,",DA=IEN
  1.  . D ^DIK
  1.  ;
  1.  W !
  1.  ;
  1.  D ENABLE^%NOJRN             ; Restore Journaling
  1.  ;
  1.  D BMES^XPDUTL($J("",5)_"Pre-Install Processing Ends.")
  1.  ;
  1.  D BMES^XPDUTL("")
  1.  D BMES^XPDUTL("PRE-INSTALL of BLRPRE31 Ends.")
  1.  Q