Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRUTIL

BLRUTIL.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;CLEAR TESTING GLOBALS
  1. RESETGLO ;EP
  1.  N BLR
  1.  F BLR="^BLRFDA","^BLRBLR","^BLREMSG","^BLRTSTS","^BLRENTRY","^BLRENTS","^BLRVARS","^BLRTEST" D
  1.  . I $$KILLOK^ZIBGCHAR($P(BLR,U,2)) W !,$$ERR^ZIBGCHAR($$KILLOK^ZIBGCHAR($P(BLR,U,2)))_"  "_BLR Q
  1.  . W !,"KILLING "_BLR K @BLR
  1.  Q
  1.  ;
  1.  ;CAPTURE/SAVE SYMBOL TABLE
  1. CAPVARS(XXXX,TARGET) ;EP 
  1.  NEW YYYY    ; LR*5.2*1030 - Make sure X & Y variables not modified
  1.  NEW TARGET2 ; LR*5.2*1033 - Make sure all arrays set correctly
  1.  ;
  1.  S TARGET2=$P(TARGET,")")_",YYYY)"     ; IHS/MSC/MKK - LR*5.2*1033 -- Make sure to record ALL arrays
  1.  K @XXXX
  1.  ; 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
  1.  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.
  1.  M @TARGET=@XXXX        ; LR*5.2*1030
  1.  Q
  1.  ;RECORD TIME AND TAG^ROUTINE
  1.  ;ENTRYAUD(LABEL,ARRY) ;EP
  1.  ;----- BEGIN IHS/OIT/MKK -- 1024 MODIFICATION
  1.  ;            Adding the ability to display another array
  1. ENTRYAUD(LABEL,ARRY1,ARRY2,ARRY3) ;EP
  1.  ;----- END IHS/OIT/MKK -- 1024 MODIFICATION
  1.  ;THE GLOBAL ROOT SHOULD BE RESET PERIODICALLY
  1.  ;
  1.  Q:+$$GET1^DIQ(9009029,+$G(DUZ(2)),"TAKE SNAPSHOTS","I")<1      ; IHS/MSC/MKK - LR*5.2*1033 - Skip if field not YES
  1.  ;
  1.  D CHKENTRY^BLRENTRY                   ; IHS/MSC/MKK - LR*5.2*1033 - Check size of ^BLRENTRY global
  1.  ;
  1.  ;----- BEGIN IHS/OIT/MKK -- LR*5.2*1030
  1.  D DISABLE^%NOJRN                      ; Disable Journaling of ^BLRENTRY global
  1.  ;
  1.  N ORIGX,ORIGY,%ORIG                   ; Want to see what %, X & Y variables are
  1.  M ORIGX=X,ORIGY=Y
  1.  M:$D(%) %ORIG=%
  1.  NEW %
  1.  S:$D(%ORIG) %=%ORIG
  1.  ;----- END IHS/OIT/MKK -- LR*5.2*1030
  1.  ;
  1.  N X,Y,NOW,ENTRYNUM,STARTTIM,NOWTIM
  1.  S NOW=$$NOW^XLFDT                     ; LR*5.2*1030 -- Use Kernel Call to set NOW variable
  1.  S ENTRYNUM=$G(^BLRENTRY)+1
  1.  S NOWTIM=$P($H,",",2)
  1.  S $P(^BLRENTRY,U)=ENTRYNUM
  1.  S ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL)=""
  1.  ;
  1.  ;----- BEGIN IHS/MSC/MKK -- LR*5.2*1033
  1.  NEW DMLRDFN,DMLRIDT                   ; Specific MICRO Accessioning variables
  1.  D DEBUGMI^BLRUTIL6                    ; Set Micro Accessioning variables
  1.  ;----- END IHS/MSC/MKK -- LR*5.2*1033
  1.  ;
  1.  D CAPVARS("BLRVARS","^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL)")
  1.  ;
  1.  I $L($G(ARRY1)) D  ; Have an array that needs to be monitored; Merge it  
  1.  . M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY1)=@ARRY1
  1.  ;
  1.  I $L($G(ARRY2)) D  ; Have another array that needs to be monitored; Merge it  
  1.  . M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY2)=@ARRY2
  1.  ;
  1.  I $L($G(ARRY3)) D  ; Have another array that needs to be monitored; Merge it  
  1.  . M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,ARRY3)=@ARRY3
  1.  ;
  1.  ;----- BEGIN IHS/OIT/MKK -- LR*5.2*1030
  1.  M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"DUZ")=DUZ                       ; Always merge in the DUZ array
  1.  I $D(ORIGX)>1 M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"ORIGX")=ORIGX
  1.  I $D(ORIGY)>1 M ^BLRENTRY(DUZ,NOW,ENTRYNUM,LABEL,"ORIGY")=ORIGY
  1.  ;----- END IHS/OIT/MKK -- LR*5.2*1030
  1.  ;
  1.  ; D GETSTACK        ; IHS/OIT/MKK - LR*5.2*1027
  1.  D GETSTACK^BLRUTIL6         ; IHS/OIT/MKK - LR*5.2*1033
  1.  ;
  1.  S ^BLRENTRY("C",ENTRYNUM)=DUZ_"~"_NOW_"~"_LABEL ; IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  D ENABLE^%NOJRN   ; LR*5.2*1030 -- Enable Journaling again
  1.  ;
  1.  Q
  1.  ;
  1. REPORT(SHORT) ; EP
  1.  D ^%ZIS Q:POP
  1.  W:'SHORT @IOF
  1.  S USER=""
  1.  F  S USER=$O(^BLRENTRY(USER)) Q:USER=""  D
  1.  .S NOW=""
  1.  .F  S NOW=$O(^BLRENTRY(USER,NOW)) Q:NOW=""  D
  1.  ..S ENTRYNUM=""
  1.  ..F  S ENTRYNUM=$O(^BLRENTRY(USER,NOW,ENTRYNUM)) Q:ENTRYNUM=""  D
  1.  ...S LABEL=""
  1.  ...F  S LABEL=$O(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL)) Q:LABEL=""  D
  1.  ....W:'SHORT @IOF
  1.  ....W !,ENTRYNUM,?15,LABEL
  1.  ....Q:SHORT
  1.  ....S VARIABLE=""
  1.  ....F  S VARIABLE=$O(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE)) Q:VARIABLE=""  D
  1.  .....; S VALUE=^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE)
  1.  .....S VALUE=$G(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE))   ; IHS/MSC/MKK - LR*5.2*1033
  1.  .....W !?20,VARIABLE_"="_VALUE
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. TEST ; EP
  1.  S BLRIEN(1)=$O(^BLRTXLOG("A"),-1)+1
  1.  S BLRFDA(9009022,"+1,",.06)=4
  1.  S BLRFDA(9009022,"+1,",.01)=BLRIEN(1)
  1.  S BLRFDA(9009022,"+1,",1202)="HE 0613 29"
  1.  D UPDATE^DIE("","BLRFDA","BLRIEN")
  1.  Q
  1.  ;
  1.  ;BLR RUNAWAY ERROR CHECK ROUTINE
  1.  ;CHECK ERROR GLOBAL FOR AN ACCUMULATION OF BLR ERRORS
  1. ERRCHK(ERRDT) ;EP
  1.  S:ERRDT="" ERRDT=+$H
  1.  S ERRNUM=0
  1.  S BLRERRS=0
  1.  S BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
  1.  S BLRERLIM=$P($G(^BLRSITE(BLRQSITE,0)),U,11)
  1.  S:BLRERLIM="" BLRERLIM=5  ;IHS/ITSC/TPF 06/06/02 DEFAULT ERROR LIMIT 5
  1.  F  S ERRNUM=$O(^%ZTER(1,ERRDT,1,ERRNUM)) Q:+ERRNUM=0  D
  1.  .;DO NOT COUNT E-SIG ERRORS
  1.  .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
  1.  S RETURN=BLRERRS>BLRERLIM
  1.  ;S RETURN=1   ;FORCE OVERFLOW ERROR
  1.  I RETURN D
  1.  .S $P(^BLRSITE(BLRQSITE,0),U,9)=1
  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)
  1.  Q RETURN
  1.  ;
  1.  ;CLEAR BLR ERRORS FROM ERROR LOG. ONLY ERRORS FROM CURRENT UCI WILL
  1.  ;BE KILLED
  1. CLRERRS(ERRDT) ;EP
  1.  S:$G(ERRDT)="" ERRDT=+$H
  1. 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)
  1.  ;
  1.  S BLRQSITE=$P($G(^AUTTSITE(1,0)),U)
  1.  S BLRERLIM=$P($G(^BLRSITE(BLRQSITE,0)),U,11)  ;GET ERROR OVERFLOW LIMIT
  1.  X ^%ZOSF("UCI")
  1.  ; S CURUCI=Y
  1.  S CURUCI=$P(Y,",")  ; IHS/MSC/MKK - LR*5.2*1039
  1.  S ERRNUM=0
  1.  S BLRERRS=0
  1.  F  S ERRNUM=$O(^%ZTER(1,ERRDT,1,ERRNUM)) Q:+ERRNUM=0  D
  1.  .Q:$G(^%ZTER(1,ERRDT,1,ERRNUM,"ZE"))'[("^BLR")
  1.  .; Q:$P($G(^%ZTER(1,ERRDT,1,ERRNUM,"J")),U,4)'=CURUCI
  1.  . ;
  1.  . ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1039
  1.  . S ERRUCI=$P($G(^%ZTER(1,ERRDT,1,ERRNUM,"J")),U,4)
  1.  . S ERRUCI=$S(ERRUCI[":":$P(ERRUCI,":"),1:$P(ERRUCI,","))
  1.  . Q:ERRUCI'=CURUCI
  1.  . S BLRERRS=BLRERRS+1
  1.  . ; ----- END IHS/MSC/MKK - LR*5.2*1039
  1.  . ;
  1.  .; K ^%ZTER(1,ERRDT,1,ERRNUM)
  1.  . ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
  1.  . ; NEW WOT
  1.  . S WOT="^%ZTER(1,ERRDT,1,ERRNUM)"
  1.  . K @WOT
  1.  . ; ----- END IHS/OIT/MKK - LR*5.2*1027
  1.  .S $P(^%ZTER(1,ERRDT,0),U,2)=$P($G(^%ZTER(1,ERRDT,0)),U,2)-1
  1.  ;
  1.  I '$G(BLRERRS) W !,"No link errors were found!!" Q
  1.  W !,$G(BLRERRS)," link errors were found and cleared from the error log!"
  1.  S $P(^BLRSITE(BLRQSITE,0),U,9)=0
  1.  Q
  1.  ;
  1.  ;function to check for PLUG-IN PACKAGE EXISTING AND TURNED ON
  1.  ;NAMESP = THE NAMESPACE THE PLUG-IN HAS BEEN ASSIGNED
  1.  ;MAINRTN = THE MAIN ROUTINE WHICH DRIVES THE PLUG-IN
  1.  ;DUZ2 = THE SITE/FACILITY THE USER IS LOGGED ONTO
  1. ADDON(NAMESP,MAINRTN,DUZ2) ;EP
  1.  Q:$G(NAMESP)=""!($G(MAINRTN)="")!($G(DUZ2)="") 0
  1.  ;
  1.  ;CHECK KIDS FILE IS THE KIDS INSTALL COMPLETE?
  1.  S KFINISH1=$O(^XPD(9.7,"B",NAMESP_"["),-1)
  1.  I KFINISH1'=NAMESP Q 0
  1.  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
  1.  S KFINISH2=$O(^XPD(9.7,"B",KFINISH1,""))
  1.  ;
  1.  ; Status:
  1.  ; '0' Loaded from Distribution
  1.  ; '1' Queued for Install
  1.  ; '2' Start of Install
  1.  ; '3' Install Completed
  1.  ; '4' FOR De-Installed
  1.  S KSTATUS=$P($G(^XPD(9.7,KFINISH2,0)),U,9)
  1.  I KSTATUS'=3 D  Q 0    ; Plug-in install not complete
  1.  . S BLRERR=3
  1.  . S BLRERR(1)="THE PLUG-IN '"_APPNAME_"' CANNOT BE TRIGGERED FOR THE"
  1.  . 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"
  1.  . D MAIL(.BLRERR,MAILGRP)
  1.  ;
  1.  S APPIEN=$O(^BLRSITE(DUZ2,1,"B",KFINISH2,0))
  1.  I '$G(APPIEN) Q 0
  1.  S APPON=$P($G(^BLRSITE(DUZ2,1,APPIEN,0)),U,2)
  1.  I 'APPON Q 0  ;PLUGIN IS NOT TURNED ON SO QUIT
  1.  ;
  1.  ;EVERYTHING LOOKS FINE BUT LETS MAKE SURE THE ROUTINES ARE THERE
  1.  S CHKRTN=$$CHKRTN(KFINISH2,.RTNERROR)   ;LETS SEE IF ALL THE ROUTINES ARE THERE ; THIS CHECK NOT YET ACTIVATED OR USED
  1.  ;
  1.  S X=MAINRTN
  1.  X ^%ZOSF("TEST")
  1.  I '$T D  Q 0
  1.  . S BLRERR=3
  1.  . S BLRERR(1)="THE PLUG-IN WITH NAMESPACE '"_NAMESP_"'"
  1.  . S BLRERR(2)="KNOWN AS THE '"_APPNAME_"' PLUG-IN"
  1.  . S BLRERR(3)="IS MISSING ITS MAIN DRIVER ROUTINE '"_MAINRTN_"'!!"
  1.  . S MAILGRP="BLR APPLICATION PLUG-IN WARNING"
  1.  . D MAIL(.BLRERR,MAILGRP)
  1.  ;
  1.  Q 1
  1.  ;
  1.  ;SEE WHAT ROUTINES BELONG TO THIS PLUGIN AND VERIFY THEY STILL EXIST
  1. CHKRTN(KIDIEN,RTNERROR) ; EP
  1.  S RTNERROR=0
  1.  S RTNNUM=0
  1.  F  S RTNNUM=$O(^XPD(9.7,KIDIEN,"RTN",RTNNUM)) Q:+RTNNUM=0  D
  1.  .S RTNNAME=$G(^XPD(9.7,KIDIEN,"RTN",RTNNUM,0))
  1.  .S X=RTNNAME X ^%ZOSF("TEST") I '$T S RTNERROR=1,RTNERROR(RTNNAME)=""
  1.  Q RTNERROR
  1.  ;
  1. MAIL(BLRERR,MAILGRP) ; EP
  1.  S XMTEXT="BLRERR"
  1.  S XMB=MAILGRP
  1.  S XMDUZ=.5
  1.  D ^XMB
  1.  Q
  1.  ;
  1.  ;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
  1. ISPIMS() ;EP
  1.  N X,IS52,VERS
  1.  S X=$O(^DIC(9.4,"B","PIMS",""))
  1.  Q:X="" 0
  1.  S VERS=$P($G(^DIC(9.4,X,"VERSION")),"^")
  1.  Q:VERS="" 0
  1.  Q:+VERS<5.3 0
  1.  Q 1
  1.  ;
  1.  ;PRINT EXTRA E-SIG INFO. CALLED BY LRPP1 AND LRMUPSU
  1. ESIGINFO ;EP
  1.  ; ----- BEGIN IHS/OIT/MKK LR*5.2*1027
  1.  ;       Code moved to BLRUTIL3 because BLRUTIL was > 15000 bytes
  1.  ; D ESIGINFO^BLRUTIL3
  1.  D ESIGINFO^BLRUTIL5         ; IHS/OIT/MKK - LR*5.2*1033
  1.  Q
  1.  ; ----- END IHS/OIT/MKK LR*5.2*1027
  1.  ; 
  1.  ; 01-Mar-2004
  1.  ; Provider - Specimen Pointer Fix - Tuba City Initial Fix
  1.  ;
  1.  ;----- BEGIN 1019 Mods
  1. NUMDATE(FMDATE)   ; EP - FileMan Date into mm/dd/yy
  1.  Q $P($TR($$FMTE^XLFDT(FMDATE,"2F")," ","0"),"@",1)
  1.  ;
  1. NUMTIME(X)        ; EP - FileMan Date/Time into xx:xx AM/PM
  1.  NEW Y
  1.  I $G(X)="" Q X
  1.  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"
  1.  Q X
  1.  ;----- END 1019 Mods
  1.  ;