BLRPRE20 ; IHS/ITSC/MKK - ENVIRONMENT CHECK FOR PATCH 20; [ 07/22/2005 ]
;;5.2;LR;**1020**;Sep 13, 2005
;
NEW CP ; Current Patch
S CP=$TR($P($T(+2),";",5),"*")
;
NEW LRSTATUS ; Install Status
;
S $P(LINE,"*",81)=""
S XPDNOQUE="NO QUE" ;NO QUEUING ALLOWED
; DISABLE THE "Disable options..." and "Move routines..."
; questions from being asked during install
S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
S XPDDIQ("XPO1")=0 ;DISABLE "Rebuild Menu Tree" question
S XPDABORT=0
;
I '$G(DUZ) D SORRY("DUZ UNDEFINED OR 0.") Q
;
I '$L($G(DUZ(0))) D SORRY("DUZ(0) UNDEFINED OR NULL.") Q
;
D HOME^%ZIS,DT^DICRW
S X=$P($G(^VA(200,DUZ,0)),U)
I $G(X) D SORRY("Installer cannot be identified!") Q
;
D BMES^XPDUTL("Hello, "_$P(X,",",2)_" "_$P(X,","))
;
D BMES^XPDUTL("Checking Environment for Patch "_$P($T(+2),";",5)_" of Version "_$P($T(+2),";",3)_" of "_$P($T(+2),";",4)_".")
;
S X=$G(^DD("VERSION"))
D BMES^XPDUTL("Need at least FileMan 22.0")
I X<22 D SORRY("Need FileMan 22.0 & FileMan "_X_" found!") Q
D OKAY("FileMan "_X_" found.")
;
S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","XU",0)),"VERSION"))
D BMES^XPDUTL("Need at least Kernel 8.0.")
I X<8.0 D SORRY("Need Kernel 8.0 & Kernel "_X_" found!") Q
D OKAY("Kernel "_X_" found.")
;
D BMES^XPDUTL("Must have 'LMI' mail group present.")
I $$CHECKLMI<0 D SORRY("'LMI' mail group NOT found!") Q
D OKAY("'LMI' mail group found.")
;
D BMES^XPDUTL("Must have Order Entry/Results Reporting.")
I '$O(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING","")) D Q
. D SORRY("Order Entry/Results Reporting NOT found!")
D OKAY("Order Entry/Results Reporting found.")
;
S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","PIMS",0)),"VERSION"))
D BMES^XPDUTL("Need at least PIMS 5.3.")
I X<5.3 D SORRY("Need PIMS 5.3 & PIMS "_X_" found!") Q
D OKAY("PIMS "_X_" found.")
;
; First, make sure Lexicon, in some form, exists
S X=$O(^DIC(9.4,"C","LEX",0))
I $G(X)="" D Q
. D BMES^XPDUTL("Must have Lexicon.")
. D SORRY("Need LEXICON and LEXICON NOT FOUND!")
;
; Now, check the Lexicon version number
S X=$G(^DIC(9.4,$O(^DIC(9.4,"C","LEX",0)),"VERSION"))
I X="" S X="Version Number NOT"
D BMES^XPDUTL("Need at least LEXICON 2.0.")
I X<2.0 D SORRY("Need LEXICON 2.0 & LEXICON "_X_" found!") Q
D OKAY("LEXICON "_X_" found.")
;
; Check for the existance of the REPORTABLE LAB TESTS dictionary.
; If it exists & current patch has NOT installed successfully, quit
S LRSTATUS=""
S %=$O(^XPD(9.7,"B","LR*5.2*"_CP,"")) ; Check if 1020 already installed.
I %'="" S LRSTATUS=$P($G(^XPD(9.7,%,0)),U,9)
I $D(^DD(90475))>0&(LRSTATUS'=3) D SORRY("DD 90475 Exists Prior to Install.") Q
;
; Check for the existance of the LAB PROV LOC CHANGE dictionary.
; If it exists & current patch has NOT installed successfully, quit
I $D(^DD(90475.2))>0&(LRSTATUS'=3) D SORRY("DD 90475.2 Exists Prior to Install.") Q
;
VERSION ;
;CHECK FOR PREVIOUS PATCH NEEDED
NEW LASTPTCH
S LASTPTCH=+$TR($P($T(+2),";",5),"*")-1
D BMES^XPDUTL("Need Lab Patch "_LASTPTCH_" to have been installed.")
I $D(^XPD(9.7,"B","LR*5.2*"_LASTPTCH))<1 D SORRY("Patch "_LASTPTCH_" WAS NOT installed!") Q
;
;GET INSTALL STATUS
NEW LRSTATUS
S LRSTATUS=0
S %=$O(^XPD(9.7,"B","LR*5.2*"_LASTPTCH,""))
I %'="" S LRSTATUS=$P($G(^XPD(9.7,%,0)),U,9)
I LRSTATUS'=3 D Q
. D SORRY("Install of Lab Patch "_LASTPTCH_" NOT complete. Status: "_LRSTATUS_"!")
;
D OKAY("Lab Patch "_LASTPTCH_" installed & Status complete.")
;
ENVOK ; If this is just an environ check, end here.
D BMES^XPDUTL("ENVIRONMENT OK.")
;
; The following line prevents the "Disable Options..." and "Move
; Routines..." questions from being asked during the install.
I $G(XPDENV)=1 S (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
;
;VERIFY BACKUPS HAVE BEEN DONE
W !!
D ^XBFMK
S DIR(0)="Y"
S DIR("B")="NO"
S DIR("A")="Has a SUCCESSFUL system backup been performed??"
D ^DIR
I $D(DIRUT)!($G(Y)=0) D BMES^XPDUTL("Please perform a successful backup before continuing!!") S XPDABORT=1 Q
S %DT="R",X="NOW" D ^%DT X ^DD("DD")
D BMES^XPDUTL("BACKUPS CONFIRMED BY "_$P($G(^VA(200,DUZ,0)),U)_" ON "_$P(Y,"@")_" AT "_$P(Y,"@",2))
S ^BLRINSTL(CP,"INSTALLED BY")=$P($G(^VA(200,DUZ,0)),U)
;
Q
;
SORRY(MSG,MODE) ;
NEW MESSAGE
I $G(MODE)'["NONFATAL" D
. S MESSAGE="Install Aborting due to the following Systems Environment issue:"
. S XPDABORT=1
;
I $G(MODE)["NONFATAL" S MESSAGE="*** WARNING *** WARNING *** WARNING ***"
;
K DIFQ
;
NEW STR
S STR(1)=""
S STR(2)=$TR($J("",65)," ","*")
S STR(3)=" "
S STR(4)=$$CJ^XLFSTR("Site: "_$$LOC^XBFUNC,65)
S STR(5)=" "
S STR(6)=$$CJ^XLFSTR(MESSAGE,65)
S STR(7)=" "
S STR(8)=$$CJ^XLFSTR(">>> "_MSG_" <<<",65)
S STR(9)=" "
S STR(10)=$$CJ^XLFSTR("Please print/capture this screen and",65)
S STR(11)=$$CJ^XLFSTR("notify the Support Center at",65)
S STR(12)=""
S STR(13)=$$CJ^XLFSTR("1-999-999-9999.",65)
S STR(14)=" "
S STR(15)=$G(STR(2))
S STR(16)=""
D BMES^XPDUTL(.STR)
;
S XQAMSG="FATAL >> "_MSG
I $G(MODE)["NONFATAL" S XQAMSG=MODE_" - "_MSG
S XQA("G.LMI")=""
D SETUP^XQALERT
Q
;
OKAY(MSG,TAB) ;
NEW MESSAGE
I $G(TAB)="" S TAB=5
S MESSAGE=$J("",TAB)_MSG_" OK."
D MES^XPDUTL(MESSAGE)
Q
;
;CHECK FOR LMI MAIL GROUP
CHECKLMI() ;
S DIC="^XMB(3.8,"
S X="LMI"
D ^DIC
Q +Y
;
; POST-INSTALL
POST ;
NEW CP ; Current Patch
S CP=$TR($P($T(+2),";",5),"*")
;
NEW CRLF ; Carriage-Return-Line-Feed
S CRLF=$C(13)_$C(10)
;
D BMES^XPDUTL("Laboratory Patch "_CP_" POST INSTALL...")
;
D LABFIXLU ; Fix lookup in COMPUTED AGE field
;
D LAB60FIX ; Fix File 60's invalid Urgency entries.
;
; Add Options to the BLRMENU
D BMES^XPDUTL(" Updating OPTIONS")
D ADDBMENU("BLREPOLR","EDT") ; Change Provider/Location Menu
D ADDBMENU("BLRSHDRC","SHDR") ; State Health Dept Report
D OKAY("Updating OPTIONS.",5)
;
; Change the Default maximum Max Order Freq of ordering tests to 365.
D CHNGMOFD
;
D BMES^XPDUTL("Laboratory Patch "_CP_" POST INSTALL complete."_CRLF_CRLF)
;
S XQAMSG="Laboratory Patch "_CP_" INSTALL complete."
S XQA("G.LMI")=""
D SETUP^XQALERT
Q
;
LABFIXLU ;
; Fix issue with strange things occurring when people use FileMan
; to look up Lab Data and want computed values. This is a flaw in the
; lookup routine. Need to change the "NMF" below to "INMF"
; ^DD(63.04,999999901,9.3)=X ^DD(63.04,999999901,9.2) S Y=$P(Y(63.04,999999901,1),
; VU,3) X:$D(^DD(63,.03,2)) ^(2) S X=Y K DIC S DIC="^AUPNPAT(",DIC(0)="NMF" D ^DIC
; S (D,D0)=+Y
;
I $D(^DD(63.04,999999901,9.3))<1 Q ; If it doesn't exist, skip
;
; If field doesn't exist, skip
I $P($G(^DD(63.04,999999901,9.3)),$C(34),4)="" Q
;
D BMES^XPDUTL(" Correcting ^DD(63.04,999999901,9.3) entry")
I $P($G(^DD(63.04,999999901,9.3)),$C(34),4)="INMF" D
. D OKAY("^DD(63.04,999999901,9.3) entry Already Corrected.",10)
I $P($G(^DD(63.04,999999901,9.3)),$C(34),4)'="INMF" D
. S $P(^DD(63.04,999999901,9.3),$C(34),4)="INMF" ; Ignore special lookup
. D OKAY("^DD(63.04,999999901,9.3) entry Corrected.",10)
;
Q
;
LAB60FIX ;
; Fix File 60's invalid Urgency entries. Left over from
; 5.1 to 5.2 Upgrade, I believe.
;
D BMES^XPDUTL(" Checking File 60 (Laboratory Test) for invalid")
D MES^XPDUTL(" HIGHEST URGENCY ALLOWED entries.")
;
NEW IEN,CNT
S IEN="",CNT=0
F S IEN=$O(^LAB(60,IEN)) Q:IEN=""!(CNT>0) D
. I $P($G(^LAB(60,IEN,0)),"^",16)'=2 Q ; 2 is invalid.
. ;
. S $P(^LAB(60,IEN,0),"^",16)=9 ; Set to ROUTINE urgency
;
I CNT<1 D OKAY("No invalid HIGHEST URGENCY ALLOWED entries detected.",10)
;
I CNT=1 D ; Single change verbage
. S STR=" In File 60 (Laboratory Test) there was "_CNT_CRLF
. S STR=STR_" invalid HIGHEST URGENCY ALLOWED entry."_CRLF
. S STR=STR_" This URGENCY has been changed to ROUTINE. OK."_CRLF
;
I CNT>1 D ; Multiple change verbage
. S STR=" In File 60 (Laboratory Test) there were "_CNT_CRLF
. S STR=STR_" invalid HIGHEST URGENCY ALLOWED entries."_CRLF
. S STR=STR_" They have been changed to ROUTINE. OK."_CRLF
;
I CNT>0 D MES^XPDUTL(STR)
;
Q
;
; Add item to BLRMENU
NEW FDA,ERR,HEREYAGO,MIEN,BLRIEN
;
D MES^XPDUTL(" Adding "_ADDM_" to BLRMENU.")
;
; First, Get BLRMENU IEN
D FIND^DIC(19,"","","","BLRMENU","","","","","HEREYAGO")
S BLRIEN=$G(HEREYAGO("DILIST",2,1))
;
; Cleanup
D ^XBFMK
K HEREYAGO
;
; Next, get IEN for Option
D FIND^DIC(19,"","","",ADDM,"","","","","HEREYAGO")
S MIEN=$G(HEREYAGO("DILIST",2,1))
;
; Make sure OPTION exists
I $G(MIEN)="" D SORRY("Could not find "_ADDM_" Option","NONFATAL") Q
;
; Now, check to see if Option already there -- if so, Quit
I $D(^DIC(19,BLRIEN,10,"B",MIEN)) D Q
. D OKAY(ADDM_" already on BLRMENU. No further processing.",15)
;
S FDA(42,19,"?1,",.01)="BLRMENU"
S FDA(42,19.01,"+2,?1,",.01)=MIEN
S FDA(42,19.01,"+2,?1,",2)=SYNM ; SYNONYM (1-4 Chars)
;
D UPDATE^DIE("","FDA(42)",,"")
;
I $D(^TMP("DIERR",$J))>0 D Q
. D SORRY("Error in adding "_ADDM_" to BLRMENU. $J="_$J_".","NONFATAL")
;
D OKAY(ADDM_" added to BLRMENU. $J="_$J_".",15)
;
Q
;
CHNGMOFD ;
NEW SPEC,STR,SUBSTR
NEW WOTDD
;
D BMES^XPDUTL(" Changing Max Order Freq Default for Lab Tests to 365.")
S STR=$G(^DD(60.03,4,0))
S SUBSTR=$P($P($P(STR,"^",5),">",2),")",1)
I $L(SUBSTR)'=3 D Q
. D SORRY("Could not change Max Order Freq Default String","NONFATAL")
;
I +SUBSTR=365 D Q
. D OKAY("Max Order Freq Default already 365.",10)
;
I +SUBSTR'=365 D
. S SPEC(SUBSTR)=365
. S STR=$$REPLACE^XLFSTR(STR,.SPEC)
. S WOTDD="^DD(60.03,4,0)"
. S @WOTDD=STR
. D OKAY("Changed Max Order Freq Default.",10)
;
K SPEC
S STR=$G(^DD(60.03,4,3))
S SUBSTR=$RE($P($RE($P(STR,",",1))," ",1))
I $L(SUBSTR)'=3 D Q
. D SORRY("Could not change Max Order Freq Default HELP String","NONFATAL")
;
I +SUBSTR=365 D
. D OKAY("Max Order Freq Default HELP String already 365.",10)
;
I +SUBSTR'=365 D
. S SPEC(SUBSTR)=365
. S STR=$$REPLACE^XLFSTR(STR,.SPEC)
. S WOTDD="^DD(60.03,4,3)"
. S @WOTDD=STR
. D OKAY("Changed Max Order Freq Default HELP.",10)
;
D OKAY("Max Order Freq Default.")
;
Q
BLRPRE20 ; IHS/ITSC/MKK - ENVIRONMENT CHECK FOR PATCH 20; [ 07/22/2005 ]
+1 ;;5.2;LR;**1020**;Sep 13, 2005
+2 ;
+3 ; Current Patch
NEW CP
+4 SET CP=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+5 ;
+6 ; Install Status
NEW LRSTATUS
+7 ;
+8 SET $PIECE(LINE,"*",81)=""
+9 ;NO QUEUING ALLOWED
SET XPDNOQUE="NO QUE"
+10 ; DISABLE THE "Disable options..." and "Move routines..."
+11 ; questions from being asked during install
+12 SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+13 ;DISABLE "Rebuild Menu Tree" question
SET XPDDIQ("XPO1")=0
+14 SET XPDABORT=0
+15 ;
+16 IF '$GET(DUZ)
DO SORRY("DUZ UNDEFINED OR 0.")
QUIT
+17 ;
+18 IF '$LENGTH($GET(DUZ(0)))
DO SORRY("DUZ(0) UNDEFINED OR NULL.")
QUIT
+19 ;
+20 DO HOME^%ZIS
DO DT^DICRW
+21 SET X=$PIECE($GET(^VA(200,DUZ,0)),U)
+22 IF $GET(X)
DO SORRY("Installer cannot be identified!")
QUIT
+23 ;
+24 DO BMES^XPDUTL("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","))
+25 ;
+26 DO BMES^XPDUTL("Checking Environment for Patch "_$PIECE($TEXT(+2),";",5)_" of Version "_$PIECE($TEXT(+2),";",3)_" of "_$PIECE($TEXT(+2),";",4)_".")
+27 ;
+28 SET X=$GET(^DD("VERSION"))
+29 DO BMES^XPDUTL("Need at least FileMan 22.0")
+30 IF X<22
DO SORRY("Need FileMan 22.0 & FileMan "_X_" found!")
QUIT
+31 DO OKAY("FileMan "_X_" found.")
+32 ;
+33 SET X=$GET(^DIC(9.4,$ORDER(^DIC(9.4,"C","XU",0)),"VERSION"))
+34 DO BMES^XPDUTL("Need at least Kernel 8.0.")
+35 IF X<8.0
DO SORRY("Need Kernel 8.0 & Kernel "_X_" found!")
QUIT
+36 DO OKAY("Kernel "_X_" found.")
+37 ;
+38 DO BMES^XPDUTL("Must have 'LMI' mail group present.")
+39 IF $$CHECKLMI<0
DO SORRY("'LMI' mail group NOT found!")
QUIT
+40 DO OKAY("'LMI' mail group found.")
+41 ;
+42 DO BMES^XPDUTL("Must have Order Entry/Results Reporting.")
+43 IF '$ORDER(^DIC(9.4,"B","ORDER ENTRY/RESULTS REPORTING",""))
Begin DoDot:1
+44 DO SORRY("Order Entry/Results Reporting NOT found!")
End DoDot:1
QUIT
+45 DO OKAY("Order Entry/Results Reporting found.")
+46 ;
+47 SET X=$GET(^DIC(9.4,$ORDER(^DIC(9.4,"C","PIMS",0)),"VERSION"))
+48 DO BMES^XPDUTL("Need at least PIMS 5.3.")
+49 IF X<5.3
DO SORRY("Need PIMS 5.3 & PIMS "_X_" found!")
QUIT
+50 DO OKAY("PIMS "_X_" found.")
+51 ;
+52 ; First, make sure Lexicon, in some form, exists
+53 SET X=$ORDER(^DIC(9.4,"C","LEX",0))
+54 IF $GET(X)=""
Begin DoDot:1
+55 DO BMES^XPDUTL("Must have Lexicon.")
+56 DO SORRY("Need LEXICON and LEXICON NOT FOUND!")
End DoDot:1
QUIT
+57 ;
+58 ; Now, check the Lexicon version number
+59 SET X=$GET(^DIC(9.4,$ORDER(^DIC(9.4,"C","LEX",0)),"VERSION"))
+60 IF X=""
SET X="Version Number NOT"
+61 DO BMES^XPDUTL("Need at least LEXICON 2.0.")
+62 IF X<2.0
DO SORRY("Need LEXICON 2.0 & LEXICON "_X_" found!")
QUIT
+63 DO OKAY("LEXICON "_X_" found.")
+64 ;
+65 ; Check for the existance of the REPORTABLE LAB TESTS dictionary.
+66 ; If it exists & current patch has NOT installed successfully, quit
+67 SET LRSTATUS=""
+68 ; Check if 1020 already installed.
SET %=$ORDER(^XPD(9.7,"B","LR*5.2*"_CP,""))
+69 IF %'=""
SET LRSTATUS=$PIECE($GET(^XPD(9.7,%,0)),U,9)
+70 IF $DATA(^DD(90475))>0&(LRSTATUS'=3)
DO SORRY("DD 90475 Exists Prior to Install.")
QUIT
+71 ;
+72 ; Check for the existance of the LAB PROV LOC CHANGE dictionary.
+73 ; If it exists & current patch has NOT installed successfully, quit
+74 IF $DATA(^DD(90475.2))>0&(LRSTATUS'=3)
DO SORRY("DD 90475.2 Exists Prior to Install.")
QUIT
+75 ;
VERSION ;
+1 ;CHECK FOR PREVIOUS PATCH NEEDED
+2 NEW LASTPTCH
+3 SET LASTPTCH=+$TRANSLATE($PIECE($TEXT(+2),";",5),"*")-1
+4 DO BMES^XPDUTL("Need Lab Patch "_LASTPTCH_" to have been installed.")
+5 IF $DATA(^XPD(9.7,"B","LR*5.2*"_LASTPTCH))<1
DO SORRY("Patch "_LASTPTCH_" WAS NOT installed!")
QUIT
+6 ;
+7 ;GET INSTALL STATUS
+8 NEW LRSTATUS
+9 SET LRSTATUS=0
+10 SET %=$ORDER(^XPD(9.7,"B","LR*5.2*"_LASTPTCH,""))
+11 IF %'=""
SET LRSTATUS=$PIECE($GET(^XPD(9.7,%,0)),U,9)
+12 IF LRSTATUS'=3
Begin DoDot:1
+13 DO SORRY("Install of Lab Patch "_LASTPTCH_" NOT complete. Status: "_LRSTATUS_"!")
End DoDot:1
QUIT
+14 ;
+15 DO OKAY("Lab Patch "_LASTPTCH_" installed & Status complete.")
+16 ;
ENVOK ; If this is just an environ check, end here.
+1 DO BMES^XPDUTL("ENVIRONMENT OK.")
+2 ;
+3 ; The following line prevents the "Disable Options..." and "Move
+4 ; Routines..." questions from being asked during the install.
+5 IF $GET(XPDENV)=1
SET (XPDDIQ("XPZ1"),XPDDIQ("XPZ2"))=0
+6 ;
+7 ;VERIFY BACKUPS HAVE BEEN DONE
+8 WRITE !!
+9 DO ^XBFMK
+10 SET DIR(0)="Y"
+11 SET DIR("B")="NO"
+12 SET DIR("A")="Has a SUCCESSFUL system backup been performed??"
+13 DO ^DIR
+14 IF $DATA(DIRUT)!($GET(Y)=0)
DO BMES^XPDUTL("Please perform a successful backup before continuing!!")
SET XPDABORT=1
QUIT
+15 SET %DT="R"
SET X="NOW"
DO ^%DT
XECUTE ^DD("DD")
+16 DO BMES^XPDUTL("BACKUPS CONFIRMED BY "_$PIECE($GET(^VA(200,DUZ,0)),U)_" ON "_$PIECE(Y,"@")_" AT "_$PIECE(Y,"@",2))
+17 SET ^BLRINSTL(CP,"INSTALLED BY")=$PIECE($GET(^VA(200,DUZ,0)),U)
+18 ;
+19 QUIT
+20 ;
SORRY(MSG,MODE) ;
+1 NEW MESSAGE
+2 IF $GET(MODE)'["NONFATAL"
Begin DoDot:1
+3 SET MESSAGE="Install Aborting due to the following Systems Environment issue:"
+4 SET XPDABORT=1
End DoDot:1
+5 ;
+6 IF $GET(MODE)["NONFATAL"
SET MESSAGE="*** WARNING *** WARNING *** WARNING ***"
+7 ;
+8 KILL DIFQ
+9 ;
+10 NEW STR
+11 SET STR(1)=""
+12 SET STR(2)=$TRANSLATE($JUSTIFY("",65)," ","*")
+13 SET STR(3)=" "
+14 SET STR(4)=$$CJ^XLFSTR("Site: "_$$LOC^XBFUNC,65)
+15 SET STR(5)=" "
+16 SET STR(6)=$$CJ^XLFSTR(MESSAGE,65)
+17 SET STR(7)=" "
+18 SET STR(8)=$$CJ^XLFSTR(">>> "_MSG_" <<<",65)
+19 SET STR(9)=" "
+20 SET STR(10)=$$CJ^XLFSTR("Please print/capture this screen and",65)
+21 SET STR(11)=$$CJ^XLFSTR("notify the Support Center at",65)
+22 SET STR(12)=""
+23 SET STR(13)=$$CJ^XLFSTR("1-999-999-9999.",65)
+24 SET STR(14)=" "
+25 SET STR(15)=$GET(STR(2))
+26 SET STR(16)=""
+27 DO BMES^XPDUTL(.STR)
+28 ;
+29 SET XQAMSG="FATAL >> "_MSG
+30 IF $GET(MODE)["NONFATAL"
SET XQAMSG=MODE_" - "_MSG
+31 SET XQA("G.LMI")=""
+32 DO SETUP^XQALERT
+33 QUIT
+34 ;
OKAY(MSG,TAB) ;
+1 NEW MESSAGE
+2 IF $GET(TAB)=""
SET TAB=5
+3 SET MESSAGE=$JUSTIFY("",TAB)_MSG_" OK."
+4 DO MES^XPDUTL(MESSAGE)
+5 QUIT
+6 ;
+7 ;CHECK FOR LMI MAIL GROUP
CHECKLMI() ;
+1 SET DIC="^XMB(3.8,"
+2 SET X="LMI"
+3 DO ^DIC
+4 QUIT +Y
+5 ;
+6 ; POST-INSTALL
POST ;
+1 ; Current Patch
NEW CP
+2 SET CP=$TRANSLATE($PIECE($TEXT(+2),";",5),"*")
+3 ;
+4 ; Carriage-Return-Line-Feed
NEW CRLF
+5 SET CRLF=$CHAR(13)_$CHAR(10)
+6 ;
+7 DO BMES^XPDUTL("Laboratory Patch "_CP_" POST INSTALL...")
+8 ;
+9 ; Fix lookup in COMPUTED AGE field
DO LABFIXLU
+10 ;
+11 ; Fix File 60's invalid Urgency entries.
DO LAB60FIX
+12 ;
+13 ; Add Options to the BLRMENU
+14 DO BMES^XPDUTL(" Updating OPTIONS")
+15 ; Change Provider/Location Menu
DO ADDBMENU("BLREPOLR","EDT")
+16 ; State Health Dept Report
DO ADDBMENU("BLRSHDRC","SHDR")
+17 DO OKAY("Updating OPTIONS.",5)
+18 ;
+19 ; Change the Default maximum Max Order Freq of ordering tests to 365.
+20 DO CHNGMOFD
+21 ;
+22 DO BMES^XPDUTL("Laboratory Patch "_CP_" POST INSTALL complete."_CRLF_CRLF)
+23 ;
+24 SET XQAMSG="Laboratory Patch "_CP_" INSTALL complete."
+25 SET XQA("G.LMI")=""
+26 DO SETUP^XQALERT
+27 QUIT
+28 ;
LABFIXLU ;
+1 ; Fix issue with strange things occurring when people use FileMan
+2 ; to look up Lab Data and want computed values. This is a flaw in the
+3 ; lookup routine. Need to change the "NMF" below to "INMF"
+4 ; ^DD(63.04,999999901,9.3)=X ^DD(63.04,999999901,9.2) S Y=$P(Y(63.04,999999901,1),
+5 ; VU,3) X:$D(^DD(63,.03,2)) ^(2) S X=Y K DIC S DIC="^AUPNPAT(",DIC(0)="NMF" D ^DIC
+6 ; S (D,D0)=+Y
+7 ;
+8 ; If it doesn't exist, skip
IF $DATA(^DD(63.04,999999901,9.3))<1
QUIT
+9 ;
+10 ; If field doesn't exist, skip
+11 IF $PIECE($GET(^DD(63.04,999999901,9.3)),$CHAR(34),4)=""
QUIT
+12 ;
+13 DO BMES^XPDUTL(" Correcting ^DD(63.04,999999901,9.3) entry")
+14 IF $PIECE($GET(^DD(63.04,999999901,9.3)),$CHAR(34),4)="INMF"
Begin DoDot:1
+15 DO OKAY("^DD(63.04,999999901,9.3) entry Already Corrected.",10)
End DoDot:1
+16 IF $PIECE($GET(^DD(63.04,999999901,9.3)),$CHAR(34),4)'="INMF"
Begin DoDot:1
+17 ; Ignore special lookup
SET $PIECE(^DD(63.04,999999901,9.3),$CHAR(34),4)="INMF"
+18 DO OKAY("^DD(63.04,999999901,9.3) entry Corrected.",10)
End DoDot:1
+19 ;
+20 QUIT
+21 ;
LAB60FIX ;
+1 ; Fix File 60's invalid Urgency entries. Left over from
+2 ; 5.1 to 5.2 Upgrade, I believe.
+3 ;
+4 DO BMES^XPDUTL(" Checking File 60 (Laboratory Test) for invalid")
+5 DO MES^XPDUTL(" HIGHEST URGENCY ALLOWED entries.")
+6 ;
+7 NEW IEN,CNT
+8 SET IEN=""
SET CNT=0
+9 FOR
SET IEN=$ORDER(^LAB(60,IEN))
IF IEN=""!(CNT>0)
QUIT
Begin DoDot:1
+10 ; 2 is invalid.
IF $PIECE($GET(^LAB(60,IEN,0)),"^",16)'=2
QUIT
+11 ;
+12 ; Set to ROUTINE urgency
SET $PIECE(^LAB(60,IEN,0),"^",16)=9
End DoDot:1
+13 ;
+14 IF CNT<1
DO OKAY("No invalid HIGHEST URGENCY ALLOWED entries detected.",10)
+15 ;
+16 ; Single change verbage
IF CNT=1
Begin DoDot:1
+17 SET STR=" In File 60 (Laboratory Test) there was "_CNT_CRLF
+18 SET STR=STR_" invalid HIGHEST URGENCY ALLOWED entry."_CRLF
+19 SET STR=STR_" This URGENCY has been changed to ROUTINE. OK."_CRLF
End DoDot:1
+20 ;
+21 ; Multiple change verbage
IF CNT>1
Begin DoDot:1
+22 SET STR=" In File 60 (Laboratory Test) there were "_CNT_CRLF
+23 SET STR=STR_" invalid HIGHEST URGENCY ALLOWED entries."_CRLF
+24 SET STR=STR_" They have been changed to ROUTINE. OK."_CRLF
End DoDot:1
+25 ;
+26 IF CNT>0
DO MES^XPDUTL(STR)
+27 ;
+28 QUIT
+29 ;
+30 ; Add item to BLRMENU
+1 NEW FDA,ERR,HEREYAGO,MIEN,BLRIEN
+2 ;
+3 DO MES^XPDUTL(" Adding "_ADDM_" to BLRMENU.")
+4 ;
+5 ; First, Get BLRMENU IEN
+6 DO FIND^DIC(19,"","","","BLRMENU","","","","","HEREYAGO")
+7 SET BLRIEN=$GET(HEREYAGO("DILIST",2,1))
+8 ;
+9 ; Cleanup
+10 DO ^XBFMK
+11 KILL HEREYAGO
+12 ;
+13 ; Next, get IEN for Option
+14 DO FIND^DIC(19,"","","",ADDM,"","","","","HEREYAGO")
+15 SET MIEN=$GET(HEREYAGO("DILIST",2,1))
+16 ;
+17 ; Make sure OPTION exists
+18 IF $GET(MIEN)=""
DO SORRY("Could not find "_ADDM_" Option","NONFATAL")
QUIT
+19 ;
+20 ; Now, check to see if Option already there -- if so, Quit
+21 IF $DATA(^DIC(19,BLRIEN,10,"B",MIEN))
Begin DoDot:1
+22 DO OKAY(ADDM_" already on BLRMENU. No further processing.",15)
End DoDot:1
QUIT
+23 ;
+24 SET FDA(42,19,"?1,",.01)="BLRMENU"
+25 SET FDA(42,19.01,"+2,?1,",.01)=MIEN
+26 ; SYNONYM (1-4 Chars)
SET FDA(42,19.01,"+2,?1,",2)=SYNM
+27 ;
+28 DO UPDATE^DIE("","FDA(42)",,"")
+29 ;
+30 IF $DATA(^TMP("DIERR",$JOB))>0
Begin DoDot:1
+31 DO SORRY("Error in adding "_ADDM_" to BLRMENU. $J="_$JOB_".","NONFATAL")
End DoDot:1
QUIT
+32 ;
+33 DO OKAY(ADDM_" added to BLRMENU. $J="_$JOB_".",15)
+34 ;
+35 QUIT
+36 ;
CHNGMOFD ;
+1 NEW SPEC,STR,SUBSTR
+2 NEW WOTDD
+3 ;
+4 DO BMES^XPDUTL(" Changing Max Order Freq Default for Lab Tests to 365.")
+5 SET STR=$GET(^DD(60.03,4,0))
+6 SET SUBSTR=$PIECE($PIECE($PIECE(STR,"^",5),">",2),")",1)
+7 IF $LENGTH(SUBSTR)'=3
Begin DoDot:1
+8 DO SORRY("Could not change Max Order Freq Default String","NONFATAL")
End DoDot:1
QUIT
+9 ;
+10 IF +SUBSTR=365
Begin DoDot:1
+11 DO OKAY("Max Order Freq Default already 365.",10)
End DoDot:1
QUIT
+12 ;
+13 IF +SUBSTR'=365
Begin DoDot:1
+14 SET SPEC(SUBSTR)=365
+15 SET STR=$$REPLACE^XLFSTR(STR,.SPEC)
+16 SET WOTDD="^DD(60.03,4,0)"
+17 SET @WOTDD=STR
+18 DO OKAY("Changed Max Order Freq Default.",10)
End DoDot:1
+19 ;
+20 KILL SPEC
+21 SET STR=$GET(^DD(60.03,4,3))
+22 SET SUBSTR=$REVERSE($PIECE($REVERSE($PIECE(STR,",",1))," ",1))
+23 IF $LENGTH(SUBSTR)'=3
Begin DoDot:1
+24 DO SORRY("Could not change Max Order Freq Default HELP String","NONFATAL")
End DoDot:1
QUIT
+25 ;
+26 IF +SUBSTR=365
Begin DoDot:1
+27 DO OKAY("Max Order Freq Default HELP String already 365.",10)
End DoDot:1
+28 ;
+29 IF +SUBSTR'=365
Begin DoDot:1
+30 SET SPEC(SUBSTR)=365
+31 SET STR=$$REPLACE^XLFSTR(STR,.SPEC)
+32 SET WOTDD="^DD(60.03,4,3)"
+33 SET @WOTDD=STR
+34 DO OKAY("Changed Max Order Freq Default HELP.",10)
End DoDot:1
+35 ;
+36 DO OKAY("Max Order Freq Default.")
+37 ;
+38 QUIT
