BLRPRE41 ; IHS/MSC/MKK - RPMS Lab Patch LR*5.2*1041 Pre/Install/Post Routine ; 13-Oct-2017 14:04 ; MKK
;;5.2;IHS LABORATORY;**1041**;NOV 01, 1997;Build 23
;
ENVICHEK ; EP - Environment Checker
NEW BLRVERN,BLRVERN2,CP,ERRARRAY,ROWSTARS,RPMS,RPMSVER,TODAY,WOTCNT
;
Q:$$ENVIVARS()="Q"
;
D ENVHEADR^BLRKIDS2(CP,RPMSVER,RPMS),BLANK
;
D NEEDIT^BLRKIDS2(CP,"LR","5.2",1040,.ERRARRAY),BLANK ; Lab Pre-Requisite
;
I XPDABORT>0 D SORRYEND^BLRKIDS2(.ERRARRAY,CP) Q ; ENVIRONMENT HAS ERROR(S)
;
D BOKAY^BLRKIDS2("ENVIRONMENT")
;
Q
;
ENVIVARS() ; EP - Setup the Environment variables
D SETEVARS
;
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^BLRKIDS2(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^BLRKIDS2(CP,"DUZ UNDEFINED OR 0.") Q "Q"
I $$GET1^DIQ(200,DUZ,"NAME")="" D SORRY^BLRKIDS2(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"
;
PRE ; EP - Ask for confirmation of Backup
NEW BLRVERN,BLRVERN2,CNT,CP,CPSTR,CRTLINE,DIRASTR,FDAROOT,IEN,IENS,MSGROOT
NEW BCKUPCNT ; Current Patch,Backup count
;
D SETEVARS
;
S XUMF=1
;
D INITSCR
D TITLE^XPDID(CPSTR)
D BLANK,BMES^XPDUTL("Pre-Install begins "_$$UP^XLFSTR($$HTE^XLFDT($H,"5MPZ"))_".")
;
Q:$$BACKUP()="Q"
;
D INITSCR
D TITLE^XPDID(CPSTR)
D BLANK,BMES^XPDUTL("Pre-Install of "_BLRVERN_" Continues.")
;
; Do Pre-install stuff here.
D SAVEOFF
;
D BMES^XPDUTL("Pre-Install ends "_$$UP^XLFSTR($$HTE^XLFDT($H,"5MPZ"))_".")
H 2 ; Pause so user can see the message.
;
; D EXIT^XPDID
Q
;
BACKUP() ; EP - Confirm Backup
NEW BCKUPCNT,SUCCSTR
;
D SHOWBOX^BLRGMENU("ATTENTION",10,70)
;
D ^XBFMK
S DIR(0)="Y"
S DIR("B")="NO"
I $G(IOST)["C-VT" S SUCCSTR=$C(27)_"[1;7;5m"_">> SUCCESSFUL <<"_$C(27)_"[0m"
E S SUCCSTR=">> SUCCESSFUL <<"
S DIR("A")=$J("",10)_"Has a "_SUCCSTR_" backup been performed?"
S DIR("?")="A *NO* answer will abort the install process."
D ^DIR
W !
;
Q:+$G(Y)'=1 $$NOBACKUP() ; If BACKUP not performed, then ABORT installation.
;
Q:+$G(DEBUG) $$OKBACKUP() ; DEBUG will *NOT* store Backup Confirmation data.
;
; Store backup confirmation person & date/time
S BCKUPCNT=1+$O(^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",0),-1)
S ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT)=$P($G(^VA(200,DUZ,0)),U)
S ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT,"DUZ")=DUZ
S ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT,"DATE/TIME")=$$HTE^XLFDT($H,"5MZ")
;
Q $$OKBACKUP()
;
OKBACKUP() ; EP - Backup Confirmed.
D BLANK
D OKAY^BLRKIDSU("SUCCESSFUL system backup CONFIRMED by: "_$$GET1^DIQ(200,DUZ,"NAME")_".",5)
I +$G(DEBUG) D
. D BLANK
. D TABMENU^BLRKIDSU("DEBUG will **NOT** Store Backup Confirmation.",10)
;
H 2 ; Pause to let the user see the message.
Q "OK"
;
NOBACKUP() ; EP - No backup message
S XPDABORT=1
D PASSMESG^BLRKIDS2("ATTENTION")
D TABMESG^BLRKIDSU("SUCCESSFUL system backup has >>> NOT <<< been confirmed.",15)
D TABMESG^BLRKIDSU("Installer: "_$$GET1^DIQ(200,DUZ,"NAME")_" ["_DUZ_"].",25)
D TABMESG^BLRKIDSU("Install Aborting.",15)
H 2 ; Pause to let the user see the message.
Q "Q"
;
DEBUG ; EP - Debugging Line Label for environment checker
NEW BEGTIME,BLRVERN,CP,CPSTR,DEBUG,ENDTIME,ERRARRAY,LASTLOGI
NEW LRBLNOW,PATCHNUM,PREREQ,QFLG,ROWSTARS,RPMS,RPMSVER,STR
NEW SUCCSTR,TODAY,WHATCNT,WOTCNT,XPDABORT,XPDENV,XPDNM
;
; NOTE: DEBUG will not store "Backup" data.
;
D SETEVARS
;
W !!
W "Debug Routine ",BLRVERN," Begins:",!!
;
S DEBUG=1 ; Don't Send Alerts
;
W !
S XPDNM=CPSTR
S (XPDENV,XPDABORT)=0
;
D PRE
Q:XPDABORT
;
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 !!,"Debug Routine ",BLRVERN," Ends.",!!
Q
;
POST ; EP - Post-Install
NEW BLRVERN,BLRVERN2,CP,CPSTR,PATCHNUM,TODAY,WOTCNT
;
D SETEVARS
;
D BLANK
D BMES^XPDUTL("Laboratory Patch "_CPSTR_" POST INSTALL begins at "_$$UP^XLFSTR($$HTE^XLFDT($H,"5MPZ"))_".")
D BLANK
;
S TODAY=$$DT^XLFDT
S WOTCNT=$$WOTCNT(BLRVERN)
;
D ADDOPTS ; Add new options to BLRMENU
;
D VBECSUPD ; VBECS Update
;
D FORCENO ; Force new parameters to NO
;
D ADDDESC ; Add Descriptions to 3 Mail Groups
;
I $L($G(^DD(90475.8,0,"VR")))<1 D
. S FORCEDD="^DD(90475.8,0,""VR"")"
. S @FORCEDD=5.2 ; Force Version Number into Data Dictionary.
. S FORCEDD="^DD(90475.8,0,""VRPK"")"
. S @FORCEDD="LR" ; Force Lab Link into Data Dictionary.
;
D BLANK
D BMES^XPDUTL("Laboratory Patch "_CPSTR_" POST INSTALL ends at "_$$UP^XLFSTR($$HTE^XLFDT($H,"5MPZ"))_".")
D BLANK
;
D POSTMAIL(BLRVERN,CPSTR)
;
S ^XTMP(BLRVERN,TODAY,WOTCNT,"END")=$$NOW^XLFDT
Q
;
ADDOPTS ; EP - Add new options
D ADDOPTS^BLRKIDS2("BLRMENU","BLR PARMETERS AND MAIL GROUPS","PAMG")
D ADDOPTS^BLRKIDS2("BLRMENU","BLROLOR","ORDO")
; D ADDOPTS^BLRKIDS2("BLRMENU","BLRPURGU","PURG")
D ADDOPTS^BLRKIDS2("LRSUPERVISOR","BLRPURGU","PURR")
D ADDOPTS^BLRKIDS2("BLRMENU","BLR PATIENT REMINDER DOCUMENT","PDOC")
D ADDOPTS^BLRKIDS2("BLRMENU","BLRERRTR","ERRT")
Q
;
FORCENO ; EP - Force new parameters to be NO
NEW (DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D SETBLRVS
Q:'$$GETPARS(.PARSLIST)
;
I +$G(DEBUG) D Q ; If DEBUG, just print messages & quit
. S TAB=$J("",10)
. D BLANK,OKAY^BLRKIDSU("DEBUG: FORCENO^"_BLRVERN,4)
. S PARAMETER=""
. F S PARAMETER=$O(PARSLIST(PARAMETER)) Q:PARAMETER="" D
.. D MES^XPDUTL(TAB_"DEBUG will *NOT* modify "_PARAMETER_" parameter.")
;
S PARAMETER=""
F S PARAMETER=$O(PARSLIST(PARAMETER)) Q:PARAMETER="" D
. K ERRS
. D EN^XPAR("PKG",PARAMETER,,"NO",.ERRS)
. I +$G(ERRS) D
.. D BLANK,MES^XPDUTL(PARAMETER_" parameter not modified."),BLANK
.. D STORERRS^BLREMERA(ERRS,PARAMETER)
Q
;
GETPARS(PARSLIST) ; EP - Function to get Parameters from BUILD file
NEW (DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PARSLIST,U,XPARSYS,XQXFLG)
;
D SETEVARS
;
S BUILDIEN=$$FIND1^DIC(9.6,,,CPSTR)
Q:BUILDIEN<1 0
;
S PARAMTRS="",CNT=0
F S PARAMTRS=$O(^XPD(9.6,BUILDIEN,"KRN",8989.51,"NM","B",PARAMTRS)) Q:PARAMTRS="" D
. S PARSLIST(PARAMTRS)="",CNT=CNT+1
;
Q CNT
;
;
SAVEOFF ; EP - Save off all routines being updated by this patch into the ^rBACKUP global.
NEW (DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$G(^%ZOSF("OS"))'["OpenM" ; If not Cache, cannot use ^%R
;
S BLRVERN=$TR($P($T(+1),";")," ")
;
I +$G(DEBUG) D Q ; If DEBUG, just print messages & quit
. S TAB=$J("",10)
. D BLANK,OKAY^BLRKIDSU("DEBUG: SAVEOFF^"_BLRVERN,4)
. D BMES^XPDUTL(TAB_"DEBUG does *NOT* Save off routines.")
;
S PATCH=$P($T(+2),"*",3)
S BUILD="LR*5.2*"_PATCH
S PATCHIEN=+$O(^XPD(9.6,"B",BUILD,"A"),-1) ; Get the most current Patch IEN
Q:PATCHIEN<1 ; If not in BUILD file, skip
;
D BMES^XPDUTL("Backing up routines.")
S RTN="",(CNT,RTNCNT)=0
F S RTN=$O(^XPD(9.6,PATCHIEN,"KRN",9.8,"NM","B",RTN)) Q:RTN="" D
. S RTNPATCH=+$RE($P($RE($TR($P($G(^ROUTINE(RTN,0,2)),";",5),"*")),","))
. Q:RTNPATCH<1 ; If RTN not in the ^ROUTINE global, skip
. Q:RTNPATCH'<PATCH ; Only versions < this patch
. ;
. S RTNCNT=RTNCNT+1
. K ERRS,RTNA
. F LN=0:1:$G(^ROUTINE(RTN,0,0)) S RTNA(LN)=$G(^ROUTINE(RTN,0,LN))
. S X=$$ROUTINE^%R(RTN_".INT",.RTNA,.ERRS,"CSB")
. S NOW=$H
. S ^BLRINSTL("LAB PATCH",PATCH,"SAVEOFF",NOW)=$$HTE^XLFDT(NOW,"5MZ")
. S ^BLRINSTL("LAB PATCH",PATCH,"SAVEOFF",NOW,RTN)=$S($D(ERRS)>1:"ERRORS",1:"OK")
. I $D(ERRS)'>1 D
.. D OKAY^BLRKIDSU("Routine "_RTN_" backed up.",4)
.. S CNT=CNT+1
;
I RTNCNT D
. S TAB=$J("",5)
. D BMES^XPDUTL(TAB_RTNCNT_" routines analyzed.")
. D BMES^XPDUTL(TAB_TAB_CNT_" routines backed up.")
Q
;
;
VBECSUPD ; EP - VBECS Update
NEW (DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$G(^%ZOSF("OS"))'["OpenM" ; If not Cache, cannot use ^%R
;
D SETBLRVS
;
S RTN="VB",CNT=0
F S RTN=$O(^ROUTINE(RTN)) Q:RTN=""!($E(RTN,1,2)'="VB") D
. S X=$$DEL^%R(RTN_".INT")
. S X=$$DEL^%R(RTN_".OBJ")
. S CNT=CNT+1
;
Q:CNT<1
;
D:$D(^XTMP(BLRVERN,0))<1 XTMPHEAD
S ^XTMP(BLRVERN,$J,"VBECSUPD")=CNT_" VBECS routines removed during Post Install."
Q
;
ADDDESC ; EP - Add Descriptons to 3 Mail Groups, if and only if they are currently blank
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D ADDLMI
D ADDBLRL
D ADDLABT
Q
;
ADDLMI ; EP - Add description to LMI Mail Group
NEW WPARRAY
;
S WPARRAY("WP")=""
S WPARRAY("WP",1)="Laboratory Management Mail Group to receive anomalous and/or descriptive"
S WPARRAY("WP",2)="messages from the Lab subsystem."
;
D STORDESC("LMI",.WPARRAY)
Q
;
ADDBLRL ; EP - Add Description to BLRLINK Mail Group
NEW WPARRAY
;
S WPARRAY("WP")=""
S WPARRAY("WP",1)="Mail Group to receive Lab to PCC linker issues and/or"
S WPARRAY("WP",2)="descriptive messages."
;
D STORDESC("BLRLINK",.WPARRAY)
Q
;
ADDLABT ; EP - Add Description to LAB TECHS Mail Group
NEW WPARRAY
;
S WPARRAY("WP")=""
S WPARRAY("WP",1)="Laboratory Techs."
;
D STORDESC("LAB TECHS",.WPARRAY)
Q
;
STORDESC(MGRP,WPARRAY) ; EP - Store description into Mail Group file
NEW LMGIEN
;
D ^XBFMK
S LMGIEN=+$$FIND1^DIC(3.8,,"O",MGRP) ; Skip if cannot determine Mail Group IEN
;
Q:$L($$GET1^DIQ(3.801,"1,"_LMGIEN,.01)) ; Skip if description already exists
;
D ^XBFMK
K ERRS
D WP^DIE(3.8,LMGIEN_",",3,"K","WPARRAY(""WP"")","ERRS")
I '$D(ERRS) D OKAY^BLRKIDSU("Added Description to "_MGRP_" Mail Group.",5) Q
;
D TABMESG^BLRKIDSU("Could Not Add Description to "_MGRP_" Mail Group.",10)
Q
;
;
; ========================= UTILITIES FOLLOW ==========================
;
SETEVARS ; EP - SET standard "Enviroment" VARiables.
S (CP,PATCHNUM)=$P($T(+2),"*",3)
S CPSTR="LR*5.2*"_CP
D SETBLRVS
Q
;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
K BLRVERN,BLRVERN2
;
S BLRVERN=$P($P($T(+1),";")," ")
S:$L($G(TWO)) BLRVERN2=$G(TWO)
Q
;
XTMPHEAD ; EP - Initialize XTMP for this patch
NEW BLRVERN,BLRVERN2,PTCHNAME
D SETBLRVS
S PTCHNAME=$$TRIM^XLFSTR($P($P($P($T(+1),";",2),"-",2),"Pre"),"LR"," ")
S ^XTMP(BLRVERN,0)=$$FMADD^XLFDT($$DT^XLFDT,30)_U_$$DT^XLFDT_U_PTCHNAME
Q
;
BLANK ; EP - Blank Line
D MES^XPDUTL("")
Q
;
MESCNTR(STR) ; EP - Center a line and use XPDUTL to display it
D MES^XPDUTL($$CJ^XLFSTR(STR,IOM))
Q
;
WOTCNT(BLRVERN) ; EP - Counter for ^XTMP
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")
;
INITSCR ; EP - Initialize screen. Cloned from INIT^XPDID
N X,XPDSTR
I IO'=IO(0)!(IOST'["C-VT") S XPDIDVT=0 Q
I $T(PREP^XGF)="" S XPDIDVT=0 Q
D PREP^XGF
S XPDIDVT=1,X="IOSTBM",XPDSTR=""
D ENDR^%ZISS
S IOTM=3,IOBM=IOSL-4
W @IOSTBM
D FRAME^XGF(IOTM-2,0,IOTM-2,IOM-1) ; Top line
; D FRAME^XGF(IOBM+1,0,IOBM+1,IOM-1) ; Bottom line
D IOXY^XGF(IOTM-2,0)
Q
;
POSTMAIL(BLRVERN,CPSTR) ; EP - Post Install MailMan Message
Q:+$G(DEBUG) ; No MailMan messages during debugging
;
NEW STR
;
S STR(1)=" "
S STR(2)=$J("",10)_"POST INSTALL of "_BLRVERN_" Routine."
S STR(3)=" "
S STR(4)=$J("",15)_"Laboratory Patch "_CPSTR_" INSTALL completed."
S STR(5)=" "
;
; Send E-Mail to LMI Mail Group & Installer
D MAILALMI^BLRUTIL3("Laboratory Patch "_CPSTR_" INSTALL complete.",.STR,BLRVERN)
;
Q
BLRPRE41 ; IHS/MSC/MKK - RPMS Lab Patch LR*5.2*1041 Pre/Install/Post Routine ; 13-Oct-2017 14:04 ; MKK
+1 ;;5.2;IHS LABORATORY;**1041**;NOV 01, 1997;Build 23
+2 ;
ENVICHEK ; EP - Environment Checker
+1 NEW BLRVERN,BLRVERN2,CP,ERRARRAY,ROWSTARS,RPMS,RPMSVER,TODAY,WOTCNT
+2 ;
+3 IF $$ENVIVARS()="Q"
QUIT
+4 ;
+5 DO ENVHEADR^BLRKIDS2(CP,RPMSVER,RPMS)
DO BLANK
+6 ;
+7 ; Lab Pre-Requisite
DO NEEDIT^BLRKIDS2(CP,"LR","5.2",1040,.ERRARRAY)
DO BLANK
+8 ;
+9 ; ENVIRONMENT HAS ERROR(S)
IF XPDABORT>0
DO SORRYEND^BLRKIDS2(.ERRARRAY,CP)
QUIT
+10 ;
+11 DO BOKAY^BLRKIDS2("ENVIRONMENT")
+12 ;
+13 QUIT
+14 ;
ENVIVARS() ; EP - Setup the Environment variables
+1 DO SETEVARS
+2 ;
+3 SET TODAY=$$DT^XLFDT
+4 SET WOTCNT=$$WOTCNT(BLRVERN)
+5 ; Row of asterisks
SET ROWSTARS=$TRANSLATE($JUSTIFY("",65)," ","*")
+6 ;
+7 SET ^XTMP(BLRVERN,0)=$$HTFM^XLFDT(+$HOROLOG+90)_"^"_$$DT^XLFDT_"^IHS Lab Patch "_CPSTR
+8 MERGE ^XTMP(BLRVERN,TODAY,WOTCNT,"DUZ")=DUZ
+9 SET ^XTMP(BLRVERN,TODAY,WOTCNT,"BEGIN")=$$NOW^XLFDT
+10 ;
+11 SET XUMF=1
+12 ;
+13 IF $GET(XPDNM)=""
DO SORRY^BLRKIDS2(CP,"XPDNM not defined or 0.")
QUIT "Q"
+14 ;
+15 ; RPMS Module
SET RPMS=$PIECE(XPDNM,"*",1)
+16 ; RPMS Version
SET RPMSVER=$PIECE(XPDNM,"*",2)
+17 ;
+18 IF +$GET(DUZ)<1
DO SORRY^BLRKIDS2(CP,"DUZ UNDEFINED OR 0.")
QUIT "Q"
+19 IF $$GET1^DIQ(200,DUZ,"NAME")=""
DO SORRY^BLRKIDS2(CP,"Installer cannot be identified!")
QUIT "Q"
+20 ;
+21 ; No Queuing Allowed
SET XPDNOQUE=1
+22 ;
+23 ; The following line prevents the "Disable Options..." and "Move
+24 ; Routines..." questions from being asked during the install.
+25 FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
SET XPDDIQ(X,"B")="NO"
+26 ;
+27 ; KIDS install Flag
SET XPDABORT=0
+28 ;
+29 ; Reset/Initialize IO variables
DO HOME^%ZIS
+30 ; Set DT variable without a Line Feed
DO DTNOLF^DICRW
+31 ;
+32 QUIT "OK"
+33 ;
PRE ; EP - Ask for confirmation of Backup
+1 NEW BLRVERN,BLRVERN2,CNT,CP,CPSTR,CRTLINE,DIRASTR,FDAROOT,IEN,IENS,MSGROOT
+2 ; Current Patch,Backup count
NEW BCKUPCNT
+3 ;
+4 DO SETEVARS
+5 ;
+6 SET XUMF=1
+7 ;
+8 DO INITSCR
+9 DO TITLE^XPDID(CPSTR)
+10 DO BLANK
DO BMES^XPDUTL("Pre-Install begins "_$$UP^XLFSTR($$HTE^XLFDT($HOROLOG,"5MPZ"))_".")
+11 ;
+12 IF $$BACKUP()="Q"
QUIT
+13 ;
+14 DO INITSCR
+15 DO TITLE^XPDID(CPSTR)
+16 DO BLANK
DO BMES^XPDUTL("Pre-Install of "_BLRVERN_" Continues.")
+17 ;
+18 ; Do Pre-install stuff here.
+19 DO SAVEOFF
+20 ;
+21 DO BMES^XPDUTL("Pre-Install ends "_$$UP^XLFSTR($$HTE^XLFDT($HOROLOG,"5MPZ"))_".")
+22 ; Pause so user can see the message.
HANG 2
+23 ;
+24 ; D EXIT^XPDID
+25 QUIT
+26 ;
BACKUP() ; EP - Confirm Backup
+1 NEW BCKUPCNT,SUCCSTR
+2 ;
+3 DO SHOWBOX^BLRGMENU("ATTENTION",10,70)
+4 ;
+5 DO ^XBFMK
+6 SET DIR(0)="Y"
+7 SET DIR("B")="NO"
+8 IF $GET(IOST)["C-VT"
SET SUCCSTR=$CHAR(27)_"[1;7;5m"_">> SUCCESSFUL <<"_$CHAR(27)_"[0m"
+9 IF '$TEST
SET SUCCSTR=">> SUCCESSFUL <<"
+10 SET DIR("A")=$JUSTIFY("",10)_"Has a "_SUCCSTR_" backup been performed?"
+11 SET DIR("?")="A *NO* answer will abort the install process."
+12 DO ^DIR
+13 WRITE !
+14 ;
+15 ; If BACKUP not performed, then ABORT installation.
IF +$GET(Y)'=1
QUIT $$NOBACKUP()
+16 ;
+17 ; DEBUG will *NOT* store Backup Confirmation data.
IF +$GET(DEBUG)
QUIT $$OKBACKUP()
+18 ;
+19 ; Store backup confirmation person & date/time
+20 SET BCKUPCNT=1+$ORDER(^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",0),-1)
+21 SET ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT)=$PIECE($GET(^VA(200,DUZ,0)),U)
+22 SET ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT,"DUZ")=DUZ
+23 SET ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT,"DATE/TIME")=$$HTE^XLFDT($HOROLOG,"5MZ")
+24 ;
+25 QUIT $$OKBACKUP()
+26 ;
OKBACKUP() ; EP - Backup Confirmed.
+1 DO BLANK
+2 DO OKAY^BLRKIDSU("SUCCESSFUL system backup CONFIRMED by: "_$$GET1^DIQ(200,DUZ,"NAME")_".",5)
+3 IF +$GET(DEBUG)
Begin DoDot:1
+4 DO BLANK
+5 DO TABMENU^BLRKIDSU("DEBUG will **NOT** Store Backup Confirmation.",10)
End DoDot:1
+6 ;
+7 ; Pause to let the user see the message.
HANG 2
+8 QUIT "OK"
+9 ;
NOBACKUP() ; EP - No backup message
+1 SET XPDABORT=1
+2 DO PASSMESG^BLRKIDS2("ATTENTION")
+3 DO TABMESG^BLRKIDSU("SUCCESSFUL system backup has >>> NOT <<< been confirmed.",15)
+4 DO TABMESG^BLRKIDSU("Installer: "_$$GET1^DIQ(200,DUZ,"NAME")_" ["_DUZ_"].",25)
+5 DO TABMESG^BLRKIDSU("Install Aborting.",15)
+6 ; Pause to let the user see the message.
HANG 2
+7 QUIT "Q"
+8 ;
DEBUG ; EP - Debugging Line Label for environment checker
+1 NEW BEGTIME,BLRVERN,CP,CPSTR,DEBUG,ENDTIME,ERRARRAY,LASTLOGI
+2 NEW LRBLNOW,PATCHNUM,PREREQ,QFLG,ROWSTARS,RPMS,RPMSVER,STR
+3 NEW SUCCSTR,TODAY,WHATCNT,WOTCNT,XPDABORT,XPDENV,XPDNM
+4 ;
+5 ; NOTE: DEBUG will not store "Backup" data.
+6 ;
+7 DO SETEVARS
+8 ;
+9 WRITE !!
+10 WRITE "Debug Routine ",BLRVERN," Begins:",!!
+11 ;
+12 ; Don't Send Alerts
SET DEBUG=1
+13 ;
+14 WRITE !
+15 SET XPDNM=CPSTR
+16 SET (XPDENV,XPDABORT)=0
+17 ;
+18 DO PRE
+19 IF XPDABORT
QUIT
+20 ;
+21 WRITE !!!
+22 ;
+23 DO ^XBFMK
+24 SET DIR(0)="YO"
+25 SET DIR("B")="NO"
+26 SET DIR("A")="Test Post Install Code"
+27 DO ^DIR
+28 ;
+29 IF +$GET(Y)=1
DO POST
+30 ;
+31 WRITE !!,"Debug Routine ",BLRVERN," Ends.",!!
+32 QUIT
+33 ;
POST ; EP - Post-Install
+1 NEW BLRVERN,BLRVERN2,CP,CPSTR,PATCHNUM,TODAY,WOTCNT
+2 ;
+3 DO SETEVARS
+4 ;
+5 DO BLANK
+6 DO BMES^XPDUTL("Laboratory Patch "_CPSTR_" POST INSTALL begins at "_$$UP^XLFSTR($$HTE^XLFDT($HOROLOG,"5MPZ"))_".")
+7 DO BLANK
+8 ;
+9 SET TODAY=$$DT^XLFDT
+10 SET WOTCNT=$$WOTCNT(BLRVERN)
+11 ;
+12 ; Add new options to BLRMENU
DO ADDOPTS
+13 ;
+14 ; VBECS Update
DO VBECSUPD
+15 ;
+16 ; Force new parameters to NO
DO FORCENO
+17 ;
+18 ; Add Descriptions to 3 Mail Groups
DO ADDDESC
+19 ;
+20 IF $LENGTH($GET(^DD(90475.8,0,"VR")))<1
Begin DoDot:1
+21 SET FORCEDD="^DD(90475.8,0,""VR"")"
+22 ; Force Version Number into Data Dictionary.
SET @FORCEDD=5.2
+23 SET FORCEDD="^DD(90475.8,0,""VRPK"")"
+24 ; Force Lab Link into Data Dictionary.
SET @FORCEDD="LR"
End DoDot:1
+25 ;
+26 DO BLANK
+27 DO BMES^XPDUTL("Laboratory Patch "_CPSTR_" POST INSTALL ends at "_$$UP^XLFSTR($$HTE^XLFDT($HOROLOG,"5MPZ"))_".")
+28 DO BLANK
+29 ;
+30 DO POSTMAIL(BLRVERN,CPSTR)
+31 ;
+32 SET ^XTMP(BLRVERN,TODAY,WOTCNT,"END")=$$NOW^XLFDT
+33 QUIT
+34 ;
ADDOPTS ; EP - Add new options
+1 DO ADDOPTS^BLRKIDS2("BLRMENU","BLR PARMETERS AND MAIL GROUPS","PAMG")
+2 DO ADDOPTS^BLRKIDS2("BLRMENU","BLROLOR","ORDO")
+3 ; D ADDOPTS^BLRKIDS2("BLRMENU","BLRPURGU","PURG")
+4 DO ADDOPTS^BLRKIDS2("LRSUPERVISOR","BLRPURGU","PURR")
+5 DO ADDOPTS^BLRKIDS2("BLRMENU","BLR PATIENT REMINDER DOCUMENT","PDOC")
+6 DO ADDOPTS^BLRKIDS2("BLRMENU","BLRERRTR","ERRT")
+7 QUIT
+8 ;
FORCENO ; EP - Force new parameters to be NO
+1 NEW (DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETBLRVS
+4 IF '$$GETPARS(.PARSLIST)
QUIT
+5 ;
+6 ; If DEBUG, just print messages & quit
IF +$GET(DEBUG)
Begin DoDot:1
+7 SET TAB=$JUSTIFY("",10)
+8 DO BLANK
DO OKAY^BLRKIDSU("DEBUG: FORCENO^"_BLRVERN,4)
+9 SET PARAMETER=""
+10 FOR
SET PARAMETER=$ORDER(PARSLIST(PARAMETER))
IF PARAMETER=""
QUIT
Begin DoDot:2
+11 DO MES^XPDUTL(TAB_"DEBUG will *NOT* modify "_PARAMETER_" parameter.")
End DoDot:2
End DoDot:1
QUIT
+12 ;
+13 SET PARAMETER=""
+14 FOR
SET PARAMETER=$ORDER(PARSLIST(PARAMETER))
IF PARAMETER=""
QUIT
Begin DoDot:1
+15 KILL ERRS
+16 DO EN^XPAR("PKG",PARAMETER,,"NO",.ERRS)
+17 IF +$GET(ERRS)
Begin DoDot:2
+18 DO BLANK
DO MES^XPDUTL(PARAMETER_" parameter not modified.")
DO BLANK
+19 DO STORERRS^BLREMERA(ERRS,PARAMETER)
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
GETPARS(PARSLIST) ; EP - Function to get Parameters from BUILD file
+1 NEW (DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PARSLIST,U,XPARSYS,XQXFLG)
+2 ;
+3 DO SETEVARS
+4 ;
+5 SET BUILDIEN=$$FIND1^DIC(9.6,,,CPSTR)
+6 IF BUILDIEN<1
QUIT 0
+7 ;
+8 SET PARAMTRS=""
SET CNT=0
+9 FOR
SET PARAMTRS=$ORDER(^XPD(9.6,BUILDIEN,"KRN",8989.51,"NM","B",PARAMTRS))
IF PARAMTRS=""
QUIT
Begin DoDot:1
+10 SET PARSLIST(PARAMTRS)=""
SET CNT=CNT+1
End DoDot:1
+11 ;
+12 QUIT CNT
+13 ;
+14 ;
SAVEOFF ; EP - Save off all routines being updated by this patch into the ^rBACKUP global.
+1 NEW (DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 ; If not Cache, cannot use ^%R
IF $GET(^%ZOSF("OS"))'["OpenM"
QUIT
+4 ;
+5 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+6 ;
+7 ; If DEBUG, just print messages & quit
IF +$GET(DEBUG)
Begin DoDot:1
+8 SET TAB=$JUSTIFY("",10)
+9 DO BLANK
DO OKAY^BLRKIDSU("DEBUG: SAVEOFF^"_BLRVERN,4)
+10 DO BMES^XPDUTL(TAB_"DEBUG does *NOT* Save off routines.")
End DoDot:1
QUIT
+11 ;
+12 SET PATCH=$PIECE($TEXT(+2),"*",3)
+13 SET BUILD="LR*5.2*"_PATCH
+14 ; Get the most current Patch IEN
SET PATCHIEN=+$ORDER(^XPD(9.6,"B",BUILD,"A"),-1)
+15 ; If not in BUILD file, skip
IF PATCHIEN<1
QUIT
+16 ;
+17 DO BMES^XPDUTL("Backing up routines.")
+18 SET RTN=""
SET (CNT,RTNCNT)=0
+19 FOR
SET RTN=$ORDER(^XPD(9.6,PATCHIEN,"KRN",9.8,"NM","B",RTN))
IF RTN=""
QUIT
Begin DoDot:1
+20 SET RTNPATCH=+$REVERSE($PIECE($REVERSE($TRANSLATE($PIECE($GET(^ROUTINE(RTN,0,2)),";",5),"*")),","))
+21 ; If RTN not in the ^ROUTINE global, skip
IF RTNPATCH<1
QUIT
+22 ; Only versions < this patch
IF RTNPATCH'<PATCH
QUIT
+23 ;
+24 SET RTNCNT=RTNCNT+1
+25 KILL ERRS,RTNA
+26 FOR LN=0:1:$GET(^ROUTINE(RTN,0,0))
SET RTNA(LN)=$GET(^ROUTINE(RTN,0,LN))
+27 SET X=$$ROUTINE^%R(RTN_".INT",.RTNA,.ERRS,"CSB")
+28 SET NOW=$HOROLOG
+29 SET ^BLRINSTL("LAB PATCH",PATCH,"SAVEOFF",NOW)=$$HTE^XLFDT(NOW,"5MZ")
+30 SET ^BLRINSTL("LAB PATCH",PATCH,"SAVEOFF",NOW,RTN)=$SELECT($DATA(ERRS)>1:"ERRORS",1:"OK")
+31 IF $DATA(ERRS)'>1
Begin DoDot:2
+32 DO OKAY^BLRKIDSU("Routine "_RTN_" backed up.",4)
+33 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+34 ;
+35 IF RTNCNT
Begin DoDot:1
+36 SET TAB=$JUSTIFY("",5)
+37 DO BMES^XPDUTL(TAB_RTNCNT_" routines analyzed.")
+38 DO BMES^XPDUTL(TAB_TAB_CNT_" routines backed up.")
End DoDot:1
+39 QUIT
+40 ;
+41 ;
VBECSUPD ; EP - VBECS Update
+1 NEW (DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 ; If not Cache, cannot use ^%R
IF $GET(^%ZOSF("OS"))'["OpenM"
QUIT
+4 ;
+5 DO SETBLRVS
+6 ;
+7 SET RTN="VB"
SET CNT=0
+8 FOR
SET RTN=$ORDER(^ROUTINE(RTN))
IF RTN=""!($EXTRACT(RTN,1,2)'="VB")
QUIT
Begin DoDot:1
+9 SET X=$$DEL^%R(RTN_".INT")
+10 SET X=$$DEL^%R(RTN_".OBJ")
+11 SET CNT=CNT+1
End DoDot:1
+12 ;
+13 IF CNT<1
QUIT
+14 ;
+15 IF $DATA(^XTMP(BLRVERN,0))<1
DO XTMPHEAD
+16 SET ^XTMP(BLRVERN,$JOB,"VBECSUPD")=CNT_" VBECS routines removed during Post Install."
+17 QUIT
+18 ;
ADDDESC ; EP - Add Descriptons to 3 Mail Groups, if and only if they are currently blank
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO ADDLMI
+4 DO ADDBLRL
+5 DO ADDLABT
+6 QUIT
+7 ;
ADDLMI ; EP - Add description to LMI Mail Group
+1 NEW WPARRAY
+2 ;
+3 SET WPARRAY("WP")=""
+4 SET WPARRAY("WP",1)="Laboratory Management Mail Group to receive anomalous and/or descriptive"
+5 SET WPARRAY("WP",2)="messages from the Lab subsystem."
+6 ;
+7 DO STORDESC("LMI",.WPARRAY)
+8 QUIT
+9 ;
ADDBLRL ; EP - Add Description to BLRLINK Mail Group
+1 NEW WPARRAY
+2 ;
+3 SET WPARRAY("WP")=""
+4 SET WPARRAY("WP",1)="Mail Group to receive Lab to PCC linker issues and/or"
+5 SET WPARRAY("WP",2)="descriptive messages."
+6 ;
+7 DO STORDESC("BLRLINK",.WPARRAY)
+8 QUIT
+9 ;
ADDLABT ; EP - Add Description to LAB TECHS Mail Group
+1 NEW WPARRAY
+2 ;
+3 SET WPARRAY("WP")=""
+4 SET WPARRAY("WP",1)="Laboratory Techs."
+5 ;
+6 DO STORDESC("LAB TECHS",.WPARRAY)
+7 QUIT
+8 ;
STORDESC(MGRP,WPARRAY) ; EP - Store description into Mail Group file
+1 NEW LMGIEN
+2 ;
+3 DO ^XBFMK
+4 ; Skip if cannot determine Mail Group IEN
SET LMGIEN=+$$FIND1^DIC(3.8,,"O",MGRP)
+5 ;
+6 ; Skip if description already exists
IF $LENGTH($$GET1^DIQ(3.801,"1,"_LMGIEN,.01))
QUIT
+7 ;
+8 DO ^XBFMK
+9 KILL ERRS
+10 DO WP^DIE(3.8,LMGIEN_",",3,"K","WPARRAY(""WP"")","ERRS")
+11 IF '$DATA(ERRS)
DO OKAY^BLRKIDSU("Added Description to "_MGRP_" Mail Group.",5)
QUIT
+12 ;
+13 DO TABMESG^BLRKIDSU("Could Not Add Description to "_MGRP_" Mail Group.",10)
+14 QUIT
+15 ;
+16 ;
+17 ; ========================= UTILITIES FOLLOW ==========================
+18 ;
SETEVARS ; EP - SET standard "Enviroment" VARiables.
+1 SET (CP,PATCHNUM)=$PIECE($TEXT(+2),"*",3)
+2 SET CPSTR="LR*5.2*"_CP
+3 DO SETBLRVS
+4 QUIT
+5 ;
SETBLRVS(TWO) ; EP - Set the BLRVERN variable(s)
+1 KILL BLRVERN,BLRVERN2
+2 ;
+3 SET BLRVERN=$PIECE($PIECE($TEXT(+1),";")," ")
+4 IF $LENGTH($GET(TWO))
SET BLRVERN2=$GET(TWO)
+5 QUIT
+6 ;
XTMPHEAD ; EP - Initialize XTMP for this patch
+1 NEW BLRVERN,BLRVERN2,PTCHNAME
+2 DO SETBLRVS
+3 SET PTCHNAME=$$TRIM^XLFSTR($PIECE($PIECE($PIECE($TEXT(+1),";",2),"-",2),"Pre"),"LR"," ")
+4 SET ^XTMP(BLRVERN,0)=$$FMADD^XLFDT($$DT^XLFDT,30)_U_$$DT^XLFDT_U_PTCHNAME
+5 QUIT
+6 ;
BLANK ; EP - Blank Line
+1 DO MES^XPDUTL("")
+2 QUIT
+3 ;
MESCNTR(STR) ; EP - Center a line and use XPDUTL to display it
+1 DO MES^XPDUTL($$CJ^XLFSTR(STR,IOM))
+2 QUIT
+3 ;
WOTCNT(BLRVERN) ; EP - Counter for ^XTMP
+1 NEW CNT,TODAY
+2 ;
+3 SET TODAY=$$DT^XLFDT
+4 ;
+5 SET CNT=1+$GET(^XTMP(BLRVERN,0,TODAY))
+6 SET ^XTMP(BLRVERN,0,TODAY)=CNT
+7 QUIT $TRANSLATE($JUSTIFY(CNT,3)," ","0")
+8 ;
INITSCR ; EP - Initialize screen. Cloned from INIT^XPDID
+1 NEW X,XPDSTR
+2 IF IO'=IO(0)!(IOST'["C-VT")
SET XPDIDVT=0
QUIT
+3 IF $TEXT(PREP^XGF)=""
SET XPDIDVT=0
QUIT
+4 DO PREP^XGF
+5 SET XPDIDVT=1
SET X="IOSTBM"
SET XPDSTR=""
+6 DO ENDR^%ZISS
+7 SET IOTM=3
SET IOBM=IOSL-4
+8 WRITE @IOSTBM
+9 ; Top line
DO FRAME^XGF(IOTM-2,0,IOTM-2,IOM-1)
+10 ; D FRAME^XGF(IOBM+1,0,IOBM+1,IOM-1) ; Bottom line
+11 DO IOXY^XGF(IOTM-2,0)
+12 QUIT
+13 ;
POSTMAIL(BLRVERN,CPSTR) ; EP - Post Install MailMan Message
+1 ; No MailMan messages during debugging
IF +$GET(DEBUG)
QUIT
+2 ;
+3 NEW STR
+4 ;
+5 SET STR(1)=" "
+6 SET STR(2)=$JUSTIFY("",10)_"POST INSTALL of "_BLRVERN_" Routine."
+7 SET STR(3)=" "
+8 SET STR(4)=$JUSTIFY("",15)_"Laboratory Patch "_CPSTR_" INSTALL completed."
+9 SET STR(5)=" "
+10 ;
+11 ; Send E-Mail to LMI Mail Group & Installer
+12 DO MAILALMI^BLRUTIL3("Laboratory Patch "_CPSTR_" INSTALL complete.",.STR,BLRVERN)
+13 ;
+14 QUIT
