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