BLRPRE33 ; IHS/MSC/MKK - IHS Lab Patch Pre/Post/Environment Routine ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
;
ENVICHEK ; Environment Checker
NEW CP,PREREQ,RPMS,RPMSVER,QFLG,ROWSTARS,STR,TODAY,WOTCNT
NEW ERRARRAY ; Errors array
NEW BLRVERN,BEGTIME,ENDTIME,PATCHNUM,WHATCNT
;
S PATCHNUM=$TR($P($T(+2),";",5),"*")
S BLRVERN=$TR($P($T(+1),";")," ")
S TODAY=$$DT^XLFDT
S WOTCNT=$$WOTCNT()
;
S ^XTMP(BLRVERN,0)=$$HTFM^XLFDT(+$H+90)_"^IHS Lab Patch "_PATCHNUM_"^"_$$DT^XLFDT
M ^XTMP(BLRVERN,TODAY,WOTCNT,"DUZ")=DUZ
S ^XTMP(BLRVERN,TODAY,WOTCNT,"BEGIN")=$$NOW^XLFDT
;
S XUMF=1
;
I $G(XPDNM)="" D Q
. S CP=$TR($P($T(+2),";",5),"*")
. D SORRY^BLRPRE31(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^BLRPRE31(CP,"DUZ UNDEFINED OR 0.") Q
;
I $L($$GET1^DIQ(200,DUZ,"NAME"))<1 D SORRY^BLRPRE31(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
;
D ENVHEADR^BLRPRE31(CP,RPMSVER,RPMS)
;
D MES^XPDUTL
;
D CHKLABMG ; Check Lab Mail Groups
;
D NEEDIT^BLRPRE31(CP,"BSTS","1.0",,.ERRARRY) ; IHS Standard Terminology Pre-Requisite
D NEEDIT^BLRPRE31(CP,"BJPC","2.0",10,.ERRARRAY) ; PCC Pre-Requisite
D NEEDIT^BLRPRE31(CP,"LR","5.2",1032,.ERRARRAY) ; Lab Pre-Requisite
D NEEDIT^BLRPRE31(CP,"XU","8.0",1017,.ERRARRAY) ; Kernel Pre-Requisite
;
D MES^XPDUTL
;
I XPDABORT>0 D SORRYEND(.ERRARRAY,CP) Q ; ENVIRONMENT HAS ERROR(S)
;
D BOKAY^BLRPRE31("ENVIRONMENT")
;
S XUMF=1
;
Q
;
WOTCNT() ; EP - Counter for ^XTMP
NEW BLRVERN,CNT,TODAY
;
S BLRVERN=$TR($P($T(+1),";")," ")
S TODAY=$$DT^XLFDT
;
S CNT=1+$G(^XTMP(BLRVERN,0,TODAY))
S ^XTMP(BLRVERN,0,TODAY)=CNT
Q $TR($J(CNT,3)," ","0")
;
CHKLABMG ; EP - Check Lab Mail Groups
NEW FNAME,LNAME,USERNAME
;
S USERNAME=$$UP^XLFSTR($$GET1^DIQ(200,DUZ,"NAME")),LNAME=$P(USERNAME,","),FNAME=$P(USERNAME,",",2)
;
Q:LNAME["WALKER"&((FNAME["MIKE")!(FNAME["MICHAEL"))
;
D CHKMAILG(CP,"LMI",.ERRARRAY) ; Check for LMI Mail Group
D CHKMAILG(CP,"LAB MESSAGING",.ERRARRAY) ; Check for LAB MESSAGING Mail Group
D CHKMAILG(CP,"BLRLINK",.ERRARRAY) ; Check for BLRLINK Mail Group
Q
;
; Determine if required Mail Group Exists AND the Mail Group has at least
; one member who has logged onto RPMS in the past year
CHKMAILG(CP,MAILGRP,ERRARRAY) ; EP
NEW MEM,MEMBER,MGRPIEN,MEMOKAY,VALIDMBR
;
D CHKGROUP^XMBGRP(MAILGRP,.MGRPIEN) ; VA DBIA 1146
;
I +$G(MGRPIEN)<1 D Q
. D SORRY^BLRPRE31(CP,MAILGRP_" Mail Group Does NOT Exist!")
. S ERRARRAY("XMB","Mail Group","3.8")=MAILGRP_" Mail Group Does NOT Exist!"
;
D OKAY^BLRKIDSU(MAILGRP_" Mail Group Exists.")
;
I $$VALIDMBR(MGRPIEN) D OKAY^BLRKIDSU(MAILGRP_" Mail Group Has a Valid Member.",10) Q
;
D SORRY^BLRPRE31(CP,"The "_MAILGRP_" Mail Group Exists but no Member of","FATAL",MAILGRP_" has logged onto RPMS within the past year!")
S ERRARRAY("XMB","Mail Group","3.8")=MAILGRP_" Mail Group Exists, but Does NOT have a Valid Member"
Q
;
VALIDMBR(MGRPIEN) ; EP - Determine if Mail Group has at least one valid member
S MEM=.9999999,VALIDMBR=0
;
F S MEM=$O(^XMB(3.8,MGRPIEN,1,MEM)) Q:MEM<1!(VALIDMBR) D
. S MEMBER=+$$GET1^DIQ(3.81,MEM_","_MGRPIEN_",","MEMBER","I")
. Q:+$$GET1^DIQ(200,MEMBER,"DISUSER") ; If DISUSERed, not a Valid Member
. Q:+$$GET1^DIQ(200,MEMBER,"TERMINATION DATE","I") ; If Terminated, not a Valid Member
. S LASTLOGI=$$GET1^DIQ(200,MEMBER,202,"I") ; Last Login Date
. Q:$$FMDIFF^XLFDT($$NOW^XLFDT,LASTLOGI)>364 ; If Last Login > 364 days ago, not a Valid Member
. ;
. S VALIDMBR=MEMBER ; None of the above true, so valid member
;
Q VALIDMBR
;
DEBUG ; EP - Debugging Line Label for environment checker
NEW CP,DEBUG,RPMS,RPMSVER,QFLG,STR
W !!
W "Debug Begins:",$$TRIM^XLFSTR($P($T(+1),";"),"LR"," "),!!
;
; Note -- DEBUG is a negative flag:
; YES="Don't Send Alerts"; NO="Send Alerts"
;
S DEBUG="YES" ; At this time, DO NOT send alerts
;
; 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"
;
W !
S XPDNM="LR*5.2*"_$P($T(+2),"*",3)
S XPDENV=0
;
D ENVICHEK
D PRESSKEY^BLRGMENU(4)
;
Q:XPDABORT
;
D PRE
W !!!
;
D ^XBFMK
S DIR(0)="YO"
S DIR("B")="NO"
S DIR("A")="Test Post Install Code"
D ^DIR
;
D EXIT^XPDID
;
I +$G(Y)=1 D
. F MENUOPT="LRLIAISON","LR IHS LIAISON" S X=$$ADD^XPDMENU(MENUOPT,"LRLOINC")
. D POST
W !!!
;
; Delete DEBUG Backup confirmation
; K ^BLRINSTL("LAB PATCH",$P(XPDNM,"*",3))
;
W !!,"Debug Ends:",$$TRIM^XLFSTR($P($T(+1),";"),"LR"," ")
Q
;
PRE ; EP -- Ask for confirmation of Backup
NEW BLRVERN,CNT,CP,CRTLINE,DIRASTR,FDAROOT,IEN,IENS,MSGROOT
NEW BCKUPCNT ; Current Patch,Backup count
;
S CP=$TR($P($T(+2),";",5),"*")
S BLRVERN=$TR($P($T(+1),";")," ")
;
S XUMF=1
;
D INIT^XPDID
D TITLE^XPDID("LR*5.2*1033")
W !!
D BMES^XPDUTL("Pre-Install of "_BLRVERN_" Begins.")
;
D PASSMESG^BLRPRE31("ATTENTION")
W !
;
D ^XBFMK
S DIR(0)="Y"
S DIR("B")="NO"
S:$G(IOST)["C-VT" DIRASTR=$J("",10)_"Has a "_$C(27)_"[1;7;5m"_">> SUCCESSFUL <<"_$C(27)_"[0m"_" backup been performed?"
S:$G(IOST)'["C-VT" DIRASTR=$J("",10)_"Has a >> SUCCESSFUL << backup been performed?"
S DIR("A")=DIRASTR
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.")
;
; 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.
;
D INIT^XPDID
D TITLE^XPDID("LR*5.2*1033")
W !!
D BMES^XPDUTL("Pre-Install of "_BLRVERN_" Continues.")
;
D FILESDEL
;
D COPYPROT
;
D BMES^XPDUTL($J("",5)_"Pre-Install Processing Ends at "_$$UP^XLFSTR($$HTE^XLFDT($H,"5MPZ"))_".")
H 1 ; Pause 1 second to let the user see the message.
;
Q
;
FILESDEL ; EP - The following deletions are necessatry in order to prevent errors during installation
NEW CNT,FILENUM,IEN
;
S XUMF=1 ; Supposedly allows updating "locked down" dictionaries. Doesn't appear to work.
;
D DISABLE^%NOJRN ; Disable Journaling prior to deletions
;
; Delete Files' entries
; 95.3 = LOINC
; 95.31 = LAB LOINC COMPONENT
; 64.061 = LAB ELECTRONIC CODES
; 64.2 = WKLD SUFFIX CODES
F FILENUM=95.3,95.31,64.061,64.2 D
. S IEN=.9999999,CNT=0
. W !,?4,FILENUM
. F S IEN=$O(^LAB(FILENUM,IEN)) Q:IEN<1 D
.. I CNT#100=0 W "." W:$X>75 !,?4
.. S CNT=CNT+1
.. D ^XBFMK
.. S DIK="^LAB("_FILENUM_",",DA=IEN
.. Q:$G(DEBUG)="YES" ; If DEBUG set, don't delete anything
.. D ^DIK
;
W !
;
D ENABLE^%NOJRN ; Restore Journaling
;
Q
;
COPYPROT ; EP - Have to copy the entries for LR7O ALL EVSEND RESULTS Protocol
NEW ERRS,FOUND,IEN,PATCHNUM
D FIND^DIC(101,,,,"LR7O ALL EVSEND RESULTS",,,,,"FOUND","ERRS")
Q:$D(ERRS)
;
S IEN=+$G(FOUND("DILIST",2,1))
Q:IEN<1
;
S PATCHNUM=$TR($P($T(+2),";",5),"*")
;
S ^XTMP("LR7O ALL EVSEND RESULTS",0)=$$HTFM^XLFDT(+$H+90)_"^"_$$DT^XLFDT_"^LR*5.2*"_PATCHNUM_" PRE-INSTALL SAVE"
M ^XTMP("LR7O ALL EVSEND RESULTS",IEN)=^ORD(101,IEN)
Q
;
POST ; EP -- POST INSTALL
NEW BLRVERN,CHKIT,CP,ERRS,FDA,IEN,MENUOPT,NEWOPT,NEWOPTM,PATCHNUM,STR,TAB,TODAY,WOTCNT
;
S CP=$P($T(+2),"*",3) ; Current Patch
;
S PATCHNUM=$TR($P($T(+2),";",5),"*")
S BLRVERN=$TR($P($T(+1),";")," ")
S TODAY=$$DT^XLFDT
S WOTCNT=$$WOTCNT()
;
D BMES^XPDUTL("LR*5.2*"_CP_" Post Install")
D MES^XPDUTL(" ")
;
; Get rid of LOINC option on LRLIAISON & LR IHS LIAISON menus since it's deactivated
F MENUOPT="LRLIAISON","LR IHS LIAISON" D
. Q:$$DELETE^XPDMENU(MENUOPT,"LRLOINC")<1
. ;
. ; Deletion successful. Give feedback
. D OKAY^BLRKIDSU("Obsolete VA LOINC option removed from "_MENUOPT_" menu.",0)
. D MES^XPDUTL(" ")
;
S TAB=$J("",5)
;
D ADDOPTS ; Add new options to BLRMENU
D ADDHLOPT ; Add new option to BLRREFLABMENU
D TURNOFF ; LA7HDR entry in file 62.48 must be set to INACTIVE
D NEWKEYON ; Add new BLRZZ Security Key to BLRREFLABMENU option
D NEWKEYLA ; Add LRSUPER Security Key to LA MI VERIFY AUTO option
D NOSNAPS ; Make sure TAKE SNAPSHOTS field in BLR MASTER CONTROL is OFF
D GLUCACHE ; Make sure GLUCOMETER is in the Terminolgoy Server Cache
;
; Run MAILMAN version of BLRLTRRR routine if DEBUG not YES
D:$G(DEBUG)'="YES" EMAIL^BLRLTRRR
;
; Setup Instance of new parameter. Initially its value is NO.
D EN^XPAR("PKG","BLR CC DATA",,"NO",.ERRS)
D:+$G(ERRS)=0 MES^XPDUTL("Parameter 'BLR CC DATA' Instance set to NO.")
;
D ENDINSTL^BLRPRE31(CP)
;
D BMES^XPDUTL(" ")
;
D BMES^XPDUTL("Laboratory Patch "_CP_" INSTALL complete.")
;
I $G(DEBUG)="YES" S ^XTMP(BLRVERN,TODAY,WOTCNT,"END")=$$NOW^XLFDT Q
;
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 E-Mail to LMI Mail Group & Installer
D MAILALMI^BLRUTIL3("Laboratory Patch "_CP_" INSTALL complete.",.STR,$TR($P($T(+1),";")," "))
;
S ^XTMP(BLRVERN,TODAY,WOTCNT,"END")=$$NOW^XLFDT
Q
;
ADDOPTS ; EP - Add new options to the BLRMENU
F MENUOPT="BLR ADD COMPLETED DATE^DADD","BLR LAB TESTS REF RANGES^LTRR","BLR 62.49 HL7 SEGMENTS^6249","BLR LRAS MICRO REPORT^LRAS","BLR MU2 MICRO REPORT^IHSM","BLRSCRNTASKS^LABT" D
. S NEWOPT=$P(MENUOPT,"^")
. S NEWOPTM=$P(MENUOPT,"^",2)
. D BMES^XPDUTL("Adding '"_NEWOPT_"' option to BLRMENU.")
. S X=$$ADD^XPDMENU("BLRMENU",NEWOPT,NEWOPTM)
. D:X=1 MES^XPDUTL(TAB_"'"_NEWOPT_"' added to BLRMENU. OK.")
. I X'=1 D
.. D MES^XPDUTL(TAB_"Error in adding '"_NEWOPT_"' option to BLRMENU.")
.. D MES^XPDUTL(TAB_TAB_"Error Message: "_$$UP^XLFSTR($P(X,"^",2)))
;
D MES^XPDUTL(" ")
Q
;
ADDHLOPT ; EP - Add new option to the BLRREFLABMENU
F MENUOPT="BLR REFLAB HL7 TABLE LOOKUP^TBLL","BLR REFLAB MONITOR PARAMS^MON" D
. S NEWOPT=$P(MENUOPT,"^")
. S NEWOPTM=$P(MENUOPT,"^",2)
. D BMES^XPDUTL("Adding '"_NEWOPT_"' option to BLRREFLABMENU.")
. S X=$$ADD^XPDMENU("BLRREFLABMENU",NEWOPT,NEWOPTM)
. D:X=1 MES^XPDUTL(TAB_"'"_NEWOPT_"' added to BLRREFLABMENU. OK.")
. I X'=1 D
.. D MES^XPDUTL(TAB_"Error in adding '"_NEWOPT_"' option to BLRMENU.")
.. D MES^XPDUTL(TAB_TAB_"Error Message: "_$$UP^XLFSTR($P(X,"^",2)))
;
D MES^XPDUTL(" ")
Q
;
TURNOFF ; EP - LA7HDR entry in file 62.48 must be set to INACTIVE
NEW ERRS,FDA,IEN
;
S IEN=+$$FIND1^DIC(62.48,,,"LA7HDR")
Q:IEN<1 ; Skip if LA7HDR parameter does not exist
;
D BMES^XPDUTL("Inactivating 'LA7HDR' parameter in 62.48.")
;
D ^XBFMK
K FDA
S FDA(62.48,IEN_",",2)=0 ; Setting STATUS field to INACTIVE
D FILE^DIE("KS","FDA","ERRS")
;
I $D(ERRS)<1 D Q
. D OKAY^BLRKIDSU("'LA7HDR' parameter in 62.48 Inactivated.",5)
. D MES^XPDUTL(" ")
;
D NOTOKAY("'LA7HDR' parameter in 62.48 *NOT* Inactivated.",5)
D SNDALERT^BLRUTIL3("'LA7HDR' parameter in 62.48 *NOT* Inactivated.")
;
Q
;
NEWKEYON ; EP - Make sure new BLRRLZ Security Key is added to BLRREFLABMENU option
NEW ERRS,FDA,IEN
S IEN=+$$LKOPT^XPDMENU("BLRREFLABMENU")
Q:IEN<1 ; Skip if cannot find Ref Lab Menu option
;
D ^XBFMK
S FDA(19,IEN_",",3)="BLRRLZ"
D FILE^DIE(,"FDA","ERRS")
Q
;
NEWKEYLA ; EP - Add LRSUPER Security Key to LA MI VERIFY AUTO option
NEW ERRS,FDA,IEN
S IEN=+$$LKOPT^XPDMENU("LA MI VERIFY AUTO")
Q:IEN<1 ; Skip if cannot find Ref Lab Menu option
;
D ^XBFMK
S FDA(19,IEN_",",3)="LRSUPER"
D FILE^DIE(,"FDA","ERRS")
Q
;
NOSNAPS ; EP - Make certain TAKE SNAPSHOTS field in BLR MASTER CONTROL file is OFF
NEW CNT,DESC,FDA,IEN
;
S (CNT,IEN)=0
F S IEN=$O(^BLRSITE(IEN)) Q:IEN<1 D
. Q:+$$GET1^DIQ(9009029,IEN,"TAKE SNAPSHOTS","I")<1
. ;
. S CNT=CNT+1,CNT(IEN)=""
. K FDA
. S FDA(9009029,IEN_",",1)=0
. D FILE^DIE(,"FDA","ERRS")
;
Q:CNT<1 ; If no update, just return
;
D BMES^XPDUTL("File 9009029 'TAKE SNAPSHOTS' Field Set to OFF for the following:")
S IEN=0
F S IEN=$O(CNT(IEN)) Q:IEN<1 D TABMENU^BLRKIDSU($$GET1^DIQ(9009029,IEN,.01),5)
D BMES^XPDUTL
Q
;
NOTOKAY(MSG,TAB) ; EP -- Write out Blank line, then "NOT OKAY" message
D BMES^XPDUTL($J("",+$G(TAB))_MSG_" NOT OK.")
Q
;
GLUCACHE ; EP - Make sure IHS Terminology Server has GLUCOMETER in its cache
NEW IN,OUT,VARS
S OUT="VARS",IN="GLUCOMETER^F^^ALL"
S X=$$SEARCH^BSTSAPI(OUT,IN)
Q
;
SORRYEND(WOTERR,CP) ; EP -- ALL the errors detected during the environment check.
NEW STR,MODULE,NAME,VERSION,PATCH,LINECNT,TMP
;
D SORRYHED^BLRPRE31
;
S (MODULE,NAME,VERSION)=""
F S MODULE=$O(WOTERR(MODULE)) Q:MODULE="" D
. F S NAME=$O(WOTERR(MODULE,NAME)) Q:NAME="" D
.. F S VERSION=$O(WOTERR(MODULE,NAME,VERSION)) Q:VERSION="" D ADDMESG
;
D SORRYFIN^BLRPRE31
;
D BMES^XPDUTL(.STR)
;
Q
;
ADDMESG ; EP
NEW WOT,WOTWRONG
;
D ADDLINE^BLRPRE31(.LINECNT,NAME_" ("_MODULE_")","YES")
;
S WOT=$G(WOTERR(MODULE,NAME,VERSION))
S TMP="Version:"_VERSION
S WOTWRONG=$P(WOT,"^",2)
;
I WOTWRONG="VERSION" D
. S TMP="Needed Version:"_VERSION
. S TMP=TMP_" Found Version:"_$P(WOT,"^")
;
I WOTWRONG="PATCH" D
. S TMP=TMP_" Needed Patch:"_$P(WOT,"^")
;
I WOTWRONG'="PATCH"&(WOTWRONG'="VERSION") D
. D ADDLINE^BLRPRE31(.LINECNT,TMP,"YES")
. S TMP=WOT
;
D ADDLINE^BLRPRE31(.LINECNT,TMP,"YES")
D ADDLINE^BLRPRE31(.LINECNT)
Q
BLRPRE33 ; IHS/MSC/MKK - IHS Lab Patch Pre/Post/Environment Routine ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
+2 ;
ENVICHEK ; Environment Checker
+1 NEW CP,PREREQ,RPMS,RPMSVER,QFLG,ROWSTARS,STR,TODAY,WOTCNT
+2 ; Errors array
NEW ERRARRAY
+3 NEW BLRVERN,BEGTIME,ENDTIME,PATCHNUM,WHATCNT
+4 ;
+5 SET PATCHNUM=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+6 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+7 SET TODAY=$$DT^XLFDT
+8 SET WOTCNT=$$WOTCNT()
+9 ;
+10 SET ^XTMP(BLRVERN,0)=$$HTFM^XLFDT(+$HOROLOG+90)_"^IHS Lab Patch "_PATCHNUM_"^"_$$DT^XLFDT
+11 MERGE ^XTMP(BLRVERN,TODAY,WOTCNT,"DUZ")=DUZ
+12 SET ^XTMP(BLRVERN,TODAY,WOTCNT,"BEGIN")=$$NOW^XLFDT
+13 ;
+14 SET XUMF=1
+15 ;
+16 IF $GET(XPDNM)=""
Begin DoDot:1
+17 SET CP=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+18 DO SORRY^BLRPRE31(CP,"XPDNM not defined or 0.")
End DoDot:1
QUIT
+19 ;
+20 ; Patch Number
SET CP=$PIECE(XPDNM,"*",3)
+21 ; RPMS Module
SET RPMS=$PIECE(XPDNM,"*",1)
+22 ; RPMS Version
SET RPMSVER=$PIECE(XPDNM,"*",2)
+23 ;
+24 ; Row of asterisks
SET ROWSTARS=$TRANSLATE($JUSTIFY("",65)," ","*")
+25 ;
USERID ; EP - CHECK FOR USER ID
+1 IF +$GET(DUZ)<1
DO SORRY^BLRPRE31(CP,"DUZ UNDEFINED OR 0.")
QUIT
+2 ;
+3 IF $LENGTH($$GET1^DIQ(200,DUZ,"NAME"))<1
DO SORRY^BLRPRE31(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 ;
+12 DO ENVHEADR^BLRPRE31(CP,RPMSVER,RPMS)
+13 ;
+14 DO MES^XPDUTL
+15 ;
+16 ; Check Lab Mail Groups
DO CHKLABMG
+17 ;
+18 ; IHS Standard Terminology Pre-Requisite
DO NEEDIT^BLRPRE31(CP,"BSTS","1.0",,.ERRARRY)
+19 ; PCC Pre-Requisite
DO NEEDIT^BLRPRE31(CP,"BJPC","2.0",10,.ERRARRAY)
+20 ; Lab Pre-Requisite
DO NEEDIT^BLRPRE31(CP,"LR","5.2",1032,.ERRARRAY)
+21 ; Kernel Pre-Requisite
DO NEEDIT^BLRPRE31(CP,"XU","8.0",1017,.ERRARRAY)
+22 ;
+23 DO MES^XPDUTL
+24 ;
+25 ; ENVIRONMENT HAS ERROR(S)
IF XPDABORT>0
DO SORRYEND(.ERRARRAY,CP)
QUIT
+26 ;
+27 DO BOKAY^BLRPRE31("ENVIRONMENT")
+28 ;
+29 SET XUMF=1
+30 ;
+31 QUIT
+32 ;
WOTCNT() ; EP - Counter for ^XTMP
+1 NEW BLRVERN,CNT,TODAY
+2 ;
+3 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+4 SET TODAY=$$DT^XLFDT
+5 ;
+6 SET CNT=1+$GET(^XTMP(BLRVERN,0,TODAY))
+7 SET ^XTMP(BLRVERN,0,TODAY)=CNT
+8 QUIT $TRANSLATE($JUSTIFY(CNT,3)," ","0")
+9 ;
CHKLABMG ; EP - Check Lab Mail Groups
+1 NEW FNAME,LNAME,USERNAME
+2 ;
+3 SET USERNAME=$$UP^XLFSTR($$GET1^DIQ(200,DUZ,"NAME"))
SET LNAME=$PIECE(USERNAME,",")
SET FNAME=$PIECE(USERNAME,",",2)
+4 ;
+5 IF LNAME["WALKER"&((FNAME["MIKE")!(FNAME["MICHAEL"))
QUIT
+6 ;
+7 ; Check for LMI Mail Group
DO CHKMAILG(CP,"LMI",.ERRARRAY)
+8 ; Check for LAB MESSAGING Mail Group
DO CHKMAILG(CP,"LAB MESSAGING",.ERRARRAY)
+9 ; Check for BLRLINK Mail Group
DO CHKMAILG(CP,"BLRLINK",.ERRARRAY)
+10 QUIT
+11 ;
+12 ; Determine if required Mail Group Exists AND the Mail Group has at least
+13 ; one member who has logged onto RPMS in the past year
CHKMAILG(CP,MAILGRP,ERRARRAY) ; EP
+1 NEW MEM,MEMBER,MGRPIEN,MEMOKAY,VALIDMBR
+2 ;
+3 ; VA DBIA 1146
DO CHKGROUP^XMBGRP(MAILGRP,.MGRPIEN)
+4 ;
+5 IF +$GET(MGRPIEN)<1
Begin DoDot:1
+6 DO SORRY^BLRPRE31(CP,MAILGRP_" Mail Group Does NOT Exist!")
+7 SET ERRARRAY("XMB","Mail Group","3.8")=MAILGRP_" Mail Group Does NOT Exist!"
End DoDot:1
QUIT
+8 ;
+9 DO OKAY^BLRKIDSU(MAILGRP_" Mail Group Exists.")
+10 ;
+11 IF $$VALIDMBR(MGRPIEN)
DO OKAY^BLRKIDSU(MAILGRP_" Mail Group Has a Valid Member.",10)
QUIT
+12 ;
+13 DO SORRY^BLRPRE31(CP,"The "_MAILGRP_" Mail Group Exists but no Member of","FATAL",MAILGRP_" has logged onto RPMS within the past year!")
+14 SET ERRARRAY("XMB","Mail Group","3.8")=MAILGRP_" Mail Group Exists, but Does NOT have a Valid Member"
+15 QUIT
+16 ;
VALIDMBR(MGRPIEN) ; EP - Determine if Mail Group has at least one valid member
+1 SET MEM=.9999999
SET VALIDMBR=0
+2 ;
+3 FOR
SET MEM=$ORDER(^XMB(3.8,MGRPIEN,1,MEM))
IF MEM<1!(VALIDMBR)
QUIT
Begin DoDot:1
+4 SET MEMBER=+$$GET1^DIQ(3.81,MEM_","_MGRPIEN_",","MEMBER","I")
+5 ; If DISUSERed, not a Valid Member
IF +$$GET1^DIQ(200,MEMBER,"DISUSER")
QUIT
+6 ; If Terminated, not a Valid Member
IF +$$GET1^DIQ(200,MEMBER,"TERMINATION DATE","I")
QUIT
+7 ; Last Login Date
SET LASTLOGI=$$GET1^DIQ(200,MEMBER,202,"I")
+8 ; If Last Login > 364 days ago, not a Valid Member
IF $$FMDIFF^XLFDT($$NOW^XLFDT,LASTLOGI)>364
QUIT
+9 ;
+10 ; None of the above true, so valid member
SET VALIDMBR=MEMBER
End DoDot:1
+11 ;
+12 QUIT VALIDMBR
+13 ;
DEBUG ; EP - Debugging Line Label for environment checker
+1 NEW CP,DEBUG,RPMS,RPMSVER,QFLG,STR
+2 WRITE !!
+3 WRITE "Debug Begins:",$$TRIM^XLFSTR($PIECE($TEXT(+1),";"),"LR"," "),!!
+4 ;
+5 ; Note -- DEBUG is a negative flag:
+6 ; YES="Don't Send Alerts"; NO="Send Alerts"
+7 ;
+8 ; At this time, DO NOT send alerts
SET DEBUG="YES"
+9 ;
+10 ; D ^XBFMK
+11 ; S DIR(0)="YO"
+12 ; S DIR("B")="NO"
+13 ; S DIR("A")="Send Alerts/E-Mails"
+14 ; D ^DIR
+15 ; S:+$G(Y)=1 DEBUG="NO"
+16 ;
+17 WRITE !
+18 SET XPDNM="LR*5.2*"_$PIECE($TEXT(+2),"*",3)
+19 SET XPDENV=0
+20 ;
+21 DO ENVICHEK
+22 DO PRESSKEY^BLRGMENU(4)
+23 ;
+24 IF XPDABORT
QUIT
+25 ;
+26 DO PRE
+27 WRITE !!!
+28 ;
+29 DO ^XBFMK
+30 SET DIR(0)="YO"
+31 SET DIR("B")="NO"
+32 SET DIR("A")="Test Post Install Code"
+33 DO ^DIR
+34 ;
+35 DO EXIT^XPDID
+36 ;
+37 IF +$GET(Y)=1
Begin DoDot:1
+38 FOR MENUOPT="LRLIAISON","LR IHS LIAISON"
SET X=$$ADD^XPDMENU(MENUOPT,"LRLOINC")
+39 DO POST
End DoDot:1
+40 WRITE !!!
+41 ;
+42 ; Delete DEBUG Backup confirmation
+43 ; K ^BLRINSTL("LAB PATCH",$P(XPDNM,"*",3))
+44 ;
+45 WRITE !!,"Debug Ends:",$$TRIM^XLFSTR($PIECE($TEXT(+1),";"),"LR"," ")
+46 QUIT
+47 ;
PRE ; EP -- Ask for confirmation of Backup
+1 NEW BLRVERN,CNT,CP,CRTLINE,DIRASTR,FDAROOT,IEN,IENS,MSGROOT
+2 ; Current Patch,Backup count
NEW BCKUPCNT
+3 ;
+4 SET CP=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+5 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+6 ;
+7 SET XUMF=1
+8 ;
+9 DO INIT^XPDID
+10 DO TITLE^XPDID("LR*5.2*1033")
+11 WRITE !!
+12 DO BMES^XPDUTL("Pre-Install of "_BLRVERN_" Begins.")
+13 ;
+14 DO PASSMESG^BLRPRE31("ATTENTION")
+15 WRITE !
+16 ;
+17 DO ^XBFMK
+18 SET DIR(0)="Y"
+19 SET DIR("B")="NO"
+20 IF $GET(IOST)["C-VT"
SET DIRASTR=$JUSTIFY("",10)_"Has a "_$CHAR(27)_"[1;7;5m"_">> SUCCESSFUL <<"_$CHAR(27)_"[0m"_" backup been performed?"
+21 IF $GET(IOST)'["C-VT"
SET DIRASTR=$JUSTIFY("",10)_"Has a >> SUCCESSFUL << backup been performed?"
+22 SET DIR("A")=DIRASTR
+23 DO ^DIR
+24 WRITE !
+25 ;
+26 ; If BACKUP not performed, then ABORT installation.
IF +$GET(Y)'=1
Begin DoDot:1
+27 SET XPDABORT=1
+28 DO PASSMESG^BLRPRE31("ATTENTION")
+29 DO BMES^XPDUTL($JUSTIFY("",15)_"SUCCESSFUL system backup has >>> NOT <<< been confirmed.")
+30 DO BMES^XPDUTL($JUSTIFY("",25)_"Installer: "_$$GET1^DIQ(200,DUZ,"NAME")_" ["_DUZ_"].")
+31 DO BMES^XPDUTL($JUSTIFY("",15)_"Install Aborting.")
End DoDot:1
QUIT
+32 ;
+33 ; Store backup confirmation person & date/time
+34 SET BCKUPCNT=1+$ORDER(^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",""),-1)
+35 SET ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT)=DUZ_"^"_$PIECE($GET(^VA(200,DUZ,0)),U)
+36 SET ^BLRINSTL("LAB PATCH",CP,"BACKUP CONFIRMED BY",BCKUPCNT,"DATE/TIME")=$$HTE^XLFDT($HOROLOG,"5MZ")
+37 ;
+38 DO BOKAY^BLRPRE31("SUCCESSFUL system backup CONFIRMED by: "_$$GET1^DIQ(200,DUZ,"NAME")_".",5)
+39 ; Pause 1 second to let the user see the message.
HANG 1
+40 ;
+41 DO INIT^XPDID
+42 DO TITLE^XPDID("LR*5.2*1033")
+43 WRITE !!
+44 DO BMES^XPDUTL("Pre-Install of "_BLRVERN_" Continues.")
+45 ;
+46 DO FILESDEL
+47 ;
+48 DO COPYPROT
+49 ;
+50 DO BMES^XPDUTL($JUSTIFY("",5)_"Pre-Install Processing Ends at "_$$UP^XLFSTR($$HTE^XLFDT($HOROLOG,"5MPZ"))_".")
+51 ; Pause 1 second to let the user see the message.
HANG 1
+52 ;
+53 QUIT
+54 ;
FILESDEL ; EP - The following deletions are necessatry in order to prevent errors during installation
+1 NEW CNT,FILENUM,IEN
+2 ;
+3 ; Supposedly allows updating "locked down" dictionaries. Doesn't appear to work.
SET XUMF=1
+4 ;
+5 ; Disable Journaling prior to deletions
DO DISABLE^%NOJRN
+6 ;
+7 ; Delete Files' entries
+8 ; 95.3 = LOINC
+9 ; 95.31 = LAB LOINC COMPONENT
+10 ; 64.061 = LAB ELECTRONIC CODES
+11 ; 64.2 = WKLD SUFFIX CODES
+12 FOR FILENUM=95.3,95.31,64.061,64.2
Begin DoDot:1
+13 SET IEN=.9999999
SET CNT=0
+14 WRITE !,?4,FILENUM
+15 FOR
SET IEN=$ORDER(^LAB(FILENUM,IEN))
IF IEN<1
QUIT
Begin DoDot:2
+16 IF CNT#100=0
WRITE "."
IF $X>75
WRITE !,?4
+17 SET CNT=CNT+1
+18 DO ^XBFMK
+19 SET DIK="^LAB("_FILENUM_","
SET DA=IEN
+20 ; If DEBUG set, don't delete anything
IF $GET(DEBUG)="YES"
QUIT
+21 DO ^DIK
End DoDot:2
End DoDot:1
+22 ;
+23 WRITE !
+24 ;
+25 ; Restore Journaling
DO ENABLE^%NOJRN
+26 ;
+27 QUIT
+28 ;
COPYPROT ; EP - Have to copy the entries for LR7O ALL EVSEND RESULTS Protocol
+1 NEW ERRS,FOUND,IEN,PATCHNUM
+2 DO FIND^DIC(101,,,,"LR7O ALL EVSEND RESULTS",,,,,"FOUND","ERRS")
+3 IF $DATA(ERRS)
QUIT
+4 ;
+5 SET IEN=+$GET(FOUND("DILIST",2,1))
+6 IF IEN<1
QUIT
+7 ;
+8 SET PATCHNUM=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+9 ;
+10 SET ^XTMP("LR7O ALL EVSEND RESULTS",0)=$$HTFM^XLFDT(+$HOROLOG+90)_"^"_$$DT^XLFDT_"^LR*5.2*"_PATCHNUM_" PRE-INSTALL SAVE"
+11 MERGE ^XTMP("LR7O ALL EVSEND RESULTS",IEN)=^ORD(101,IEN)
+12 QUIT
+13 ;
POST ; EP -- POST INSTALL
+1 NEW BLRVERN,CHKIT,CP,ERRS,FDA,IEN,MENUOPT,NEWOPT,NEWOPTM,PATCHNUM,STR,TAB,TODAY,WOTCNT
+2 ;
+3 ; Current Patch
SET CP=$PIECE($TEXT(+2),"*",3)
+4 ;
+5 SET PATCHNUM=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+6 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+7 SET TODAY=$$DT^XLFDT
+8 SET WOTCNT=$$WOTCNT()
+9 ;
+10 DO BMES^XPDUTL("LR*5.2*"_CP_" Post Install")
+11 DO MES^XPDUTL(" ")
+12 ;
+13 ; Get rid of LOINC option on LRLIAISON & LR IHS LIAISON menus since it's deactivated
+14 FOR MENUOPT="LRLIAISON","LR IHS LIAISON"
Begin DoDot:1
+15 IF $$DELETE^XPDMENU(MENUOPT,"LRLOINC")<1
QUIT
+16 ;
+17 ; Deletion successful. Give feedback
+18 DO OKAY^BLRKIDSU("Obsolete VA LOINC option removed from "_MENUOPT_" menu.",0)
+19 DO MES^XPDUTL(" ")
End DoDot:1
+20 ;
+21 SET TAB=$JUSTIFY("",5)
+22 ;
+23 ; Add new options to BLRMENU
DO ADDOPTS
+24 ; Add new option to BLRREFLABMENU
DO ADDHLOPT
+25 ; LA7HDR entry in file 62.48 must be set to INACTIVE
DO TURNOFF
+26 ; Add new BLRZZ Security Key to BLRREFLABMENU option
DO NEWKEYON
+27 ; Add LRSUPER Security Key to LA MI VERIFY AUTO option
DO NEWKEYLA
+28 ; Make sure TAKE SNAPSHOTS field in BLR MASTER CONTROL is OFF
DO NOSNAPS
+29 ; Make sure GLUCOMETER is in the Terminolgoy Server Cache
DO GLUCACHE
+30 ;
+31 ; Run MAILMAN version of BLRLTRRR routine if DEBUG not YES
+32 IF $GET(DEBUG)'="YES"
DO EMAIL^BLRLTRRR
+33 ;
+34 ; Setup Instance of new parameter. Initially its value is NO.
+35 DO EN^XPAR("PKG","BLR CC DATA",,"NO",.ERRS)
+36 IF +$GET(ERRS)=0
DO MES^XPDUTL("Parameter 'BLR CC DATA' Instance set to NO.")
+37 ;
+38 DO ENDINSTL^BLRPRE31(CP)
+39 ;
+40 DO BMES^XPDUTL(" ")
+41 ;
+42 DO BMES^XPDUTL("Laboratory Patch "_CP_" INSTALL complete.")
+43 ;
+44 IF $GET(DEBUG)="YES"
SET ^XTMP(BLRVERN,TODAY,WOTCNT,"END")=$$NOW^XLFDT
QUIT
+45 ;
+46 SET STR(1)=" "
+47 SET STR(2)=$JUSTIFY("",10)_"POST INSTALL of "_BLRVERN_" Routine."
+48 SET STR(3)=" "
+49 SET STR(4)=$JUSTIFY("",15)_"Laboratory Patch "_CP_" INSTALL completed."
+50 SET STR(5)=" "
+51 ;
+52 ; Send E-Mail to LMI Mail Group & Installer
+53 DO MAILALMI^BLRUTIL3("Laboratory Patch "_CP_" INSTALL complete.",.STR,$TRANSLATE($PIECE($TEXT(+1),";")," "))
+54 ;
+55 SET ^XTMP(BLRVERN,TODAY,WOTCNT,"END")=$$NOW^XLFDT
+56 QUIT
+57 ;
ADDOPTS ; EP - Add new options to the BLRMENU
+1 FOR MENUOPT="BLR ADD COMPLETED DATE^DADD","BLR LAB TESTS REF RANGES^LTRR","BLR 62.49 HL7 SEGMENTS^6249","BLR LRAS MICRO REPORT^LRAS","BLR MU2 MICRO REPORT^IHSM","BLRSCRNTASKS^LABT"
Begin DoDot:1
+2 SET NEWOPT=$PIECE(MENUOPT,"^")
+3 SET NEWOPTM=$PIECE(MENUOPT,"^",2)
+4 DO BMES^XPDUTL("Adding '"_NEWOPT_"' option to BLRMENU.")
+5 SET X=$$ADD^XPDMENU("BLRMENU",NEWOPT,NEWOPTM)
+6 IF X=1
DO MES^XPDUTL(TAB_"'"_NEWOPT_"' added to BLRMENU. OK.")
+7 IF X'=1
Begin DoDot:2
+8 DO MES^XPDUTL(TAB_"Error in adding '"_NEWOPT_"' option to BLRMENU.")
+9 DO MES^XPDUTL(TAB_TAB_"Error Message: "_$$UP^XLFSTR($PIECE(X,"^",2)))
End DoDot:2
End DoDot:1
+10 ;
+11 DO MES^XPDUTL(" ")
+12 QUIT
+13 ;
ADDHLOPT ; EP - Add new option to the BLRREFLABMENU
+1 FOR MENUOPT="BLR REFLAB HL7 TABLE LOOKUP^TBLL","BLR REFLAB MONITOR PARAMS^MON"
Begin DoDot:1
+2 SET NEWOPT=$PIECE(MENUOPT,"^")
+3 SET NEWOPTM=$PIECE(MENUOPT,"^",2)
+4 DO BMES^XPDUTL("Adding '"_NEWOPT_"' option to BLRREFLABMENU.")
+5 SET X=$$ADD^XPDMENU("BLRREFLABMENU",NEWOPT,NEWOPTM)
+6 IF X=1
DO MES^XPDUTL(TAB_"'"_NEWOPT_"' added to BLRREFLABMENU. OK.")
+7 IF X'=1
Begin DoDot:2
+8 DO MES^XPDUTL(TAB_"Error in adding '"_NEWOPT_"' option to BLRMENU.")
+9 DO MES^XPDUTL(TAB_TAB_"Error Message: "_$$UP^XLFSTR($PIECE(X,"^",2)))
End DoDot:2
End DoDot:1
+10 ;
+11 DO MES^XPDUTL(" ")
+12 QUIT
+13 ;
TURNOFF ; EP - LA7HDR entry in file 62.48 must be set to INACTIVE
+1 NEW ERRS,FDA,IEN
+2 ;
+3 SET IEN=+$$FIND1^DIC(62.48,,,"LA7HDR")
+4 ; Skip if LA7HDR parameter does not exist
IF IEN<1
QUIT
+5 ;
+6 DO BMES^XPDUTL("Inactivating 'LA7HDR' parameter in 62.48.")
+7 ;
+8 DO ^XBFMK
+9 KILL FDA
+10 ; Setting STATUS field to INACTIVE
SET FDA(62.48,IEN_",",2)=0
+11 DO FILE^DIE("KS","FDA","ERRS")
+12 ;
+13 IF $DATA(ERRS)<1
Begin DoDot:1
+14 DO OKAY^BLRKIDSU("'LA7HDR' parameter in 62.48 Inactivated.",5)
+15 DO MES^XPDUTL(" ")
End DoDot:1
QUIT
+16 ;
+17 DO NOTOKAY("'LA7HDR' parameter in 62.48 *NOT* Inactivated.",5)
+18 DO SNDALERT^BLRUTIL3("'LA7HDR' parameter in 62.48 *NOT* Inactivated.")
+19 ;
+20 QUIT
+21 ;
NEWKEYON ; EP - Make sure new BLRRLZ Security Key is added to BLRREFLABMENU option
+1 NEW ERRS,FDA,IEN
+2 SET IEN=+$$LKOPT^XPDMENU("BLRREFLABMENU")
+3 ; Skip if cannot find Ref Lab Menu option
IF IEN<1
QUIT
+4 ;
+5 DO ^XBFMK
+6 SET FDA(19,IEN_",",3)="BLRRLZ"
+7 DO FILE^DIE(,"FDA","ERRS")
+8 QUIT
+9 ;
NEWKEYLA ; EP - Add LRSUPER Security Key to LA MI VERIFY AUTO option
+1 NEW ERRS,FDA,IEN
+2 SET IEN=+$$LKOPT^XPDMENU("LA MI VERIFY AUTO")
+3 ; Skip if cannot find Ref Lab Menu option
IF IEN<1
QUIT
+4 ;
+5 DO ^XBFMK
+6 SET FDA(19,IEN_",",3)="LRSUPER"
+7 DO FILE^DIE(,"FDA","ERRS")
+8 QUIT
+9 ;
NOSNAPS ; EP - Make certain TAKE SNAPSHOTS field in BLR MASTER CONTROL file is OFF
+1 NEW CNT,DESC,FDA,IEN
+2 ;
+3 SET (CNT,IEN)=0
+4 FOR
SET IEN=$ORDER(^BLRSITE(IEN))
IF IEN<1
QUIT
Begin DoDot:1
+5 IF +$$GET1^DIQ(9009029,IEN,"TAKE SNAPSHOTS","I")<1
QUIT
+6 ;
+7 SET CNT=CNT+1
SET CNT(IEN)=""
+8 KILL FDA
+9 SET FDA(9009029,IEN_",",1)=0
+10 DO FILE^DIE(,"FDA","ERRS")
End DoDot:1
+11 ;
+12 ; If no update, just return
IF CNT<1
QUIT
+13 ;
+14 DO BMES^XPDUTL("File 9009029 'TAKE SNAPSHOTS' Field Set to OFF for the following:")
+15 SET IEN=0
+16 FOR
SET IEN=$ORDER(CNT(IEN))
IF IEN<1
QUIT
DO TABMENU^BLRKIDSU($$GET1^DIQ(9009029,IEN,.01),5)
+17 DO BMES^XPDUTL
+18 QUIT
+19 ;
NOTOKAY(MSG,TAB) ; EP -- Write out Blank line, then "NOT OKAY" message
+1 DO BMES^XPDUTL($JUSTIFY("",+$GET(TAB))_MSG_" NOT OK.")
+2 QUIT
+3 ;
GLUCACHE ; EP - Make sure IHS Terminology Server has GLUCOMETER in its cache
+1 NEW IN,OUT,VARS
+2 SET OUT="VARS"
SET IN="GLUCOMETER^F^^ALL"
+3 SET X=$$SEARCH^BSTSAPI(OUT,IN)
+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^BLRPRE31
+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
DO ADDMESG
End DoDot:2
End DoDot:1
+9 ;
+10 DO SORRYFIN^BLRPRE31
+11 ;
+12 DO BMES^XPDUTL(.STR)
+13 ;
+14 QUIT
+15 ;
ADDMESG ; EP
+1 NEW WOT,WOTWRONG
+2 ;
+3 DO ADDLINE^BLRPRE31(.LINECNT,NAME_" ("_MODULE_")","YES")
+4 ;
+5 SET WOT=$GET(WOTERR(MODULE,NAME,VERSION))
+6 SET TMP="Version:"_VERSION
+7 SET WOTWRONG=$PIECE(WOT,"^",2)
+8 ;
+9 IF WOTWRONG="VERSION"
Begin DoDot:1
+10 SET TMP="Needed Version:"_VERSION
+11 SET TMP=TMP_" Found Version:"_$PIECE(WOT,"^")
End DoDot:1
+12 ;
+13 IF WOTWRONG="PATCH"
Begin DoDot:1
+14 SET TMP=TMP_" Needed Patch:"_$PIECE(WOT,"^")
End DoDot:1
+15 ;
+16 IF WOTWRONG'="PATCH"&(WOTWRONG'="VERSION")
Begin DoDot:1
+17 DO ADDLINE^BLRPRE31(.LINECNT,TMP,"YES")
+18 SET TMP=WOT
End DoDot:1
+19 ;
+20 DO ADDLINE^BLRPRE31(.LINECNT,TMP,"YES")
+21 DO ADDLINE^BLRPRE31(.LINECNT)
+22 QUIT
