BLRUTIL ;IHS/ITSC/TPF - BLR LINK UTILITIES AND TESTING SUBROUTINES ; 24-Mar-2016 12:28 ; MKK
;;5.2;IHS LABORATORY;**1013,1014,1015,1018,1019,1020,1024,1027,1030,1033,1039**;NOV 01, 1997;Build 38
;
;CLEAR TESTING GLOBALS
RESETGLO ;EP
N BLR
F BLR="^BLRFDA","^BLRBLR","^BLREMSG","^BLRTSTS","^BLRENTRY","^BLRENTS","^BLRVARS","^BLRTEST" D
. I $$KILLOK^ZIBGCHAR($P(BLR,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(BLR,U,2)))_" "_BLR Q
. W !,"KILLING "_BLR K @BLR
Q
;
;CAPTURE/SAVE SYMBOL TABLE
CAPVARS(XXXX,TARGET) ;EP
NEW YYYY ; LR*5.2*1030 - Make sure X & Y variables not modified
NEW TARGET2 ; LR*5.2*1033 - Make sure all arrays set correctly
;
S TARGET2=$P(TARGET,")")_",YYYY)" ; IHS/MSC/MKK - LR*5.2*1033 -- Make sure to record ALL arrays
K @XXXX
; S YYYY="%" F %=0:0 S YYYY=$O(@YYYY) Q:YYYY="" S %=$D(@YYYY) S:%#2&($E(YYYY,1,2)'="ZT") @(XXXX_"("""_YYYY_""")=$G(@YYYY,""NULL"")") M:%=10&($E(YYYY,1,2)'="ZT") @TARGET=@YYYY ; IHS/OTI/MKK - LR*5.2*1030 - Will automatically store ALL arrays
S YYYY="%" F %=0:0 S YYYY=$O(@YYYY) Q:YYYY="" S %=$D(@YYYY) S:%#2&($E(YYYY,1,2)'="ZT") @(XXXX_"("""_YYYY_""")=$G(@YYYY,""NULL"")") M:%=10&($E(YYYY,1,2)'="ZT") @TARGET2=@YYYY ; IHS/OTI/MKK - LR*5.2*1033. Fixed bug.
M @TARGET=@XXXX ; LR*5.2*1030
Q
;RECORD TIME AND TAG^ROUTINE
;ENTRYAUD(LABEL,ARRY) ;EP
;----- BEGIN IHS/OIT/MKK -- 1024 MODIFICATION
; Adding the ability to display another array
ENTRYAUD(LABEL,ARRY1,ARRY2,ARRY3) ;EP
;----- END IHS/OIT/MKK -- 1024 MODIFICATION
;THE GLOBAL ROOT SHOULD BE RESET PERIODICALLY
;
Q:+$$GET1^DIQ(9009029,+$G(DUZ(2)),"TAKE SNAPSHOTS","I")<1 ; IHS/MSC/MKK - LR*5.2*1033 - Skip if field not YES
;
D CHKENTRY^BLRENTRY ; IHS/MSC/MKK - LR*5.2*1033 - Check size of ^BLRENTRY global
;
;----- BEGIN IHS/OIT/MKK -- LR*5.2*1030
D DISABLE^%NOJRN ; Disable Journaling of ^BLRENTRY global
;
N ORIGX,ORIGY,%ORIG ; Want to see what %, X & Y variables are
M ORIGX=X,ORIGY=Y
M:$D(%) %ORIG=%
NEW %
S:$D(%ORIG) %=%ORIG
;----- END IHS/OIT/MKK -- LR*5.2*1030
;
N X,Y,NOW,ENTRYNUM,STARTTIM,NOWTIM
S NOW=$$NOW^XLFDT ; LR*5.2*1030 -- Use Kernel Call to set NOW variable
S ENTRYNUM=$G(^BLRENTRY)+1
S NOWTIM=$P($H,",",2)
S $P(^BLRENTRY,U)=ENTRYNUM
S ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL)=""
;
;----- BEGIN IHS/MSC/MKK -- LR*5.2*1033
NEW DMLRDFN,DMLRIDT ; Specific MICRO Accessioning variables
D DEBUGMI^BLRUTIL6 ; Set Micro Accessioning variables
;----- END IHS/MSC/MKK -- LR*5.2*1033
;
D CAPVARS("BLRVARS","^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL)")
;
I $L($G(ARRY1)) D ; Have an array that needs to be monitored; Merge it
. M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY1)=@ARRY1
;
I $L($G(ARRY2)) D ; Have another array that needs to be monitored; Merge it
. M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY2)=@ARRY2
;
I $L($G(ARRY3)) D ; Have another array that needs to be monitored; Merge it
. M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY3)=@ARRY3
;
;----- BEGIN IHS/OIT/MKK -- LR*5.2*1030
M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"DUZ")=DUZ ; Always merge in the DUZ array
I $D(ORIGX)>1 M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"ORIGX")=ORIGX
I $D(ORIGY)>1 M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"ORIGY")=ORIGY
;----- END IHS/OIT/MKK -- LR*5.2*1030
;
; D GETSTACK ; IHS/OIT/MKK - LR*5.2*1027
D GETSTACK^BLRUTIL6 ; IHS/OIT/MKK - LR*5.2*1033
;
S ^BLRENTRY("C",ENTRYNUM)=DUZ_"~"_NOW_"~"_LABEL ; IHS/MSC/MKK - LR*5.2*1035
;
D ENABLE^%NOJRN ; LR*5.2*1030 -- Enable Journaling again
;
Q
;
REPORT(SHORT) ; EP
D ^%ZIS Q:POP
W:'SHORT @IOF
S USER=""
F S USER=$O(^BLRENTRY(USER)) Q:USER="" D
.S NOW=""
.F S NOW=$O(^BLRENTRY(USER,NOW)) Q:NOW="" D
..S ENTRYNUM=""
..F S ENTRYNUM=$O(^BLRENTRY(USER,NOW,ENTRYNUM)) Q:ENTRYNUM="" D
...S LABEL=""
...F S LABEL=$O(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL)) Q:LABEL="" D
....W:'SHORT @IOF
....W !,ENTRYNUM,?15,LABEL
....Q:SHORT
....S VARIABLE=""
....F S VARIABLE=$O(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE)) Q:VARIABLE="" D
.....; S VALUE=^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE)
.....S VALUE=$G(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE)) ; IHS/MSC/MKK - LR*5.2*1033
.....W !?20,VARIABLE_"="_VALUE
D ^%ZISC
Q
;
TEST ; EP
S BLRIEN(1)=$O(^BLRTXLOG("A"),-1)+1
S BLRFDA(9009022,"+1,",.06)=4
S BLRFDA(9009022,"+1,",.01)=BLRIEN(1)
S BLRFDA(9009022,"+1,",1202)="HE 0613 29"
D UPDATE^DIE("","BLRFDA","BLRIEN")
Q
;
;BLR RUNAWAY ERROR CHECK ROUTINE
;CHECK ERROR GLOBAL FOR AN ACCUMULATION OF BLR ERRORS
ERRCHK(ERRDT) ;EP
S:ERRDT="" ERRDT=+$H
S ERRNUM=0
S BLRERRS=0
S BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
S BLRERLIM=$P($G(^BLRSITE(BLRQSITE,0)),U,11)
S:BLRERLIM="" BLRERLIM=5 ;IHS/ITSC/TPF 06/06/02 DEFAULT ERROR LIMIT 5
F S ERRNUM=$O(^%ZTER(1,ERRDT,1,ERRNUM)) Q:+ERRNUM=0 D
.;DO NOT COUNT E-SIG ERRORS
.I $E($P($P($G(^%ZTER(1,ERRDT,1,ERRNUM,"ZE")),">",2),U,2),1,3)="BLR",($E($P($P($G(^%ZTER(1,ERRDT,1,ERRNUM,"ZE")),">",2),U,2),4,4)'="A") S BLRERRS=BLRERRS+1
S RETURN=BLRERRS>BLRERLIM
;S RETURN=1 ;FORCE OVERFLOW ERROR
I RETURN D
.S $P(^BLRSITE(BLRQSITE,0),U,9)=1
.S BLRERR=2,BLRERR(1)="ERROR OVERFLOW LIMIT REACHED!!",BLRERR(2)="THE BLR LAB PCC LINK HAS BEEN HALTED!!",BLRERR(3)="CALL YOUR SITE MANAGER IMMEDIATELY!",MAILGRP="BLR ERROR OVERFLOW WARNING" D MAIL(.BLRERR,MAILGRP)
Q RETURN
;
;CLEAR BLR ERRORS FROM ERROR LOG. ONLY ERRORS FROM CURRENT UCI WILL
;BE KILLED
CLRERRS(ERRDT) ;EP
S:$G(ERRDT)="" ERRDT=+$H
4 ; S BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,ERRDT,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
S BLRERLIM=$P($G(^BLRSITE(BLRQSITE,0)),U,11) ;GET ERROR OVERFLOW LIMIT
X ^%ZOSF("UCI")
; S CURUCI=Y
S CURUCI=$P(Y,",") ; IHS/MSC/MKK - LR*5.2*1039
S ERRNUM=0
S BLRERRS=0
F S ERRNUM=$O(^%ZTER(1,ERRDT,1,ERRNUM)) Q:+ERRNUM=0 D
.Q:$G(^%ZTER(1,ERRDT,1,ERRNUM,"ZE"))'[("^BLR")
.; Q:$P($G(^%ZTER(1,ERRDT,1,ERRNUM,"J")),U,4)'=CURUCI
. ;
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
. S ERRUCI=$P($G(^%ZTER(1,ERRDT,1,ERRNUM,"J")),U,4)
. S ERRUCI=$S(ERRUCI[":":$P(ERRUCI,":"),1:$P(ERRUCI,","))
. Q:ERRUCI'=CURUCI
. S BLRERRS=BLRERRS+1
. ; ----- END IHS/MSC/MKK - LR*5.2*1039
. ;
.; K ^%ZTER(1,ERRDT,1,ERRNUM)
. ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
. ; NEW WOT
. S WOT="^%ZTER(1,ERRDT,1,ERRNUM)"
. K @WOT
. ; ----- END IHS/OIT/MKK - LR*5.2*1027
.S $P(^%ZTER(1,ERRDT,0),U,2)=$P($G(^%ZTER(1,ERRDT,0)),U,2)-1
;
I '$G(BLRERRS) W !,"No link errors were found!!" Q
W !,$G(BLRERRS)," link errors were found and cleared from the error log!"
S $P(^BLRSITE(BLRQSITE,0),U,9)=0
Q
;
;function to check for PLUG-IN PACKAGE EXISTING AND TURNED ON
;NAMESP = THE NAMESPACE THE PLUG-IN HAS BEEN ASSIGNED
;MAINRTN = THE MAIN ROUTINE WHICH DRIVES THE PLUG-IN
;DUZ2 = THE SITE/FACILITY THE USER IS LOGGED ONTO
ADDON(NAMESP,MAINRTN,DUZ2) ;EP
Q:$G(NAMESP)=""!($G(MAINRTN)="")!($G(DUZ2)="") 0
;
;CHECK KIDS FILE IS THE KIDS INSTALL COMPLETE?
S KFINISH1=$O(^XPD(9.7,"B",NAMESP_"["),-1)
I KFINISH1'=NAMESP Q 0
I $G(KFINISH1)="" S BLRERR=1,BLRERR(1)="THE PLUG-IN WITH NAMESPACE "_NAMESP_" HAS NOT BEEN INSTALLED BY KIDS!" S MAILGRP="BLR APPLICATION PLUG-IN WARNING" D MAIL(.BLRERR,MAILGRP) Q 0
S KFINISH2=$O(^XPD(9.7,"B",KFINISH1,""))
;
; Status:
; '0' Loaded from Distribution
; '1' Queued for Install
; '2' Start of Install
; '3' Install Completed
; '4' FOR De-Installed
S KSTATUS=$P($G(^XPD(9.7,KFINISH2,0)),U,9)
I KSTATUS'=3 D Q 0 ; Plug-in install not complete
. S BLRERR=3
. S BLRERR(1)="THE PLUG-IN '"_APPNAME_"' CANNOT BE TRIGGERED FOR THE"
. S BLRERR(2)="FOLLOWING REASON "_$S(KSTATUS=0:"Loaded from Distribution",KSTATUS=1:"Queued for Install",KSTATUS=2:"Start of Install",KSTATUS=4:"De-Installed",1:"Unknown Status"),MAILGRP="BLR APPLICATION PLUG-IN WARNING"
. D MAIL(.BLRERR,MAILGRP)
;
S APPIEN=$O(^BLRSITE(DUZ2,1,"B",KFINISH2,0))
I '$G(APPIEN) Q 0
S APPON=$P($G(^BLRSITE(DUZ2,1,APPIEN,0)),U,2)
I 'APPON Q 0 ;PLUGIN IS NOT TURNED ON SO QUIT
;
;EVERYTHING LOOKS FINE BUT LETS MAKE SURE THE ROUTINES ARE THERE
S CHKRTN=$$CHKRTN(KFINISH2,.RTNERROR) ;LETS SEE IF ALL THE ROUTINES ARE THERE ; THIS CHECK NOT YET ACTIVATED OR USED
;
S X=MAINRTN
X ^%ZOSF("TEST")
I '$T D Q 0
. S BLRERR=3
. S BLRERR(1)="THE PLUG-IN WITH NAMESPACE '"_NAMESP_"'"
. S BLRERR(2)="KNOWN AS THE '"_APPNAME_"' PLUG-IN"
. S BLRERR(3)="IS MISSING ITS MAIN DRIVER ROUTINE '"_MAINRTN_"'!!"
. S MAILGRP="BLR APPLICATION PLUG-IN WARNING"
. D MAIL(.BLRERR,MAILGRP)
;
Q 1
;
;SEE WHAT ROUTINES BELONG TO THIS PLUGIN AND VERIFY THEY STILL EXIST
CHKRTN(KIDIEN,RTNERROR) ; EP
S RTNERROR=0
S RTNNUM=0
F S RTNNUM=$O(^XPD(9.7,KIDIEN,"RTN",RTNNUM)) Q:+RTNNUM=0 D
.S RTNNAME=$G(^XPD(9.7,KIDIEN,"RTN",RTNNUM,0))
.S X=RTNNAME X ^%ZOSF("TEST") I '$T S RTNERROR=1,RTNERROR(RTNNAME)=""
Q RTNERROR
;
MAIL(BLRERR,MAILGRP) ; EP
S XMTEXT="BLRERR"
S XMB=MAILGRP
S XMDUZ=.5
D ^XMB
Q
;
;VERIFY PIMS IS INSTALLED. LAB PATCH 18 FOR EHR DOES NOT NECESSARILY NEED EHR COMPONENTS TO WORK, INCLUDING PIMS 5.3. IF PIMS IS THERE USE ITS ROUTNES, IF NOT USE BLRDPT CALLS AS ALWAYS
ISPIMS() ;EP
N X,IS52,VERS
S X=$O(^DIC(9.4,"B","PIMS",""))
Q:X="" 0
S VERS=$P($G(^DIC(9.4,X,"VERSION")),"^")
Q:VERS="" 0
Q:+VERS<5.3 0
Q 1
;
;PRINT EXTRA E-SIG INFO. CALLED BY LRPP1 AND LRMUPSU
ESIGINFO ;EP
; ----- BEGIN IHS/OIT/MKK LR*5.2*1027
; Code moved to BLRUTIL3 because BLRUTIL was > 15000 bytes
; D ESIGINFO^BLRUTIL3
D ESIGINFO^BLRUTIL5 ; IHS/OIT/MKK - LR*5.2*1033
Q
; ----- END IHS/OIT/MKK LR*5.2*1027
;
; 01-Mar-2004
; Provider - Specimen Pointer Fix - Tuba City Initial Fix
;
;----- BEGIN 1019 Mods
NUMDATE(FMDATE) ; EP - FileMan Date into mm/dd/yy
Q $P($TR($$FMTE^XLFDT(FMDATE,"2F")," ","0"),"@",1)
;
NUMTIME(X) ; EP - FileMan Date/Time into xx:xx AM/PM
NEW Y
I $G(X)="" Q X
S X=$E($P(X,".",2)_"0000",1,4),Y=X>1159 S:X>1259 X=X-1200 S X=$J(X\100,2)_":"_$E(X#100+100,2,3)_" "_$E("AP",Y+1)_"M"
Q X
;----- END 1019 Mods
;
BLRUTIL ;IHS/ITSC/TPF - BLR LINK UTILITIES AND TESTING SUBROUTINES ; 24-Mar-2016 12:28 ; MKK
+1 ;;5.2;IHS LABORATORY;**1013,1014,1015,1018,1019,1020,1024,1027,1030,1033,1039**;NOV 01, 1997;Build 38
+2 ;
+3 ;CLEAR TESTING GLOBALS
RESETGLO ;EP
+1 NEW BLR
+2 FOR BLR="^BLRFDA","^BLRBLR","^BLREMSG","^BLRTSTS","^BLRENTRY","^BLRENTS","^BLRVARS","^BLRTEST"
Begin DoDot:1
+3 IF $$KILLOK^ZIBGCHAR($PIECE(BLR,U,2))
WRITE !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($PIECE(BLR,U,2)))_" "_BLR
QUIT
+4 WRITE !,"KILLING "_BLR
KILL @BLR
End DoDot:1
+5 QUIT
+6 ;
+7 ;CAPTURE/SAVE SYMBOL TABLE
CAPVARS(XXXX,TARGET) ;EP
+1 ; LR*5.2*1030 - Make sure X & Y variables not modified
NEW YYYY
+2 ; LR*5.2*1033 - Make sure all arrays set correctly
NEW TARGET2
+3 ;
+4 ; IHS/MSC/MKK - LR*5.2*1033 -- Make sure to record ALL arrays
SET TARGET2=$PIECE(TARGET,")")_",YYYY)"
+5 KILL @XXXX
+6 ; S YYYY="%" F %=0:0 S YYYY=$O(@YYYY) Q:YYYY="" S %=$D(@YYYY) S:%#2&($E(YYYY,1,2)'="ZT") @(XXXX_"("""_YYYY_""")=$G(@YYYY,""NULL"")") M:%=10&($E(YYYY,1,2)'="ZT") @TARGET=@YYYY ; IHS/OTI/MKK - LR*5.2*1030 - Will automatically store ALL arrays
+7 ; IHS/OTI/MKK - LR*5.2*1033. Fixed bug.
SET YYYY="%"
FOR %=0:0
SET YYYY=$ORDER(@YYYY)
IF YYYY=""
QUIT
SET %=$DATA(@YYYY)
IF %#2&($EXTRACT(YYYY,1,2)'="ZT")
SET @(XXXX_"("""_YYYY_""")=$G(@YYYY,""NULL"")")
IF %=10&($EXTRACT(YYYY,1,2)'="ZT")
MERGE @TARGET2=@YYYY
+8 ; LR*5.2*1030
MERGE @TARGET=@XXXX
+9 QUIT
+10 ;RECORD TIME AND TAG^ROUTINE
+11 ;ENTRYAUD(LABEL,ARRY) ;EP
+12 ;----- BEGIN IHS/OIT/MKK -- 1024 MODIFICATION
+13 ; Adding the ability to display another array
ENTRYAUD(LABEL,ARRY1,ARRY2,ARRY3) ;EP
+1 ;----- END IHS/OIT/MKK -- 1024 MODIFICATION
+2 ;THE GLOBAL ROOT SHOULD BE RESET PERIODICALLY
+3 ;
+4 ; IHS/MSC/MKK - LR*5.2*1033 - Skip if field not YES
IF +$$GET1^DIQ(9009029,+$GET(DUZ(2)),"TAKE SNAPSHOTS","I")<1
QUIT
+5 ;
+6 ; IHS/MSC/MKK - LR*5.2*1033 - Check size of ^BLRENTRY global
DO CHKENTRY^BLRENTRY
+7 ;
+8 ;----- BEGIN IHS/OIT/MKK -- LR*5.2*1030
+9 ; Disable Journaling of ^BLRENTRY global
DO DISABLE^%NOJRN
+10 ;
+11 ; Want to see what %, X & Y variables are
NEW ORIGX,ORIGY,%ORIG
+12 MERGE ORIGX=X,ORIGY=Y
+13 IF $DATA(%)
MERGE %ORIG=%
+14 NEW %
+15 IF $DATA(%ORIG)
SET %=%ORIG
+16 ;----- END IHS/OIT/MKK -- LR*5.2*1030
+17 ;
+18 NEW X,Y,NOW,ENTRYNUM,STARTTIM,NOWTIM
+19 ; LR*5.2*1030 -- Use Kernel Call to set NOW variable
SET NOW=$$NOW^XLFDT
+20 SET ENTRYNUM=$GET(^BLRENTRY)+1
+21 SET NOWTIM=$PIECE($HOROLOG,",",2)
+22 SET $PIECE(^BLRENTRY,U)=ENTRYNUM
+23 SET ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL)=""
+24 ;
+25 ;----- BEGIN IHS/MSC/MKK -- LR*5.2*1033
+26 ; Specific MICRO Accessioning variables
NEW DMLRDFN,DMLRIDT
+27 ; Set Micro Accessioning variables
DO DEBUGMI^BLRUTIL6
+28 ;----- END IHS/MSC/MKK -- LR*5.2*1033
+29 ;
+30 DO CAPVARS("BLRVARS","^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL)")
+31 ;
+32 ; Have an array that needs to be monitored; Merge it
IF $LENGTH($GET(ARRY1))
Begin DoDot:1
+33 MERGE ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY1)=@ARRY1
End DoDot:1
+34 ;
+35 ; Have another array that needs to be monitored; Merge it
IF $LENGTH($GET(ARRY2))
Begin DoDot:1
+36 MERGE ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY2)=@ARRY2
End DoDot:1
+37 ;
+38 ; Have another array that needs to be monitored; Merge it
IF $LENGTH($GET(ARRY3))
Begin DoDot:1
+39 MERGE ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY3)=@ARRY3
End DoDot:1
+40 ;
+41 ;----- BEGIN IHS/OIT/MKK -- LR*5.2*1030
+42 ; Always merge in the DUZ array
MERGE ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"DUZ")=DUZ
+43 IF $DATA(ORIGX)>1
MERGE ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"ORIGX")=ORIGX
+44 IF $DATA(ORIGY)>1
MERGE ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"ORIGY")=ORIGY
+45 ;----- END IHS/OIT/MKK -- LR*5.2*1030
+46 ;
+47 ; D GETSTACK ; IHS/OIT/MKK - LR*5.2*1027
+48 ; IHS/OIT/MKK - LR*5.2*1033
DO GETSTACK^BLRUTIL6
+49 ;
+50 ; IHS/MSC/MKK - LR*5.2*1035
SET ^BLRENTRY("C",ENTRYNUM)=DUZ_"~"_NOW_"~"_LABEL
+51 ;
+52 ; LR*5.2*1030 -- Enable Journaling again
DO ENABLE^%NOJRN
+53 ;
+54 QUIT
+55 ;
REPORT(SHORT) ; EP
+1 DO ^%ZIS
IF POP
QUIT
+2 IF 'SHORT
WRITE @IOF
+3 SET USER=""
+4 FOR
SET USER=$ORDER(^BLRENTRY(USER))
IF USER=""
QUIT
Begin DoDot:1
+5 SET NOW=""
+6 FOR
SET NOW=$ORDER(^BLRENTRY(USER,NOW))
IF NOW=""
QUIT
Begin DoDot:2
+7 SET ENTRYNUM=""
+8 FOR
SET ENTRYNUM=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM))
IF ENTRYNUM=""
QUIT
Begin DoDot:3
+9 SET LABEL=""
+10 FOR
SET LABEL=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL))
IF LABEL=""
QUIT
Begin DoDot:4
+11 IF 'SHORT
WRITE @IOF
+12 WRITE !,ENTRYNUM,?15,LABEL
+13 IF SHORT
QUIT
+14 SET VARIABLE=""
+15 FOR
SET VARIABLE=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE))
IF VARIABLE=""
QUIT
Begin DoDot:5
+16 ; S VALUE=^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE)
+17 ; IHS/MSC/MKK - LR*5.2*1033
SET VALUE=$GET(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE))
+18 WRITE !?20,VARIABLE_"="_VALUE
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 DO ^%ZISC
+20 QUIT
+21 ;
TEST ; EP
+1 SET BLRIEN(1)=$ORDER(^BLRTXLOG("A"),-1)+1
+2 SET BLRFDA(9009022,"+1,",.06)=4
+3 SET BLRFDA(9009022,"+1,",.01)=BLRIEN(1)
+4 SET BLRFDA(9009022,"+1,",1202)="HE 0613 29"
+5 DO UPDATE^DIE("","BLRFDA","BLRIEN")
+6 QUIT
+7 ;
+8 ;BLR RUNAWAY ERROR CHECK ROUTINE
+9 ;CHECK ERROR GLOBAL FOR AN ACCUMULATION OF BLR ERRORS
ERRCHK(ERRDT) ;EP
+1 IF ERRDT=""
SET ERRDT=+$HOROLOG
+2 SET ERRNUM=0
+3 SET BLRERRS=0
+4 SET BLRQSITE=$PIECE($GET(^AUTTSITE(1,0)),U)
+5 SET BLRERLIM=$PIECE($GET(^BLRSITE(BLRQSITE,0)),U,11)
+6 ;IHS/ITSC/TPF 06/06/02 DEFAULT ERROR LIMIT 5
IF BLRERLIM=""
SET BLRERLIM=5
+7 FOR
SET ERRNUM=$ORDER(^%ZTER(1,ERRDT,1,ERRNUM))
IF +ERRNUM=0
QUIT
Begin DoDot:1
+8 ;DO NOT COUNT E-SIG ERRORS
+9 IF $EXTRACT($PIECE($PIECE($GET(^%ZTER(1,ERRDT,1,ERRNUM,"ZE")),">",2),U,2),1,3)="BLR"
IF ($EXTRACT($PIECE($PIECE($GET(^%ZTER(1,ERRDT,1,ERRNUM,"ZE")),">",2),U,2),4,4)'="A")
SET BLRERRS=BLRERRS+1
End DoDot:1
+10 SET RETURN=BLRERRS>BLRERLIM
+11 ;S RETURN=1 ;FORCE OVERFLOW ERROR
+12 IF RETURN
Begin DoDot:1
+13 SET $PIECE(^BLRSITE(BLRQSITE,0),U,9)=1
+14 SET BLRERR=2
SET BLRERR(1)="ERROR OVERFLOW LIMIT REACHED!!"
SET BLRERR(2)="THE BLR LAB PCC LINK HAS BEEN HALTED!!"
SET BLRERR(3)="CALL YOUR SITE MANAGER IMMEDIATELY!"
SET MAILGRP="BLR ERROR OVERFLOW WARNING"
DO MAIL(.BLRERR,MAILGRP)
End DoDot:1
+15 QUIT RETURN
+16 ;
+17 ;CLEAR BLR ERRORS FROM ERROR LOG. ONLY ERRORS FROM CURRENT UCI WILL
+18 ;BE KILLED
CLRERRS(ERRDT) ;EP
+1 IF $GET(ERRDT)=""
SET ERRDT=+$HOROLOG
4 ; S BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,ERRDT,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET BLRQSITE=$PIECE($GET(^AUTTSITE(1,0)),U)
+4 ;GET ERROR OVERFLOW LIMIT
SET BLRERLIM=$PIECE($GET(^BLRSITE(BLRQSITE,0)),U,11)
+5 XECUTE ^%ZOSF("UCI")
+6 ; S CURUCI=Y
+7 ; IHS/MSC/MKK - LR*5.2*1039
SET CURUCI=$PIECE(Y,",")
+8 SET ERRNUM=0
+9 SET BLRERRS=0
+10 FOR
SET ERRNUM=$ORDER(^%ZTER(1,ERRDT,1,ERRNUM))
IF +ERRNUM=0
QUIT
Begin DoDot:1
+11 IF $GET(^%ZTER(1,ERRDT,1,ERRNUM,"ZE"))'[("^BLR")
QUIT
+12 ; Q:$P($G(^%ZTER(1,ERRDT,1,ERRNUM,"J")),U,4)'=CURUCI
+13 ;
+14 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
+15 SET ERRUCI=$PIECE($GET(^%ZTER(1,ERRDT,1,ERRNUM,"J")),U,4)
+16 SET ERRUCI=$SELECT(ERRUCI[":":$PIECE(ERRUCI,":"),1:$PIECE(ERRUCI,","))
+17 IF ERRUCI'=CURUCI
QUIT
+18 SET BLRERRS=BLRERRS+1
+19 ; ----- END IHS/MSC/MKK - LR*5.2*1039
+20 ;
+21 ; K ^%ZTER(1,ERRDT,1,ERRNUM)
+22 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
+23 ; NEW WOT
+24 SET WOT="^%ZTER(1,ERRDT,1,ERRNUM)"
+25 KILL @WOT
+26 ; ----- END IHS/OIT/MKK - LR*5.2*1027
+27 SET $PIECE(^%ZTER(1,ERRDT,0),U,2)=$PIECE($GET(^%ZTER(1,ERRDT,0)),U,2)-1
End DoDot:1
+28 ;
+29 IF '$GET(BLRERRS)
WRITE !,"No link errors were found!!"
QUIT
+30 WRITE !,$GET(BLRERRS)," link errors were found and cleared from the error log!"
+31 SET $PIECE(^BLRSITE(BLRQSITE,0),U,9)=0
+32 QUIT
+33 ;
+34 ;function to check for PLUG-IN PACKAGE EXISTING AND TURNED ON
+35 ;NAMESP = THE NAMESPACE THE PLUG-IN HAS BEEN ASSIGNED
+36 ;MAINRTN = THE MAIN ROUTINE WHICH DRIVES THE PLUG-IN
+37 ;DUZ2 = THE SITE/FACILITY THE USER IS LOGGED ONTO
ADDON(NAMESP,MAINRTN,DUZ2) ;EP
+1 IF $GET(NAMESP)=""!($GET(MAINRTN)="")!($GET(DUZ2)="")
QUIT 0
+2 ;
+3 ;CHECK KIDS FILE IS THE KIDS INSTALL COMPLETE?
+4 SET KFINISH1=$ORDER(^XPD(9.7,"B",NAMESP_"["),-1)
+5 IF KFINISH1'=NAMESP
QUIT 0
+6 IF $GET(KFINISH1)=""
SET BLRERR=1
SET BLRERR(1)="THE PLUG-IN WITH NAMESPACE "_NAMESP_" HAS NOT BEEN INSTALLED BY KIDS!"
SET MAILGRP="BLR APPLICATION PLUG-IN WARNING"
DO MAIL(.BLRERR,MAILGRP)
QUIT 0
+7 SET KFINISH2=$ORDER(^XPD(9.7,"B",KFINISH1,""))
+8 ;
+9 ; Status:
+10 ; '0' Loaded from Distribution
+11 ; '1' Queued for Install
+12 ; '2' Start of Install
+13 ; '3' Install Completed
+14 ; '4' FOR De-Installed
+15 SET KSTATUS=$PIECE($GET(^XPD(9.7,KFINISH2,0)),U,9)
+16 ; Plug-in install not complete
IF KSTATUS'=3
Begin DoDot:1
+17 SET BLRERR=3
+18 SET BLRERR(1)="THE PLUG-IN '"_APPNAME_"' CANNOT BE TRIGGERED FOR THE"
+19 SET BLRERR(2)="FOLLOWING REASON "_$SELECT(KSTATUS=0:"Loaded from Distribution",KSTATUS=1:"Queued for Install",KSTATUS=2:"Start of Install",KSTATUS=4:"De-Installed",1:"Unknown Status")
SET MAILGRP="BLR APPLICATION PLUG-IN WARNING"
+20 DO MAIL(.BLRERR,MAILGRP)
End DoDot:1
QUIT 0
+21 ;
+22 SET APPIEN=$ORDER(^BLRSITE(DUZ2,1,"B",KFINISH2,0))
+23 IF '$GET(APPIEN)
QUIT 0
+24 SET APPON=$PIECE($GET(^BLRSITE(DUZ2,1,APPIEN,0)),U,2)
+25 ;PLUGIN IS NOT TURNED ON SO QUIT
IF 'APPON
QUIT 0
+26 ;
+27 ;EVERYTHING LOOKS FINE BUT LETS MAKE SURE THE ROUTINES ARE THERE
+28 ;LETS SEE IF ALL THE ROUTINES ARE THERE ; THIS CHECK NOT YET ACTIVATED OR USED
SET CHKRTN=$$CHKRTN(KFINISH2,.RTNERROR)
+29 ;
+30 SET X=MAINRTN
+31 XECUTE ^%ZOSF("TEST")
+32 IF '$TEST
Begin DoDot:1
+33 SET BLRERR=3
+34 SET BLRERR(1)="THE PLUG-IN WITH NAMESPACE '"_NAMESP_"'"
+35 SET BLRERR(2)="KNOWN AS THE '"_APPNAME_"' PLUG-IN"
+36 SET BLRERR(3)="IS MISSING ITS MAIN DRIVER ROUTINE '"_MAINRTN_"'!!"
+37 SET MAILGRP="BLR APPLICATION PLUG-IN WARNING"
+38 DO MAIL(.BLRERR,MAILGRP)
End DoDot:1
QUIT 0
+39 ;
+40 QUIT 1
+41 ;
+42 ;SEE WHAT ROUTINES BELONG TO THIS PLUGIN AND VERIFY THEY STILL EXIST
CHKRTN(KIDIEN,RTNERROR) ; EP
+1 SET RTNERROR=0
+2 SET RTNNUM=0
+3 FOR
SET RTNNUM=$ORDER(^XPD(9.7,KIDIEN,"RTN",RTNNUM))
IF +RTNNUM=0
QUIT
Begin DoDot:1
+4 SET RTNNAME=$GET(^XPD(9.7,KIDIEN,"RTN",RTNNUM,0))
+5 SET X=RTNNAME
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET RTNERROR=1
SET RTNERROR(RTNNAME)=""
End DoDot:1
+6 QUIT RTNERROR
+7 ;
MAIL(BLRERR,MAILGRP) ; EP
+1 SET XMTEXT="BLRERR"
+2 SET XMB=MAILGRP
+3 SET XMDUZ=.5
+4 DO ^XMB
+5 QUIT
+6 ;
+7 ;VERIFY PIMS IS INSTALLED. LAB PATCH 18 FOR EHR DOES NOT NECESSARILY NEED EHR COMPONENTS TO WORK, INCLUDING PIMS 5.3. IF PIMS IS THERE USE ITS ROUTNES, IF NOT USE BLRDPT CALLS AS ALWAYS
ISPIMS() ;EP
+1 NEW X,IS52,VERS
+2 SET X=$ORDER(^DIC(9.4,"B","PIMS",""))
+3 IF X=""
QUIT 0
+4 SET VERS=$PIECE($GET(^DIC(9.4,X,"VERSION")),"^")
+5 IF VERS=""
QUIT 0
+6 IF +VERS<5.3
QUIT 0
+7 QUIT 1
+8 ;
+9 ;PRINT EXTRA E-SIG INFO. CALLED BY LRPP1 AND LRMUPSU
ESIGINFO ;EP
+1 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1027
+2 ; Code moved to BLRUTIL3 because BLRUTIL was > 15000 bytes
+3 ; D ESIGINFO^BLRUTIL3
+4 ; IHS/OIT/MKK - LR*5.2*1033
DO ESIGINFO^BLRUTIL5
+5 QUIT
+6 ; ----- END IHS/OIT/MKK LR*5.2*1027
+7 ;
+8 ; 01-Mar-2004
+9 ; Provider - Specimen Pointer Fix - Tuba City Initial Fix
+10 ;
+11 ;----- BEGIN 1019 Mods
NUMDATE(FMDATE) ; EP - FileMan Date into mm/dd/yy
+1 QUIT $PIECE($TRANSLATE($$FMTE^XLFDT(FMDATE,"2F")," ","0"),"@",1)
+2 ;
NUMTIME(X) ; EP - FileMan Date/Time into xx:xx AM/PM
+1 NEW Y
+2 IF $GET(X)=""
QUIT X
+3 SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
SET Y=X>1159
IF X>1259
SET X=X-1200
SET X=$JUSTIFY(X\100,2)_":"_$EXTRACT(X#100+100,2,3)_" "_$EXTRACT("AP",Y+1)_"M"
+4 QUIT X
+5 ;----- END 1019 Mods
+6 ;
