BLRPRE34 ; IHS/OIT/MKK - IHS Lab PATCH 1034 Environment/Pre/Post Install Routine ; 17-Oct-2014 09:22 ; MKK
;;5.2;IHS LABORATORY;**1034**;NOV 01, 1997;Build 88
;
ENVCHK ; EP
D BMES^XPDUTL("Beginning of Pre Check.")
D MES^XPDUTL("")
NEW CP,LINE2,RPMS,RPMSVER,STR
NEW LASTPTCH ; Last Patch of Lab
NEW LSTPISTS ; Last Patch Install Status
NEW WOTERR ; Array of errors detected
;
I $G(XPDNM)="" D SORRY("XPDNM not defined or 0.",,,1034) Q
;
S LINE2=$T(+2) ; Second line of THIS Routine
;
D OKAY^BLRKIDSU("XPDNM Defined.",5)
;
S CP=$P(XPDNM,"*",3) ; Current Patch Number
S RPMS=$P(XPDNM,"*",1) ; RPMS Module
S RPMSVER=$P(XPDNM,"*",2) ; Version of RPMS module being patched
;
S XPDNOQUE="NO QUE" ; No Queuing Allowed
;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
I $G(XPDENV)=1 F X="XPO1","XPZ1","XPZ2","XPI1" S XPDDIQ(X)=0
;
S XPDABORT=0 ; Initialize ABORT flag to NO
;
USERID ; EP - CHECK FOR USER ID
NEW USERNAME
;
I '$G(DUZ) D SORRY("DUZ UNDEFINED OR 0.",,,CP) Q
;
I '$L($G(DUZ(0))) D SORRY("DUZ(0) UNDEFINED OR NULL.",,,CP) Q
;
S USERNAME=$$GET1^DIQ(200,DUZ,"NAME")
I $L(USERNAME)<1 D SORRY^BLRKIDSU("Installer [DUZ:"_DUZ_"] cannot be identified!",,,CP) Q
;
D OKAY^BLRKIDSU("Installer: "_USERNAME_" ["_DUZ_"].",5)
;
D HOME^%ZIS ; IO Defaults
D DTNOLF^DICRW ; Set DT variable without Doing a Line Feed
;
D BMES^XPDUTL("Pre Check complete.")
;
LETSGO ; EP - USER IDENTIFIED -- LET'S GO
D BMES^XPDUTL("Checking Environment for Patch "_CP_" of Version "_RPMSVER_" of "_RPMS_".")
D MES^XPDUTL(" ")
;
D NEEDIT^BLRPRE31(CP,"AICD","4.0",,.ERRARRY) ; IHS ICD/CPT Lookup & Grouper ICD-10 Version
D NEEDIT^BLRPRE31(CP,"LR","5.2","1033",.ERRARRY) ; Lab Patch Pre-Requisite
;
I XPDABORT D SORRYEND^BLRKIDSU(.WOTERR,CP)
E D BMES^XPDUTL("ENVIRONMENT OK.") D MES^XPDUTL("")
;
Q
;
BACKUP ; EP
NEW CP ; Current Patch
S CP=$TR($P($T(+2),";",5),"*")
;
D PASSMESG^BLRPRE31("ATTENTION")
W !
;
D ^XBFMK
S DIR(0)="Y"
S DIR("B")="NO"
S DIR("A")=$J("",10)_"Has a >> SUCCESSFUL << backup been performed?"
D ^DIR
W !
;
I +$G(Y)'=1 D Q ; If BACKUP not performed, then ABORT installation.
. S XPDABORT=1
. D PASSMESG^BLRPRE31("ATTENTION")
. D BMES^XPDUTL($J("",15)_"SUCCESSFUL system backup has >>> NOT <<< been confirmed.")
. D BMES^XPDUTL($J("",25)_"Installer: "_$$GET1^DIQ(200,DUZ,"NAME")_" ["_DUZ_"].")
. D BMES^XPDUTL($J("",15)_"Install Aborting.")
. H 1 ; Pause 1 second to let the user see the message.
;
I +$G(DEBUG) D Q
. D BOKAY^BLRPRE31("SUCCESSFUL system backup CONFIRMED by: "_$$GET1^DIQ(200,DUZ,"NAME")_".",5)
. D OKAY^BLRKIDSU("DEBUG in process. No Data Stored.",10)
. H 1 ; Pause 1 second to let the user see the message.
;
; 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 BOKAY^BLRPRE31("SUCCESSFUL system backup CONFIRMED by: "_$$GET1^DIQ(200,DUZ,"NAME")_".",5)
H 1 ; Pause 1 second to let the user see the message.
Q
;
POST ; EP -- POST INSTALL
NEW BLRVERN,CP,STR
;
S CP=$TR($P($T(+2),";",5),"*") ; Current Patch
S BLRVERN=$TR($P($T(+1),";")," ") ; Routine Name
;
D CLEANSET^BLRICDO ; Creates BLRICDO global
;
D ADDOPTS("BLRMENU","BLROTSCH","REPL")
D ADDOPTS("BLRMENU","BLRLROS","LROS")
D CHNGOPTT("LROE","Accessioning tests ordered by provider order entry")
D BMXPO ; Add RPCs to Option
D UPGIS ; Change Labcorp DG1.2 to @DG12LABO
;
D LABJRNL ; Get rid of extraneous LAB JOURNAL pointers in file 61.2
;
D BMES^XPDUTL("Need to Reset Ref Lab Accession X-Ref Global.")
K ^XTMP("BLRLINKU")
D REFLAB68^BLRLINKU ; Reset Ref Lab Accession X-Ref Global
D OKAY^BLRKIDSU("Ref Lab Accession X-Ref Global Reset.")
;
D BMES^XPDUTL("Laboratory Patch "_CP_" INSTALL complete.")
;
; The VistA Lab's Emerging Pathogen Initiative module is not used
; by IHS. Inactivate the options so that users do not, inadvertantly,
; go into any of the EPI menus.
D INACTOPT("LREP","Lab EPI Module Not Used by IHS","LREPILK")
;
; Store # of times installation occurred as well as person & date/time
D ENDINSTL^BLRKIDSU(CP)
;
Q:+$G(DEBUG)
;
S STR(1)=" "
S STR(2)=$J("",10)_"POST INSTALL of "_BLRVERN_" Routine."
S STR(3)=" "
S STR(4)=$J("",15)_"Laboratory Patch "_CP_" INSTALL completed."
S STR(5)=" "
;
; Send Alert & E-Mail to LMI Mail Group & Installer
D MAILALMI^BLRUTIL3("Laboratory Patch "_CP_" INSTALL complete.",.STR,BLRVERN)
Q
;
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 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.")
I X'=1 D
. D BMES^XPDUTL(TAB_"Error in adding '"_OPTION_"' option to "_TOMENU_".")
. D MES^XPDUTL(TAB_TAB_"Error Message: "_$$UP^XLFSTR($P(X,"^",2)))
;
D MES^XPDUTL("")
Q
;
BMXPO ;-- update the RPC file
N BLRRPC
S BLRRPC=$O(^DIC(19,"B","BLRRLRPC",0))
Q:'BLRRPC
D CLEAN(BLRRPC)
D GUIEP^BMXPO(.RETVAL,BLRRPC_"|BLR")
Q
;
CLEAN(APP) ;-- clean out the RPC multiple first
S DA(1)=APP
S DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
N BLRDA
S BLRDA=0 F S BLRDA=$O(^DIC(19,APP,"RPC",BLRDA)) Q:'BLRDA D
. S DA=BLRDA
. D ^DIK
K ^DIC(19,APP,"RPC","B")
Q
;
UPGIS ;-- update the GIS definition
N BLRX,BLRM
S BLRX=$O(^INTHL7F("B","HL IHS LAB ORM DG1-2 LC",0))
Q:'BLRX
S ^INTHL7F(BLRX,"C")="@DG12LABO"
S BLRM=$O(^INTHL7M("B","HL IHS LAB O01 LABCORP",0))
Q:'BLRM
D COMPILE^BHLU(BLRM)
Q
;
DEONARDY(TOMENU,OPTION,SYNONYM) ; EP
; 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)
;
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
;
LABJRNL ; EP - Get rid of pointers in file 61.2 that point to an empty File 95.
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:+$O(^LAB(95,0)) ; If there is data in file 95, don't do anything
;
S CNT=0,IEN=.9999999
F S IEN=$O(^LAB(61.2,IEN)) Q:IEN<1 D
. S JOURN=0 F S JOURN=$O(^LAB(61.2,IEN,"JR",JOURN)) Q:JOURN<1 D
.. S CNT=CNT+1
.. I CNT=1 D
... S ^XTMP("LABJRNAL",0)=$$HTFM^XLFDT(+$H+365)_"^"_$$DT^XLFDT_"^Entries In File 61.2 that Pointed to (Empty) File 95"
... D BMES^XPDUTL("There are entries In File 61.2 that Point to (Empty) LAB JOURNAL (#95) File.")
.. S ^XTMP("LABJRNAL","61.2","IEN",IEN)=""
.. M ^XTMP("LABJRNAL","61.2","IEN",IEN,"JOURN",JOURN)=^LAB(61.2,IEN,"JR",JOURN)
.. D TABMENU^BLRKIDSU("File 61.2 IEN:"_IEN_"; JOURN IEN:"_JOURN)
.. D TABMENU^BLRKIDSU("File 61.2 Journal Reference:"_$G(^LAB(61.2,IEN,"JR",JOURN,0)),10)
.. ;
.. K DA
.. S DA(1)=IEN,DA=JOURN
.. S DIK="^LAB(61.2,"_DA(1)_",""JR"","
.. D ^DIK
;
S:CNT ^XTMP("LABJRNAL","61.2")=CNT
Q
;
DEBUG ; EP - Debugging Line Label for environment checker
NEW CP,DEBUG,LINE2,ROWPLUS,ROWSTARS,XPDNM
S DEBUG=1
S XPDNM="LR*5.2*1034"
;
S ROWSTARS=$TR($J("",IOM)," ","*")
S ROWPLUS=$TR($J("",IOM)," ","+")
;
D ^XBCLS,PASSMESG^BLRPRE31("DEBUG: ENVCHK Check")
;
D ENVCHK^BLRPRE34
;
W !!,"DEBUG: ENVCHK^BLRPRE34 Completed."
W !!,ROWPLUS
D PRESSKEY^BLRGMENU
;
D ^XBCLS,PASSMESG^BLRPRE31("DEBUG: BACKUP Check.")
D BACKUP^BLRPRE34
W !!,"DEBUG: BACKUP^BLRPRE34 Completed.",!
W !,ROWPLUS
D PRESSKEY^BLRGMENU
;
D ^XBCLS,PASSMESG^BLRPRE31("DEBUG: POST Check")
D POST^BLRPRE34
W !!,"DEBUG: POST^BLRPRE34 Completed."
W !!,ROWPLUS
D PRESSKEY^BLRGMENU
;
D ^XBCLS,PASSMESG^BLRPRE31("DEBUG: COMPLETED")
D PRESSKEY^BLRGMENU
Q
;
LASTPTCH(CP) ; EP
NEW COMPFLAG,COMPPTCH,LASTPTCH,LRPATCH,LPIEN,STR
;
S LASTPTCH=CP-1
;
D BMES^XPDUTL("Need at least IHS Lab Patch "_LASTPTCH)
;
S LRPATCH="LR*5.2*1099",COMPFLAG="NO"
F S LRPATCH=$O(^XPD(9.7,"B",LRPATCH),-1) D Q:LRPATCH=""!(COMPFLAG="YES")!($E(LRPATCH,1,2)'="LR")!($P(LRPATCH,"*",3)<LASTPTCH)
. S LPIEN=$O(^XPD(9.7,"B",LRPATCH,""),-1)
. I $P($G(^XPD(9.7,+$G(LPIEN),0)),"^",9)=3 S COMPFLAG="YES",COMPPTCH=LRPATCH
;
I COMPFLAG'="YES"!($P(COMPPTCH,"*",3)<LASTPTCH) D Q "NOT OK"
. D SORRY("Need at least IHS Lab Patch "_LASTPTCH,,"Latest IHS Lab Patch Found is "_COMPPTCH_".",CP)
;
D OKAY^BLRKIDSU("IHS Lab Patch "_LASTPTCH_" Installed.",10)
;
Q "OK"
;
SORRY(MSG,MODE,MSG2,CP) ; EP
; Error Message routine. It will send an ALERT and a MailMan message
; to the people who are assigned to the LMI Mail group.
;
; The STR array is built so that the error/warning message will
; also appear on the INSTALL LOG via the D BMES^XPDUTL(.STR) call.
;
NEW MESSAGE
I $G(MODE)'["NONFATAL" 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
;
NEW STR,LINECNT
S LINECNT=1
D ADDLINE(" ",.LINECNT)
D ADDLINE($TR($J("",65)," ","*"),.LINECNT) ; Row of asterisks
D ADDLINE(" ",.LINECNT)
D ADDLINE($$CJ^XLFSTR("Site: "_$$LOC^XBFUNC,65),.LINECNT)
D ADDLINE(" ",.LINECNT)
D ADDLINE($$CJ^XLFSTR(MESSAGE,65),.LINECNT)
D ADDLINE(" ",.LINECNT)
D ADDLINE($$CJ^XLFSTR(">>> "_MSG_" <<<",65),.LINECNT)
I $D(MSG2) D ADDLINE($$CJ^XLFSTR(">>> "_MSG2_" <<<",65),.LINECNT)
D ADDLINE(" ",.LINECNT)
;
I $G(MODE)["NONFATAL" D ADDLINE($$CJ^XLFSTR(MESSAGE,65),.LINECNT)
;
I $G(MODE)'["NONFATAL" D
. D ADDLINE($$CJ^XLFSTR("Please print/capture this screen and",65),.LINECNT)
. D ADDLINE($$CJ^XLFSTR("notify the Support Center at",65),.LINECNT)
. D ADDLINE(" ",.LINECNT)
. D ADDLINE($$CJ^XLFSTR("1-888-830-7280.",65),.LINECNT)
. D ADDLINE(" ",.LINECNT)
;
D ADDLINE($TR($J("",65)," ","*"),.LINECNT) ; Row of asterisks
D ADDLINE(" ",.LINECNT)
;
D BMES^XPDUTL(.STR) ; Display the message
;
Q:+$G(DEBUG) ; Skip if DEBUG
;
I '$G(DUZ)!('$L($G(DUZ(0)))) Q ; Skip if no DUZ
;
Q:$$FIND1^DIC(3.8,,,"LMI")<1 ; Skip if no LMI Mail group
;
I $G(MODE)="FATAL" D MAILALMI^BLRUTIL3("IHS Lab Patch "_CP_" Install FATAL Error",.STR,"BLRPRE34")
I $G(MODE)="NONFATAL" D MAILALMI^BLRUTIL3("IHS Lab Patch "_CP_" Install NONFATAL Error",.STR,"BLRPRE34")
;
Q
;
ADDLINE(ASTR,LC) ; EP
; Add a line to the STR array
I $G(ASTR)="" S ASTR=" "
S STR(LC)=ASTR
S LC=LC+1
Q
;
CHNGOPTT(OPTION,TEXT) ; EP - Change the MENU Text of an Option
NEW ERRS,FDA,OLDMTEXT,OPTIEN
;
S OPTIEN=$$FIND1^DIC(19,,,OPTION)
Q:OPTIEN<1 ; Skip if cannot determine OPTION's IEN in file 19
;
S OLDMTEXT=$$GET1^DIQ(19,OPTIEN,"MENU TEXT")
;
D BMES^XPDUTL("Attempting to modify MENU TEXT on Option "_OPTION_" from")
D MES^XPDUTL($J("",10)_$E(OLDMTEXT,1,50))
D MES^XPDUTL(" to")
D MES^XPDUTL($J("",10)_$E(TEXT,1,50))
;
S FDA(19,OPTIEN_",",1)=TEXT
D UPDATE^DIE("SE","FDA",,"ERRS")
D MES^XPDUTL("")
I $D(ERRS)<1 D OKAY^BLRKIDSU("MENU TEXT modified.")
I $D(ERRS) D MES^XPDUTL(" MENU TEXT was *NOT* modified.")
Q
BLRPRE34 ; IHS/OIT/MKK - IHS Lab PATCH 1034 Environment/Pre/Post Install Routine ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1034**;NOV 01, 1997;Build 88
+2 ;
ENVCHK ; EP
+1 DO BMES^XPDUTL("Beginning of Pre Check.")
+2 DO MES^XPDUTL("")
+3 NEW CP,LINE2,RPMS,RPMSVER,STR
+4 ; Last Patch of Lab
NEW LASTPTCH
+5 ; Last Patch Install Status
NEW LSTPISTS
+6 ; Array of errors detected
NEW WOTERR
+7 ;
+8 IF $GET(XPDNM)=""
DO SORRY("XPDNM not defined or 0.",,,1034)
QUIT
+9 ;
+10 ; Second line of THIS Routine
SET LINE2=$TEXT(+2)
+11 ;
+12 DO OKAY^BLRKIDSU("XPDNM Defined.",5)
+13 ;
+14 ; Current Patch Number
SET CP=$PIECE(XPDNM,"*",3)
+15 ; RPMS Module
SET RPMS=$PIECE(XPDNM,"*",1)
+16 ; Version of RPMS module being patched
SET RPMSVER=$PIECE(XPDNM,"*",2)
+17 ;
+18 ; No Queuing Allowed
SET XPDNOQUE="NO QUE"
+19 ;
+20 ; The following line prevents the "Disable Options..." and "Move
+21 ; Routines..." questions from being asked during the install.
+22 IF $GET(XPDENV)=1
FOR X="XPO1","XPZ1","XPZ2","XPI1"
SET XPDDIQ(X)=0
+23 ;
+24 ; Initialize ABORT flag to NO
SET XPDABORT=0
+25 ;
USERID ; EP - CHECK FOR USER ID
+1 NEW USERNAME
+2 ;
+3 IF '$GET(DUZ)
DO SORRY("DUZ UNDEFINED OR 0.",,,CP)
QUIT
+4 ;
+5 IF '$LENGTH($GET(DUZ(0)))
DO SORRY("DUZ(0) UNDEFINED OR NULL.",,,CP)
QUIT
+6 ;
+7 SET USERNAME=$$GET1^DIQ(200,DUZ,"NAME")
+8 IF $LENGTH(USERNAME)<1
DO SORRY^BLRKIDSU("Installer [DUZ:"_DUZ_"] cannot be identified!",,,CP)
QUIT
+9 ;
+10 DO OKAY^BLRKIDSU("Installer: "_USERNAME_" ["_DUZ_"].",5)
+11 ;
+12 ; IO Defaults
DO HOME^%ZIS
+13 ; Set DT variable without Doing a Line Feed
DO DTNOLF^DICRW
+14 ;
+15 DO BMES^XPDUTL("Pre Check complete.")
+16 ;
LETSGO ; EP - USER IDENTIFIED -- LET'S GO
+1 DO BMES^XPDUTL("Checking Environment for Patch "_CP_" of Version "_RPMSVER_" of "_RPMS_".")
+2 DO MES^XPDUTL(" ")
+3 ;
+4 ; IHS ICD/CPT Lookup & Grouper ICD-10 Version
DO NEEDIT^BLRPRE31(CP,"AICD","4.0",,.ERRARRY)
+5 ; Lab Patch Pre-Requisite
DO NEEDIT^BLRPRE31(CP,"LR","5.2","1033",.ERRARRY)
+6 ;
+7 IF XPDABORT
DO SORRYEND^BLRKIDSU(.WOTERR,CP)
+8 IF '$TEST
DO BMES^XPDUTL("ENVIRONMENT OK.")
DO MES^XPDUTL("")
+9 ;
+10 QUIT
+11 ;
BACKUP ; EP
+1 ; Current Patch
NEW CP
+2 SET CP=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+3 ;
+4 DO PASSMESG^BLRPRE31("ATTENTION")
+5 WRITE !
+6 ;
+7 DO ^XBFMK
+8 SET DIR(0)="Y"
+9 SET DIR("B")="NO"
+10 SET DIR("A")=$JUSTIFY("",10)_"Has a >> SUCCESSFUL << backup been performed?"
+11 DO ^DIR
+12 WRITE !
+13 ;
+14 ; If BACKUP not performed, then ABORT installation.
IF +$GET(Y)'=1
Begin DoDot:1
+15 SET XPDABORT=1
+16 DO PASSMESG^BLRPRE31("ATTENTION")
+17 DO BMES^XPDUTL($JUSTIFY("",15)_"SUCCESSFUL system backup has >>> NOT <<< been confirmed.")
+18 DO BMES^XPDUTL($JUSTIFY("",25)_"Installer: "_$$GET1^DIQ(200,DUZ,"NAME")_" ["_DUZ_"].")
+19 DO BMES^XPDUTL($JUSTIFY("",15)_"Install Aborting.")
+20 ; Pause 1 second to let the user see the message.
HANG 1
End DoDot:1
QUIT
+21 ;
+22 IF +$GET(DEBUG)
Begin DoDot:1
+23 DO BOKAY^BLRPRE31("SUCCESSFUL system backup CONFIRMED by: "_$$GET1^DIQ(200,DUZ,"NAME")_".",5)
+24 DO OKAY^BLRKIDSU("DEBUG in process. No Data Stored.",10)
+25 ; Pause 1 second to let the user see the message.
HANG 1
End DoDot:1
QUIT
+26 ;
+27 ; Store backup confirmation person & date/time
+28 SET BCKUPCNT=1+$ORDER(^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",""),-1)
+29 SET ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT)=DUZ_"^"_$PIECE($GET(^VA(200,DUZ,0)),U)
+30 SET ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT,"DATE/TIME")=$$HTE^XLFDT($HOROLOG,"5MZ")
+31 ;
+32 DO BOKAY^BLRPRE31("SUCCESSFUL system backup CONFIRMED by: "_$$GET1^DIQ(200,DUZ,"NAME")_".",5)
+33 ; Pause 1 second to let the user see the message.
HANG 1
+34 QUIT
+35 ;
POST ; EP -- POST INSTALL
+1 NEW BLRVERN,CP,STR
+2 ;
+3 ; Current Patch
SET CP=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+4 ; Routine Name
SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+5 ;
+6 ; Creates BLRICDO global
DO CLEANSET^BLRICDO
+7 ;
+8 DO ADDOPTS("BLRMENU","BLROTSCH","REPL")
+9 DO ADDOPTS("BLRMENU","BLRLROS","LROS")
+10 DO CHNGOPTT("LROE","Accessioning tests ordered by provider order entry")
+11 ; Add RPCs to Option
DO BMXPO
+12 ; Change Labcorp DG1.2 to @DG12LABO
DO UPGIS
+13 ;
+14 ; Get rid of extraneous LAB JOURNAL pointers in file 61.2
DO LABJRNL
+15 ;
+16 DO BMES^XPDUTL("Need to Reset Ref Lab Accession X-Ref Global.")
+17 KILL ^XTMP("BLRLINKU")
+18 ; Reset Ref Lab Accession X-Ref Global
DO REFLAB68^BLRLINKU
+19 DO OKAY^BLRKIDSU("Ref Lab Accession X-Ref Global Reset.")
+20 ;
+21 DO BMES^XPDUTL("Laboratory Patch "_CP_" INSTALL complete.")
+22 ;
+23 ; The VistA Lab's Emerging Pathogen Initiative module is not used
+24 ; by IHS. Inactivate the options so that users do not, inadvertantly,
+25 ; go into any of the EPI menus.
+26 DO INACTOPT("LREP","Lab EPI Module Not Used by IHS","LREPILK")
+27 ;
+28 ; Store # of times installation occurred as well as person & date/time
+29 DO ENDINSTL^BLRKIDSU(CP)
+30 ;
+31 IF +$GET(DEBUG)
QUIT
+32 ;
+33 SET STR(1)=" "
+34 SET STR(2)=$JUSTIFY("",10)_"POST INSTALL of "_BLRVERN_" Routine."
+35 SET STR(3)=" "
+36 SET STR(4)=$JUSTIFY("",15)_"Laboratory Patch "_CP_" INSTALL completed."
+37 SET STR(5)=" "
+38 ;
+39 ; Send Alert & E-Mail to LMI Mail Group & Installer
+40 DO MAILALMI^BLRUTIL3("Laboratory Patch "_CP_" INSTALL complete.",.STR,BLRVERN)
+41 QUIT
+42 ;
+43 QUIT
+44 ;
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 SET TAB=$JUSTIFY(" ",$GET(TAB,5))
+5 SET X="Adding '"_OPTION_"' option"
+6 IF $DATA(SYNONYM)
SET X=X_" with "_SYNONYM_" synonym"
+7 SET X=X_" to "_TOMENU_"."
+8 DO BMES^XPDUTL(X)
+9 SET X=$$ADD^XPDMENU(TOMENU,OPTION,SYNONYM)
+10 IF X=1
DO BMES^XPDUTL(TAB_"'"_OPTION_"' added to "_TOMENU_". OK.")
+11 IF X'=1
Begin DoDot:1
+12 DO BMES^XPDUTL(TAB_"Error in adding '"_OPTION_"' option to "_TOMENU_".")
+13 DO MES^XPDUTL(TAB_TAB_"Error Message: "_$$UP^XLFSTR($PIECE(X,"^",2)))
End DoDot:1
+14 ;
+15 DO MES^XPDUTL("")
+16 QUIT
+17 ;
BMXPO ;-- update the RPC file
+1 NEW BLRRPC
+2 SET BLRRPC=$ORDER(^DIC(19,"B","BLRRLRPC",0))
+3 IF 'BLRRPC
QUIT
+4 DO CLEAN(BLRRPC)
+5 DO GUIEP^BMXPO(.RETVAL,BLRRPC_"|BLR")
+6 QUIT
+7 ;
CLEAN(APP) ;-- clean out the RPC multiple first
+1 SET DA(1)=APP
+2 SET DIK="^DIC(19,"_DA(1)_","_"""RPC"""_","
+3 NEW BLRDA
+4 SET BLRDA=0
FOR
SET BLRDA=$ORDER(^DIC(19,APP,"RPC",BLRDA))
IF 'BLRDA
QUIT
Begin DoDot:1
+5 SET DA=BLRDA
+6 DO ^DIK
End DoDot:1
+7 KILL ^DIC(19,APP,"RPC","B")
+8 QUIT
+9 ;
UPGIS ;-- update the GIS definition
+1 NEW BLRX,BLRM
+2 SET BLRX=$ORDER(^INTHL7F("B","HL IHS LAB ORM DG1-2 LC",0))
+3 IF 'BLRX
QUIT
+4 SET ^INTHL7F(BLRX,"C")="@DG12LABO"
+5 SET BLRM=$ORDER(^INTHL7M("B","HL IHS LAB O01 LABCORP",0))
+6 IF 'BLRM
QUIT
+7 DO COMPILE^BHLU(BLRM)
+8 QUIT
+9 ;
DEONARDY(TOMENU,OPTION,SYNONYM) ; EP
+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 QUIT $SELECT($GET(^DIC(19,TOIEN,10,SYNIEN,0))=OPTIEN:1,1:0)
+14 ;
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
+16 ;
LABJRNL ; EP - Get rid of pointers in file 61.2 that point to an empty File 95.
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 ; If there is data in file 95, don't do anything
IF +$ORDER(^LAB(95,0))
QUIT
+4 ;
+5 SET CNT=0
SET IEN=.9999999
+6 FOR
SET IEN=$ORDER(^LAB(61.2,IEN))
IF IEN<1
QUIT
Begin DoDot:1
+7 SET JOURN=0
FOR
SET JOURN=$ORDER(^LAB(61.2,IEN,"JR",JOURN))
IF JOURN<1
QUIT
Begin DoDot:2
+8 SET CNT=CNT+1
+9 IF CNT=1
Begin DoDot:3
+10 SET ^XTMP("LABJRNAL",0)=$$HTFM^XLFDT(+$HOROLOG+365)_"^"_$$DT^XLFDT_"^Entries In File 61.2 that Pointed to (Empty) File 95"
+11 DO BMES^XPDUTL("There are entries In File 61.2 that Point to (Empty) LAB JOURNAL (#95) File.")
End DoDot:3
+12 SET ^XTMP("LABJRNAL","61.2","IEN",IEN)=""
+13 MERGE ^XTMP("LABJRNAL","61.2","IEN",IEN,"JOURN",JOURN)=^LAB(61.2,IEN,"JR",JOURN)
+14 DO TABMENU^BLRKIDSU("File 61.2 IEN:"_IEN_"; JOURN IEN:"_JOURN)
+15 DO TABMENU^BLRKIDSU("File 61.2 Journal Reference:"_$GET(^LAB(61.2,IEN,"JR",JOURN,0)),10)
+16 ;
+17 KILL DA
+18 SET DA(1)=IEN
SET DA=JOURN
+19 SET DIK="^LAB(61.2,"_DA(1)_",""JR"","
+20 DO ^DIK
End DoDot:2
End DoDot:1
+21 ;
+22 IF CNT
SET ^XTMP("LABJRNAL","61.2")=CNT
+23 QUIT
+24 ;
DEBUG ; EP - Debugging Line Label for environment checker
+1 NEW CP,DEBUG,LINE2,ROWPLUS,ROWSTARS,XPDNM
+2 SET DEBUG=1
+3 SET XPDNM="LR*5.2*1034"
+4 ;
+5 SET ROWSTARS=$TRANSLATE($JUSTIFY("",IOM)," ","*")
+6 SET ROWPLUS=$TRANSLATE($JUSTIFY("",IOM)," ","+")
+7 ;
+8 DO ^XBCLS
DO PASSMESG^BLRPRE31("DEBUG: ENVCHK Check")
+9 ;
+10 DO ENVCHK^BLRPRE34
+11 ;
+12 WRITE !!,"DEBUG: ENVCHK^BLRPRE34 Completed."
+13 WRITE !!,ROWPLUS
+14 DO PRESSKEY^BLRGMENU
+15 ;
+16 DO ^XBCLS
DO PASSMESG^BLRPRE31("DEBUG: BACKUP Check.")
+17 DO BACKUP^BLRPRE34
+18 WRITE !!,"DEBUG: BACKUP^BLRPRE34 Completed.",!
+19 WRITE !,ROWPLUS
+20 DO PRESSKEY^BLRGMENU
+21 ;
+22 DO ^XBCLS
DO PASSMESG^BLRPRE31("DEBUG: POST Check")
+23 DO POST^BLRPRE34
+24 WRITE !!,"DEBUG: POST^BLRPRE34 Completed."
+25 WRITE !!,ROWPLUS
+26 DO PRESSKEY^BLRGMENU
+27 ;
+28 DO ^XBCLS
DO PASSMESG^BLRPRE31("DEBUG: COMPLETED")
+29 DO PRESSKEY^BLRGMENU
+30 QUIT
+31 ;
LASTPTCH(CP) ; EP
+1 NEW COMPFLAG,COMPPTCH,LASTPTCH,LRPATCH,LPIEN,STR
+2 ;
+3 SET LASTPTCH=CP-1
+4 ;
+5 DO BMES^XPDUTL("Need at least IHS Lab Patch "_LASTPTCH)
+6 ;
+7 SET LRPATCH="LR*5.2*1099"
SET COMPFLAG="NO"
+8 FOR
SET LRPATCH=$ORDER(^XPD(9.7,"B",LRPATCH),-1)
Begin DoDot:1
+9 SET LPIEN=$ORDER(^XPD(9.7,"B",LRPATCH,""),-1)
+10 IF $PIECE($GET(^XPD(9.7,+$GET(LPIEN),0)),"^",9)=3
SET COMPFLAG="YES"
SET COMPPTCH=LRPATCH
End DoDot:1
IF LRPATCH=""!(COMPFLAG="YES")!($EXTRACT(LRPATCH,1,2)'="LR")!($PIECE(LRPATCH,"*",3)<LASTPTCH)
QUIT
+11 ;
+12 IF COMPFLAG'="YES"!($PIECE(COMPPTCH,"*",3)<LASTPTCH)
Begin DoDot:1
+13 DO SORRY("Need at least IHS Lab Patch "_LASTPTCH,,"Latest IHS Lab Patch Found is "_COMPPTCH_".",CP)
End DoDot:1
QUIT "NOT OK"
+14 ;
+15 DO OKAY^BLRKIDSU("IHS Lab Patch "_LASTPTCH_" Installed.",10)
+16 ;
+17 QUIT "OK"
+18 ;
SORRY(MSG,MODE,MSG2,CP) ; EP
+1 ; Error Message routine. It will send an ALERT and a MailMan message
+2 ; to the people who are assigned to the LMI Mail group.
+3 ;
+4 ; The STR array is built so that the error/warning message will
+5 ; also appear on the INSTALL LOG via the D BMES^XPDUTL(.STR) call.
+6 ;
+7 NEW MESSAGE
+8 IF $GET(MODE)'["NONFATAL"
Begin DoDot:1
+9 SET MESSAGE="Install Aborting due to the following Systems Environment issue:"
+10 ; Fatal Error Flag Set
SET XPDABORT=1
End DoDot:1
+11 ;
+12 IF $GET(MODE)["NONFATAL"
SET MESSAGE="*** WARNING *** WARNING *** WARNING ***"
+13 ;
+14 KILL DIFQ
+15 ;
+16 NEW STR,LINECNT
+17 SET LINECNT=1
+18 DO ADDLINE(" ",.LINECNT)
+19 ; Row of asterisks
DO ADDLINE($TRANSLATE($JUSTIFY("",65)," ","*"),.LINECNT)
+20 DO ADDLINE(" ",.LINECNT)
+21 DO ADDLINE($$CJ^XLFSTR("Site: "_$$LOC^XBFUNC,65),.LINECNT)
+22 DO ADDLINE(" ",.LINECNT)
+23 DO ADDLINE($$CJ^XLFSTR(MESSAGE,65),.LINECNT)
+24 DO ADDLINE(" ",.LINECNT)
+25 DO ADDLINE($$CJ^XLFSTR(">>> "_MSG_" <<<",65),.LINECNT)
+26 IF $DATA(MSG2)
DO ADDLINE($$CJ^XLFSTR(">>> "_MSG2_" <<<",65),.LINECNT)
+27 DO ADDLINE(" ",.LINECNT)
+28 ;
+29 IF $GET(MODE)["NONFATAL"
DO ADDLINE($$CJ^XLFSTR(MESSAGE,65),.LINECNT)
+30 ;
+31 IF $GET(MODE)'["NONFATAL"
Begin DoDot:1
+32 DO ADDLINE($$CJ^XLFSTR("Please print/capture this screen and",65),.LINECNT)
+33 DO ADDLINE($$CJ^XLFSTR("notify the Support Center at",65),.LINECNT)
+34 DO ADDLINE(" ",.LINECNT)
+35 DO ADDLINE($$CJ^XLFSTR("1-888-830-7280.",65),.LINECNT)
+36 DO ADDLINE(" ",.LINECNT)
End DoDot:1
+37 ;
+38 ; Row of asterisks
DO ADDLINE($TRANSLATE($JUSTIFY("",65)," ","*"),.LINECNT)
+39 DO ADDLINE(" ",.LINECNT)
+40 ;
+41 ; Display the message
DO BMES^XPDUTL(.STR)
+42 ;
+43 ; Skip if DEBUG
IF +$GET(DEBUG)
QUIT
+44 ;
+45 ; Skip if no DUZ
IF '$GET(DUZ)!('$LENGTH($GET(DUZ(0))))
QUIT
+46 ;
+47 ; Skip if no LMI Mail group
IF $$FIND1^DIC(3.8,,,"LMI")<1
QUIT
+48 ;
+49 IF $GET(MODE)="FATAL"
DO MAILALMI^BLRUTIL3("IHS Lab Patch "_CP_" Install FATAL Error",.STR,"BLRPRE34")
+50 IF $GET(MODE)="NONFATAL"
DO MAILALMI^BLRUTIL3("IHS Lab Patch "_CP_" Install NONFATAL Error",.STR,"BLRPRE34")
+51 ;
+52 QUIT
+53 ;
ADDLINE(ASTR,LC) ; EP
+1 ; Add a line to the STR array
+2 IF $GET(ASTR)=""
SET ASTR=" "
+3 SET STR(LC)=ASTR
+4 SET LC=LC+1
+5 QUIT
+6 ;
CHNGOPTT(OPTION,TEXT) ; EP - Change the MENU Text of an Option
+1 NEW ERRS,FDA,OLDMTEXT,OPTIEN
+2 ;
+3 SET OPTIEN=$$FIND1^DIC(19,,,OPTION)
+4 ; Skip if cannot determine OPTION's IEN in file 19
IF OPTIEN<1
QUIT
+5 ;
+6 SET OLDMTEXT=$$GET1^DIQ(19,OPTIEN,"MENU TEXT")
+7 ;
+8 DO BMES^XPDUTL("Attempting to modify MENU TEXT on Option "_OPTION_" from")
+9 DO MES^XPDUTL($JUSTIFY("",10)_$EXTRACT(OLDMTEXT,1,50))
+10 DO MES^XPDUTL(" to")
+11 DO MES^XPDUTL($JUSTIFY("",10)_$EXTRACT(TEXT,1,50))
+12 ;
+13 SET FDA(19,OPTIEN_",",1)=TEXT
+14 DO UPDATE^DIE("SE","FDA",,"ERRS")
+15 DO MES^XPDUTL("")
+16 IF $DATA(ERRS)<1
DO OKAY^BLRKIDSU("MENU TEXT modified.")
+17 IF $DATA(ERRS)
DO MES^XPDUTL(" MENU TEXT was *NOT* modified.")
+18 QUIT
