BLRUTIL2 ;IHS/OIT/MKK - MISC IHS LAB UTILITIES (Cont) ; 22-Oct-2013 09:22 ; MKK
;;5.2;IHS LABORATORY;**1020,1022,1024,1027,1028,1030,1033**;NOV 01, 1997
;
; Cloned from ACTIVE^XUSER -- VA Code
ACTIVE(XUDA) ; EP - Get if a user is active.
N %,X1,X2
S X1=$G(^VA(200,+$G(XUDA),0)),X2=$S(X1="":"",1:0)
I $L($P(X1,U,3)) S X2="1^"_$S($L($P($G(^VA(200,XUDA,.1)),U,2)):"ACTIVE",1:"NEW")
S:$P(X1,U,7)=1 X2="0^DISUSER"
S:X2["ACTIVE" $P(X2,U,3)=$P($G(^VA(200,XUDA,1.1)),U) ;Return last sign-on
S %=$P(X1,U,11) I %>0,%<DT S X2="0^TERMINATED^"_%
; Q X2
;
I $P(X2,"^",1)=1 Q X2 ; If active, then OK.
;
; IHS addition; at this point the VA Code believes person INACTIVE
NEW PROVINFO,WRIORDRS,INACTDT
S PROVINFO=$G(^VA(200,+$G(XUDA),"PS")) ; Provider Info
S WRIORDRS=$P(PROVINFO,"^",1) ; Write Orders? (1=Yes)
S INACTDT=+$P(PROVINFO,"^",4) ; Inactive Date
;
I WRIORDRS'=1 Q X2 ; If cannot write orders, Quit
;
;If Inactive date < Today, then Quit with error
I INACTDT>0&(INACTDT<DT) Q "0^TERMINATED^"_INACTDT
;
; Can write orders AND INACTDT>=DT => OK
Q "1^ACTIVE" ; OK
;
BLRHEADR(LINE1,LINE2,LINE3) ; EP -- Generic HEADER array
NEW TMPLN
; W $$CJ^XLFSTR($$LOC^XBFUNC,IOM) ; Location
W $$CJ^XLFSTR($$LOC^XBFUNC,IOM),! ; Location -- LR*5.2*1030
;
S TMPLN=$$CJ^XLFSTR(LINE1,IOM)
S $E(TMPLN,1,13)="Date:"_$$HTE^XLFDT($H,"2DZ") ; Today's Date
S $E(TMPLN,IOM-15)=$J("Time:"_$$NOWTIME,16) ; Current Time
S TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ") ; Trim extra spaces
W TMPLN,!
;
I $G(LINE2)="" Q
;
W $$CJ^XLFSTR(LINE2,IOM),!
;
I $G(LINE3)="" Q
;
W $$CJ^XLFSTR(LINE3,IOM),!
;
Q
;
NOWTIME() ; EP - return NOW TIME in xx:xx AM/PM format
NEW X
S X=$$HTE^XLFDT($H,"2MPZ") ; MM/DD/YY HH:MM am/pm format
S X=$P(X," ",2,3) ; Get HH:MM am/pm
S X=$$UP^XLFSTR(X) ; Uppercase am/pm to AM/PM
Q X
;
NOW24TIM() ; EP -- return NOW TIME in military format: HHMM
Q $P($$HTE^XLFDT($H,"2MZ"),"@",2)
;
; Troubleshooting routine -- look at TaskMan and determine if any
; tasks have been rescheduled due to a "BUSY DEVICE" error. Produce
; a report of all occurrences.
CHKTHL7 ; EP
NEW CNT,CNTTSK,TSK,ONE,ZERO,HEADER,STR,SDATE,STIME
;
S (CNT,CNTTSK,TSK)=0
S HEADER(1)="HLZTCP Cannot Start Issue"
S HEADER(2)="'BUSY DEVICE' Tasks"
S HEADER(3)=" "
S $E(HEADER(4),1)="Task #"
S $E(HEADER(4),13)="Date"
S $E(HEADER(4),21)="Time"
S $E(HEADER(4),31)="Routine"
S $E(HEADER(4),41)="Description"
;
F S TSK=$O(^%ZTSK(TSK)) Q:TSK=""!(TSK'?.N) D
. S CNTTSK=CNTTSK+1
. S ONE=$$UP^XLFSTR($G(^%ZTSK(TSK,.1)))
. I ONE'["RESCHEDULED FOR BUSY DEVICE" Q
. ;
. S ZERO=$G(^%ZTSK(TSK,0))
. S SDATE=$$UP^XLFSTR($$HTE^XLFDT($P(ZERO,"^",5),"2PMZ"))
. S STIME=$P(SDATE," ",2,3)
. S SDATE=$P(SDATE," ",1)
. ;
. I CNT<1 D BLRGSHSH^BLRGMENU
. W TSK
. W ?10,SDATE,$J(STIME,9)
. W ?30,$P(ZERO,"^",2)
. W ?40,$E($G(^%ZTSK(TSK,.03)),1,40)
. W !
. S CNT=CNT+1
;
W:CNT>0 !!,"Number of tasks that were rescheduled = ",CNT,!!
W:CNT<1 !!,"Number of tasks that were examined = ",CNTTSK,!!
Q
;
; ----- BEGIN IHS/OIT/MKK MODIFCATION -- LR*5.2*1022
ERRTRAPR ; EP -- Quick & Dirty Error Trap Report
NEW ETD ; Error Trap Date
NEW ETN ; Error Trap Number
NEW MAXERRPD ; Maximum Errors Per Day
NEW NERRSPD ; Number of Errors Per Day
NEW CNT ; Temporary Count variable
NEW HEADER ; Header Information Array
;
S HEADER(1)="ERROR TRAP REPORT"
S HEADER(2)="Maximum 15 Errors Per Day"
S HEADER(3)=" "
S HEADER(4)="----Error Date----"
S $E(HEADER(4),26)="Err"
S HEADER(5)=" $H"
S $E(HEADER(5),11)="External"
S $E(HEADER(5),26)="Num"
S $E(HEADER(5),31)="Routine"
S $E(HEADER(5),51)="Error"
;
D BLRGSHSH^BLRGMENU
;
S MAXERRPD=15
S ETD="A"
F S ETD=$O(^%ZTER(1,ETD),-1) Q:ETD=""!(ETD'?.N)!(ETD<1) D
. W ETD
. W ?10,$$HTE^XLFDT(ETD,"2DZ")
. S (CNT,ETN)=0
. F S ETN=$O(^%ZTER(1,ETD,1,ETN)) Q:ETN=""!(ETN'?.N)!(ETN>MAXERRPD) D
.. S CNT=CNT+1
.. W ?25,$J(ETN,3) ; Error Trap #
.. W ?30,$P($G(^%ZTER(1,ETD,1,ETN,"ZE")),"^",2) ; Routine Name
.. W ?50,$P($G(^%ZTER(1,ETD,1,ETN,"ZE")),">",1),">" ; Error
.. W !
. I CNT=0 W !
. W !
;
Q
;
; LAB REPORTS HEADER routine
; If and only if the entries in the BLR MASTER CONTROL File are filled
; in, use those as the address of the site. Otherwise, use default
; Lab calls. IHS/OIT/MKK LR*5.2*1022 addition
LABHDR ; EP -- Display Header for Lab Report(s)
I $$GET1^DIQ(9009029,+$G(DUZ(2))_",3","INTERIM REPORT LINE 1")'="" D HDRBLREN Q
;
D NOBLRENT
Q
;
HDRBLREN ; EP -- Header if BLR MASTER FILE address fields ARE NOT blank
NEW INSTNUM ; Institution Number
NEW INTRPTH2 ; Header Line 2
NEW STR
;
S INSTNUM=+$G(DUZ(2)) ; Set the variable
;
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
; BLR MASTER CONTROL FILE field
; S STR=$$CJ^XLFSTR($$GET1^DIQ(9009029,INSTNUM_",3","INTERIM REPORT LINE 1"),IOM)
S STR=$$GET1^DIQ(9009029,INSTNUM_",3","INTERIM REPORT LINE 1")
;I $L(STR)>59 D
;. W "Printed at:"
;. W ?70,"Page "_LRPG
;. W !
;. S STR=$$CJ^XLFSTR(STR,IOM)
;I $L(STR)<60 D
;. S STR=$$CJ^XLFSTR(STR,IOM)
;. S $E(STR,1,11)="Printed at:"
;. S $E(STR,70)="Page "_LRPG
;. S STR=$$TRIM^XLFSTR(STR,"R"," ")
; ----- END IHS/OIT/MKK - LR*5.2*1027
S STR=$$CJ^XLFSTR(STR,IOM) ; IHS/OIT/MKK - LR*5.2*1028
; W STR,!
W !,STR,! ; IHS/OIT/MKK - LR*5.2*1030
;
S INTRPTH2=$$GET1^DIQ(9009029,INSTNUM_",3","INTERIM REPORT LINE 2")
W:$G(INTRPTH2)'="" $$CJ^XLFSTR(INTRPTH2,IOM)
;
W !
;
Q
;
NOBLRENT ; EP -- Header if the BLR MASTER FILE address fields ARE blank
NEW STR,STRA1,STRA2,STRN,INSTHDR,INSTNUM,STRO,STRT
NEW CITY,STATE,ZIP
;
S INSTNUM=+$G(DUZ(2)) ; "Institution" Number from DUZ(2)
;
; If there is no Institution Number from DUZ(2), try the DEFAULT
; INSTITUTION entry in the KERNEL SYSTEM PARAMETERS file.
I INSTNUM<1 S INSTNUM=+$$KSP^XUPARAM("INST")
;
S STRN=$$NAME^XUAF4(INSTNUM) ; Get Site Name
;
I $TR(STRN," ")="" D Q ; If there is no site name, skip
. W !,$$CJ^XLFSTR("<UNKNOWN INSTITUTION>",IOM),!
;
S STRN=STRN_" ("_INSTNUM_")" ; Include Number in string
;
; GET STREET ADDRESS Entries
D STREETAD
;
; If there is no address, print Institution name and then quit
I $TR($TR($G(STRA1),",")," ")="" D Q
. W !,$$CJ^XLFSTR(STRN,IOM),!
;
; At this point, there is some sort of address information -- Print it.
I ($L(STRA1)+$L(STRN)+8)>IOM D ; Too wide -- use 2 lines
. W !,$$CJ^XLFSTR(STRN,IOM)
. W !,$$CJ^XLFSTR(STRA1,IOM),!
;
I ($L(STRA1)+$L(STRN)+8)<(IOM+1) D ; Just use 1 line
. W !,$$CJ^XLFSTR(STRN_" "_STRA1,IOM),!
;
Q
;
STREETAD ; EP -- Get Street Address
S STRA1=$$GET1^DIQ(4,INSTNUM,"STREET ADDR. 1") ; Get the STREET ADDR. 1 entry
;
; If there is a STREET ADDR. 1 entry, then try to get all of the address
I $G(STRA1)'="" D
. S STRA2=$$GET1^DIQ(4,$G(INSTNUM),"STREET ADDR. 2")
. S CITY=$$GET1^DIQ(4,$G(INSTNUM),"CITY")
. S STATE=$$GET1^DIQ(4,$G(INSTNUM),"STATE:ABBREVIATION")
. S ZIP=$$GET1^DIQ(4,$G(INSTNUM),"ZIP")
;
; If there IS NOT a STREET ADDR. 1 entry, then try to get the address
; information from the MAILING address entries.
I $G(STRA1)="" D
. S STRA1=$$GET1^DIQ(4,$G(INSTNUM),"STREET ADDR. 1 (MAILING)")
. S STRA2=$$GET1^DIQ(4,$G(INSTNUM),"STREET ADDR. 2 (MAILING)")
. S CITY=$$GET1^DIQ(4,$G(INSTNUM),"CITY (MAILING)")
. S STATE=$$GET1^DIQ(4,$G(INSTNUM),"STATE (MAILING):ABBREVIATION")
. S ZIP=$$GET1^DIQ(4,$G(INSTNUM),"ZIP (MAILING)")
;
I $G(STRA2)'="" S STRA1=STRA1_" "_STRA2
;
S STRA1=STRA1_" "_CITY_", "_STATE_" "_ZIP
Q
;
; ----- BEGIN IHS/OIT/MKK MODIFCATION -- LR*5.2*1024
; Moved here because BLRUTIL was too large
REPORT2(USER) ; EP
NEW BLRIDS,BLRACCN,CNT
NEW NOW,ENTRYNUM,LABEL,VARIABLE
;
S CNT=0
D ^%ZIS Q:POP
W @IOF
S (ENTRYNUM,LABEL,NOW,VARIABLE)=""
F S NOW=$O(^BLRENTRY(USER,NOW)) Q:NOW="" D
. F S ENTRYNUM=$O(^BLRENTRY(USER,NOW,ENTRYNUM)) Q:ENTRYNUM="" D
.. F S LABEL=$O(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL)) Q:LABEL="" D
... W !,ENTRYNUM,?15,LABEL,?67,NOW
... S (BLRIDS,BLRACCN)=""
... F S VARIABLE=$O(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE)) Q:VARIABLE="" D
.... S VALUE=$G(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE))
.... I VARIABLE["BLRIDS" S BLRIDS=VALUE
.... I VARIABLE["BLRACCN" S BLRACCN=VALUE
... I BLRIDS'=""!(BLRACCN'="") W !,?20,"BLRIDS:",BLRIDS,"; BLRACCN=",BLRACCN
;
D ^%ZISC
Q
;
REPORT3(VARIABLE) ; EP
NEW BLRIDS,BLRACCN
NEW NOW,ENTRYNUM,LABEL,USER
NEW HDRONE,LINES,MAXLINES,PG,QFLG ; IHS/MSC/MKK - LR*5.2*1033
;
NEW HEADER
;
S HEADER(1)="^BLRENTRY TRACE REPORT"
S HEADER(2)="ALL USERS"
;
D HEADERDT^BLRGMENU
D HEADONE^BLRGMENU(.HDRONE) ; IHS/MSC/MKK - LR*5.2*1033
;
S HEADER(3)=" "
S $E(HEADER(4),60)=VARIABLE
S HEADER(5)="DUZ"
S $E(HEADER(5),10)="Date/Time"
S $E(HEADER(5),25)="Num"
S $E(HEADER(5),30)="Label"
S $E(HEADER(5),60)="Value"
;
S MAXLINES=20,LINES=MAXLINES+10 ; IHS/MSC/MKK - LR*5.2*1033
S PG=0,QFLG="NO" ; IHS/MSC/MKK - LR*5.2*1033
;
D ^%ZIS Q:POP
S (ENTRYNUM,LABEL,NOW,USER)=""
F S USER=$O(^BLRENTRY(USER)) Q:USER=""!(QFLG="Q") D
. F S NOW=$O(^BLRENTRY(USER,NOW)) Q:NOW=""!(QFLG="Q") D
.. F S ENTRYNUM=$O(^BLRENTRY(USER,NOW,ENTRYNUM)) Q:ENTRYNUM=""!(QFLG="Q") D
... F S LABEL=$O(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL)) Q:LABEL=""!(QFLG="Q") D
.... I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE) Q:QFLG="Q" ; IHS/MSC/MKK - LR*5.2*1033
.... ;
.... S VALUE=$G(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE))
.... W USER
.... W ?9,NOW
.... W ?24,$J(ENTRYNUM,3)
.... W ?29,$E(LABEL,1,28)
.... W ?59,$E(VALUE,1,19)
.... W !
.... S LINES=LINES+1 ; IHS/MSC/MKK - LR*5.2*1033
;
D ^%ZISC
Q
;
; ----- END IHS/OIT/MKK MODIFCATION -- LR*5.2*1024
;
REPORT4(LABEL) ; EP -- Only print certain "LABELS"
NEW BLRIDS,BLRACCN
; NEW NOW,ENTRYNUM,LABEL,USER
NEW NOW,ENTRYNUM,SRCLABEL,USER ; IHS/MSC/MKK - LR*5.2*1033
NEW HDRONE,LINES,MAXLINES,PG,QFLG
;
NEW HEADER
;
S HEADER(1)="^BLRENTRY TRACE REPORT"
S HEADER(2)="ALL USERS"
;
D HEADERDT^BLRGMENU
D HEADONE^BLRGMENU(.HDRONE) ; IHS/MSC/MKK - LR*5.2*1033
;
; S HEADER(3)=$$CJ^XLFSTR(LABEL)
S HEADER(3)=$$CJ^XLFSTR(LABEL,IOM) ; IHS/MSC/MKK - LR*5.2*1033
S HEADER(4)=" "
S HEADER(5)="DUZ"
S $E(HEADER(5),10)="Date/Time"
S $E(HEADER(5),25)="Num"
S $E(HEADER(5),30)="Variable"
S $E(HEADER(5),40)="Value"
;
S MAXLINES=20,LINES=MAXLINES+10 ; IHS/MSC/MKK - LR*5.2*1033
S PG=0,QFLG="NO" ; IHS/MSC/MKK - LR*5.2*1033
;
D ^%ZIS Q:POP
; S (ENTRYNUM,LABEL,NOW,USER)=""
S (ENTRYNUM,SRCLABEL,NOW,USER)="" ; IHS/MSC/MKK - LR*5.2*1033
F S USER=$O(^BLRENTRY(USER)) Q:USER=""!(QFLG="Q") D
. F S NOW=$O(^BLRENTRY(USER,NOW)) Q:NOW=""!(QFLG="Q") D
.. F S ENTRYNUM=$O(^BLRENTRY(USER,NOW,ENTRYNUM)) Q:ENTRYNUM=""!(QFLG="Q") D
... F S SRCLABEL=$O(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL)) Q:SRCLABEL=""!(QFLG="Q") D
.... Q:SRCLABEL'[LABEL ; IHS/MSC/MKK - LR*5.2*1033
.... F S VARIABLE=$O(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE)) Q:VARIABLE=""!(QFLG="Q") D
..... I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE) Q:QFLG="Q" ; IHS/MSC/MKK - LR*5.2*1033
..... ;
..... S VALUE=$G(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE))
..... W USER
..... W ?9,NOW
..... W ?24,$J(ENTRYNUM,3)
..... W ?29,VARIABLE
..... W ?39,$E(VALUE,1,40)
..... W !
..... S LINES=LINES+1 ; IHS/MSC/MKK - LR*5.2*1033
..... D SUBNODES ; IHS/MSC/MKK - LR*5.2*1033
;
D ^%ZISC
;
D:QFLG'="Q" PRESSKEY^BLRGMENU(9) ; IHS/MSC/MKK - LR*5.2*1033
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
SUBNODES ; EP
NEW STR,SUB2,SUB3,SUB4,SUB5
;
S SUB1=""
F S SUB1=$O(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1)) Q:SUB1="" D
. D SUBLINE(SUB1,$G(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1)))
. S SUB2=""
. F S SUB2=$O(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2)) Q:SUB2="" D
.. D SUBLINE(SUB2,$G(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2)))
.. S SUB3=""
.. F S SUB3=$O(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3)) Q:SUB3="" D
... D SUBLINE(SUB3,$G(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3)))
... S SUB4=""
... F S SUB4=$O(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3,SUB4)) Q:SUB4="" D
.... D SUBLINE(SUB4,$G(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3,SUB4)))
.... S SUB5=""
.... F S SUB5=$O(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3,SUB4,SUB5)) Q:SUB5="" D
..... D SUBLINE(SUB5,$G(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3,SUB4,SUB5)))
Q
;
SUBLINE(WOT,STR) ; EP - Line of Data
W ?39,WOT,! S LINES=LINES+1
Q:$L(STR)<1
;
I $L(STR)<31 W ?49,STR,! S LINES=LINES+1 Q
;
D:$L(STR)>30 LINEWRAP^BLRGMENU(49,STR,30)
;
Q
; ----- END IHS/MSC/MKK - LR*5.2*1033
;
; Purge BLRENTRY global of ALL entries up to (but NOT including) today
PURGBLRE ; EP
NEW DTT,TODAY,WHO
;
S TODAY=$P($$NOW^XLFDT,".")
;
W !!,"Purging BLRENTRY global",!,?5
;
S WHO=0
F S WHO=$O(^BLRENTRY(WHO)) Q:WHO<1 D
. S DTT=0
. F S DTT=$O(^BLRENTRY(WHO,DTT)) Q:DTT<1 D
.. I +$P(DTT,".")'<TODAY W "."
.. I +$P(DTT,".")<TODAY D
... K ^BLRENTRY(WHO,DTT)
... W "*"
.. W:$X>70 !,?5
;
Q
BLRUTIL2 ;IHS/OIT/MKK - MISC IHS LAB UTILITIES (Cont) ; 22-Oct-2013 09:22 ; MKK
+1 ;;5.2;IHS LABORATORY;**1020,1022,1024,1027,1028,1030,1033**;NOV 01, 1997
+2 ;
+3 ; Cloned from ACTIVE^XUSER -- VA Code
ACTIVE(XUDA) ; EP - Get if a user is active.
+1 NEW %,X1,X2
+2 SET X1=$GET(^VA(200,+$GET(XUDA),0))
SET X2=$SELECT(X1="":"",1:0)
+3 IF $LENGTH($PIECE(X1,U,3))
SET X2="1^"_$SELECT($LENGTH($PIECE($GET(^VA(200,XUDA,.1)),U,2)):"ACTIVE",1:"NEW")
+4 IF $PIECE(X1,U,7)=1
SET X2="0^DISUSER"
+5 ;Return last sign-on
IF X2["ACTIVE"
SET $PIECE(X2,U,3)=$PIECE($GET(^VA(200,XUDA,1.1)),U)
+6 SET %=$PIECE(X1,U,11)
IF %>0
IF %<DT
SET X2="0^TERMINATED^"_%
+7 ; Q X2
+8 ;
+9 ; If active, then OK.
IF $PIECE(X2,"^",1)=1
QUIT X2
+10 ;
+11 ; IHS addition; at this point the VA Code believes person INACTIVE
+12 NEW PROVINFO,WRIORDRS,INACTDT
+13 ; Provider Info
SET PROVINFO=$GET(^VA(200,+$GET(XUDA),"PS"))
+14 ; Write Orders? (1=Yes)
SET WRIORDRS=$PIECE(PROVINFO,"^",1)
+15 ; Inactive Date
SET INACTDT=+$PIECE(PROVINFO,"^",4)
+16 ;
+17 ; If cannot write orders, Quit
IF WRIORDRS'=1
QUIT X2
+18 ;
+19 ;If Inactive date < Today, then Quit with error
+20 IF INACTDT>0&(INACTDT<DT)
QUIT "0^TERMINATED^"_INACTDT
+21 ;
+22 ; Can write orders AND INACTDT>=DT => OK
+23 ; OK
QUIT "1^ACTIVE"
+24 ;
BLRHEADR(LINE1,LINE2,LINE3) ; EP -- Generic HEADER array
+1 NEW TMPLN
+2 ; W $$CJ^XLFSTR($$LOC^XBFUNC,IOM) ; Location
+3 ; Location -- LR*5.2*1030
WRITE $$CJ^XLFSTR($$LOC^XBFUNC,IOM),!
+4 ;
+5 SET TMPLN=$$CJ^XLFSTR(LINE1,IOM)
+6 ; Today's Date
SET $EXTRACT(TMPLN,1,13)="Date:"_$$HTE^XLFDT($HOROLOG,"2DZ")
+7 ; Current Time
SET $EXTRACT(TMPLN,IOM-15)=$JUSTIFY("Time:"_$$NOWTIME,16)
+8 ; Trim extra spaces
SET TMPLN=$$TRIM^XLFSTR(TMPLN,"R"," ")
+9 WRITE TMPLN,!
+10 ;
+11 IF $GET(LINE2)=""
QUIT
+12 ;
+13 WRITE $$CJ^XLFSTR(LINE2,IOM),!
+14 ;
+15 IF $GET(LINE3)=""
QUIT
+16 ;
+17 WRITE $$CJ^XLFSTR(LINE3,IOM),!
+18 ;
+19 QUIT
+20 ;
NOWTIME() ; EP - return NOW TIME in xx:xx AM/PM format
+1 NEW X
+2 ; MM/DD/YY HH:MM am/pm format
SET X=$$HTE^XLFDT($HOROLOG,"2MPZ")
+3 ; Get HH:MM am/pm
SET X=$PIECE(X," ",2,3)
+4 ; Uppercase am/pm to AM/PM
SET X=$$UP^XLFSTR(X)
+5 QUIT X
+6 ;
NOW24TIM() ; EP -- return NOW TIME in military format: HHMM
+1 QUIT $PIECE($$HTE^XLFDT($HOROLOG,"2MZ"),"@",2)
+2 ;
+3 ; Troubleshooting routine -- look at TaskMan and determine if any
+4 ; tasks have been rescheduled due to a "BUSY DEVICE" error. Produce
+5 ; a report of all occurrences.
CHKTHL7 ; EP
+1 NEW CNT,CNTTSK,TSK,ONE,ZERO,HEADER,STR,SDATE,STIME
+2 ;
+3 SET (CNT,CNTTSK,TSK)=0
+4 SET HEADER(1)="HLZTCP Cannot Start Issue"
+5 SET HEADER(2)="'BUSY DEVICE' Tasks"
+6 SET HEADER(3)=" "
+7 SET $EXTRACT(HEADER(4),1)="Task #"
+8 SET $EXTRACT(HEADER(4),13)="Date"
+9 SET $EXTRACT(HEADER(4),21)="Time"
+10 SET $EXTRACT(HEADER(4),31)="Routine"
+11 SET $EXTRACT(HEADER(4),41)="Description"
+12 ;
+13 FOR
SET TSK=$ORDER(^%ZTSK(TSK))
IF TSK=""!(TSK'?.N)
QUIT
Begin DoDot:1
+14 SET CNTTSK=CNTTSK+1
+15 SET ONE=$$UP^XLFSTR($GET(^%ZTSK(TSK,.1)))
+16 IF ONE'["RESCHEDULED FOR BUSY DEVICE"
QUIT
+17 ;
+18 SET ZERO=$GET(^%ZTSK(TSK,0))
+19 SET SDATE=$$UP^XLFSTR($$HTE^XLFDT($PIECE(ZERO,"^",5),"2PMZ"))
+20 SET STIME=$PIECE(SDATE," ",2,3)
+21 SET SDATE=$PIECE(SDATE," ",1)
+22 ;
+23 IF CNT<1
DO BLRGSHSH^BLRGMENU
+24 WRITE TSK
+25 WRITE ?10,SDATE,$JUSTIFY(STIME,9)
+26 WRITE ?30,$PIECE(ZERO,"^",2)
+27 WRITE ?40,$EXTRACT($GET(^%ZTSK(TSK,.03)),1,40)
+28 WRITE !
+29 SET CNT=CNT+1
End DoDot:1
+30 ;
+31 IF CNT>0
WRITE !!,"Number of tasks that were rescheduled = ",CNT,!!
+32 IF CNT<1
WRITE !!,"Number of tasks that were examined = ",CNTTSK,!!
+33 QUIT
+34 ;
+35 ; ----- BEGIN IHS/OIT/MKK MODIFCATION -- LR*5.2*1022
ERRTRAPR ; EP -- Quick & Dirty Error Trap Report
+1 ; Error Trap Date
NEW ETD
+2 ; Error Trap Number
NEW ETN
+3 ; Maximum Errors Per Day
NEW MAXERRPD
+4 ; Number of Errors Per Day
NEW NERRSPD
+5 ; Temporary Count variable
NEW CNT
+6 ; Header Information Array
NEW HEADER
+7 ;
+8 SET HEADER(1)="ERROR TRAP REPORT"
+9 SET HEADER(2)="Maximum 15 Errors Per Day"
+10 SET HEADER(3)=" "
+11 SET HEADER(4)="----Error Date----"
+12 SET $EXTRACT(HEADER(4),26)="Err"
+13 SET HEADER(5)=" $H"
+14 SET $EXTRACT(HEADER(5),11)="External"
+15 SET $EXTRACT(HEADER(5),26)="Num"
+16 SET $EXTRACT(HEADER(5),31)="Routine"
+17 SET $EXTRACT(HEADER(5),51)="Error"
+18 ;
+19 DO BLRGSHSH^BLRGMENU
+20 ;
+21 SET MAXERRPD=15
+22 SET ETD="A"
+23 FOR
SET ETD=$ORDER(^%ZTER(1,ETD),-1)
IF ETD=""!(ETD'?.N)!(ETD<1)
QUIT
Begin DoDot:1
+24 WRITE ETD
+25 WRITE ?10,$$HTE^XLFDT(ETD,"2DZ")
+26 SET (CNT,ETN)=0
+27 FOR
SET ETN=$ORDER(^%ZTER(1,ETD,1,ETN))
IF ETN=""!(ETN'?.N)!(ETN>MAXERRPD)
QUIT
Begin DoDot:2
+28 SET CNT=CNT+1
+29 ; Error Trap #
WRITE ?25,$JUSTIFY(ETN,3)
+30 ; Routine Name
WRITE ?30,$PIECE($GET(^%ZTER(1,ETD,1,ETN,"ZE")),"^",2)
+31 ; Error
WRITE ?50,$PIECE($GET(^%ZTER(1,ETD,1,ETN,"ZE")),">",1),">"
+32 WRITE !
End DoDot:2
+33 IF CNT=0
WRITE !
+34 WRITE !
End DoDot:1
+35 ;
+36 QUIT
+37 ;
+38 ; LAB REPORTS HEADER routine
+39 ; If and only if the entries in the BLR MASTER CONTROL File are filled
+40 ; in, use those as the address of the site. Otherwise, use default
+41 ; Lab calls. IHS/OIT/MKK LR*5.2*1022 addition
LABHDR ; EP -- Display Header for Lab Report(s)
+1 IF $$GET1^DIQ(9009029,+$GET(DUZ(2))_",3","INTERIM REPORT LINE 1")'=""
DO HDRBLREN
QUIT
+2 ;
+3 DO NOBLRENT
+4 QUIT
+5 ;
HDRBLREN ; EP -- Header if BLR MASTER FILE address fields ARE NOT blank
+1 ; Institution Number
NEW INSTNUM
+2 ; Header Line 2
NEW INTRPTH2
+3 NEW STR
+4 ;
+5 ; Set the variable
SET INSTNUM=+$GET(DUZ(2))
+6 ;
+7 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1027
+8 ; BLR MASTER CONTROL FILE field
+9 ; S STR=$$CJ^XLFSTR($$GET1^DIQ(9009029,INSTNUM_",3","INTERIM REPORT LINE 1"),IOM)
+10 SET STR=$$GET1^DIQ(9009029,INSTNUM_",3","INTERIM REPORT LINE 1")
+11 ;I $L(STR)>59 D
+12 ;. W "Printed at:"
+13 ;. W ?70,"Page "_LRPG
+14 ;. W !
+15 ;. S STR=$$CJ^XLFSTR(STR,IOM)
+16 ;I $L(STR)<60 D
+17 ;. S STR=$$CJ^XLFSTR(STR,IOM)
+18 ;. S $E(STR,1,11)="Printed at:"
+19 ;. S $E(STR,70)="Page "_LRPG
+20 ;. S STR=$$TRIM^XLFSTR(STR,"R"," ")
+21 ; ----- END IHS/OIT/MKK - LR*5.2*1027
+22 ; IHS/OIT/MKK - LR*5.2*1028
SET STR=$$CJ^XLFSTR(STR,IOM)
+23 ; W STR,!
+24 ; IHS/OIT/MKK - LR*5.2*1030
WRITE !,STR,!
+25 ;
+26 SET INTRPTH2=$$GET1^DIQ(9009029,INSTNUM_",3","INTERIM REPORT LINE 2")
+27 IF $GET(INTRPTH2)'=""
WRITE $$CJ^XLFSTR(INTRPTH2,IOM)
+28 ;
+29 WRITE !
+30 ;
+31 QUIT
+32 ;
NOBLRENT ; EP -- Header if the BLR MASTER FILE address fields ARE blank
+1 NEW STR,STRA1,STRA2,STRN,INSTHDR,INSTNUM,STRO,STRT
+2 NEW CITY,STATE,ZIP
+3 ;
+4 ; "Institution" Number from DUZ(2)
SET INSTNUM=+$GET(DUZ(2))
+5 ;
+6 ; If there is no Institution Number from DUZ(2), try the DEFAULT
+7 ; INSTITUTION entry in the KERNEL SYSTEM PARAMETERS file.
+8 IF INSTNUM<1
SET INSTNUM=+$$KSP^XUPARAM("INST")
+9 ;
+10 ; Get Site Name
SET STRN=$$NAME^XUAF4(INSTNUM)
+11 ;
+12 ; If there is no site name, skip
IF $TRANSLATE(STRN," ")=""
Begin DoDot:1
+13 WRITE !,$$CJ^XLFSTR("<UNKNOWN INSTITUTION>",IOM),!
End DoDot:1
QUIT
+14 ;
+15 ; Include Number in string
SET STRN=STRN_" ("_INSTNUM_")"
+16 ;
+17 ; GET STREET ADDRESS Entries
+18 DO STREETAD
+19 ;
+20 ; If there is no address, print Institution name and then quit
+21 IF $TRANSLATE($TRANSLATE($GET(STRA1),",")," ")=""
Begin DoDot:1
+22 WRITE !,$$CJ^XLFSTR(STRN,IOM),!
End DoDot:1
QUIT
+23 ;
+24 ; At this point, there is some sort of address information -- Print it.
+25 ; Too wide -- use 2 lines
IF ($LENGTH(STRA1)+$LENGTH(STRN)+8)>IOM
Begin DoDot:1
+26 WRITE !,$$CJ^XLFSTR(STRN,IOM)
+27 WRITE !,$$CJ^XLFSTR(STRA1,IOM),!
End DoDot:1
+28 ;
+29 ; Just use 1 line
IF ($LENGTH(STRA1)+$LENGTH(STRN)+8)<(IOM+1)
Begin DoDot:1
+30 WRITE !,$$CJ^XLFSTR(STRN_" "_STRA1,IOM),!
End DoDot:1
+31 ;
+32 QUIT
+33 ;
STREETAD ; EP -- Get Street Address
+1 ; Get the STREET ADDR. 1 entry
SET STRA1=$$GET1^DIQ(4,INSTNUM,"STREET ADDR. 1")
+2 ;
+3 ; If there is a STREET ADDR. 1 entry, then try to get all of the address
+4 IF $GET(STRA1)'=""
Begin DoDot:1
+5 SET STRA2=$$GET1^DIQ(4,$GET(INSTNUM),"STREET ADDR. 2")
+6 SET CITY=$$GET1^DIQ(4,$GET(INSTNUM),"CITY")
+7 SET STATE=$$GET1^DIQ(4,$GET(INSTNUM),"STATE:ABBREVIATION")
+8 SET ZIP=$$GET1^DIQ(4,$GET(INSTNUM),"ZIP")
End DoDot:1
+9 ;
+10 ; If there IS NOT a STREET ADDR. 1 entry, then try to get the address
+11 ; information from the MAILING address entries.
+12 IF $GET(STRA1)=""
Begin DoDot:1
+13 SET STRA1=$$GET1^DIQ(4,$GET(INSTNUM),"STREET ADDR. 1 (MAILING)")
+14 SET STRA2=$$GET1^DIQ(4,$GET(INSTNUM),"STREET ADDR. 2 (MAILING)")
+15 SET CITY=$$GET1^DIQ(4,$GET(INSTNUM),"CITY (MAILING)")
+16 SET STATE=$$GET1^DIQ(4,$GET(INSTNUM),"STATE (MAILING):ABBREVIATION")
+17 SET ZIP=$$GET1^DIQ(4,$GET(INSTNUM),"ZIP (MAILING)")
End DoDot:1
+18 ;
+19 IF $GET(STRA2)'=""
SET STRA1=STRA1_" "_STRA2
+20 ;
+21 SET STRA1=STRA1_" "_CITY_", "_STATE_" "_ZIP
+22 QUIT
+23 ;
+24 ; ----- BEGIN IHS/OIT/MKK MODIFCATION -- LR*5.2*1024
+25 ; Moved here because BLRUTIL was too large
REPORT2(USER) ; EP
+1 NEW BLRIDS,BLRACCN,CNT
+2 NEW NOW,ENTRYNUM,LABEL,VARIABLE
+3 ;
+4 SET CNT=0
+5 DO ^%ZIS
IF POP
QUIT
+6 WRITE @IOF
+7 SET (ENTRYNUM,LABEL,NOW,VARIABLE)=""
+8 FOR
SET NOW=$ORDER(^BLRENTRY(USER,NOW))
IF NOW=""
QUIT
Begin DoDot:1
+9 FOR
SET ENTRYNUM=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM))
IF ENTRYNUM=""
QUIT
Begin DoDot:2
+10 FOR
SET LABEL=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL))
IF LABEL=""
QUIT
Begin DoDot:3
+11 WRITE !,ENTRYNUM,?15,LABEL,?67,NOW
+12 SET (BLRIDS,BLRACCN)=""
+13 FOR
SET VARIABLE=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE))
IF VARIABLE=""
QUIT
Begin DoDot:4
+14 SET VALUE=$GET(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE))
+15 IF VARIABLE["BLRIDS"
SET BLRIDS=VALUE
+16 IF VARIABLE["BLRACCN"
SET BLRACCN=VALUE
End DoDot:4
+17 IF BLRIDS'=""!(BLRACCN'="")
WRITE !,?20,"BLRIDS:",BLRIDS,"; BLRACCN=",BLRACCN
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 DO ^%ZISC
+20 QUIT
+21 ;
REPORT3(VARIABLE) ; EP
+1 NEW BLRIDS,BLRACCN
+2 NEW NOW,ENTRYNUM,LABEL,USER
+3 ; IHS/MSC/MKK - LR*5.2*1033
NEW HDRONE,LINES,MAXLINES,PG,QFLG
+4 ;
+5 NEW HEADER
+6 ;
+7 SET HEADER(1)="^BLRENTRY TRACE REPORT"
+8 SET HEADER(2)="ALL USERS"
+9 ;
+10 DO HEADERDT^BLRGMENU
+11 ; IHS/MSC/MKK - LR*5.2*1033
DO HEADONE^BLRGMENU(.HDRONE)
+12 ;
+13 SET HEADER(3)=" "
+14 SET $EXTRACT(HEADER(4),60)=VARIABLE
+15 SET HEADER(5)="DUZ"
+16 SET $EXTRACT(HEADER(5),10)="Date/Time"
+17 SET $EXTRACT(HEADER(5),25)="Num"
+18 SET $EXTRACT(HEADER(5),30)="Label"
+19 SET $EXTRACT(HEADER(5),60)="Value"
+20 ;
+21 ; IHS/MSC/MKK - LR*5.2*1033
SET MAXLINES=20
SET LINES=MAXLINES+10
+22 ; IHS/MSC/MKK - LR*5.2*1033
SET PG=0
SET QFLG="NO"
+23 ;
+24 DO ^%ZIS
IF POP
QUIT
+25 SET (ENTRYNUM,LABEL,NOW,USER)=""
+26 FOR
SET USER=$ORDER(^BLRENTRY(USER))
IF USER=""!(QFLG="Q")
QUIT
Begin DoDot:1
+27 FOR
SET NOW=$ORDER(^BLRENTRY(USER,NOW))
IF NOW=""!(QFLG="Q")
QUIT
Begin DoDot:2
+28 FOR
SET ENTRYNUM=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM))
IF ENTRYNUM=""!(QFLG="Q")
QUIT
Begin DoDot:3
+29 FOR
SET LABEL=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL))
IF LABEL=""!(QFLG="Q")
QUIT
Begin DoDot:4
+30 ; IHS/MSC/MKK - LR*5.2*1033
IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
IF QFLG="Q"
QUIT
+31 ;
+32 SET VALUE=$GET(^BLRENTRY(USER,NOW,ENTRYNUM,LABEL,VARIABLE))
+33 WRITE USER
+34 WRITE ?9,NOW
+35 WRITE ?24,$JUSTIFY(ENTRYNUM,3)
+36 WRITE ?29,$EXTRACT(LABEL,1,28)
+37 WRITE ?59,$EXTRACT(VALUE,1,19)
+38 WRITE !
+39 ; IHS/MSC/MKK - LR*5.2*1033
SET LINES=LINES+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+40 ;
+41 DO ^%ZISC
+42 QUIT
+43 ;
+44 ; ----- END IHS/OIT/MKK MODIFCATION -- LR*5.2*1024
+45 ;
REPORT4(LABEL) ; EP -- Only print certain "LABELS"
+1 NEW BLRIDS,BLRACCN
+2 ; NEW NOW,ENTRYNUM,LABEL,USER
+3 ; IHS/MSC/MKK - LR*5.2*1033
NEW NOW,ENTRYNUM,SRCLABEL,USER
+4 NEW HDRONE,LINES,MAXLINES,PG,QFLG
+5 ;
+6 NEW HEADER
+7 ;
+8 SET HEADER(1)="^BLRENTRY TRACE REPORT"
+9 SET HEADER(2)="ALL USERS"
+10 ;
+11 DO HEADERDT^BLRGMENU
+12 ; IHS/MSC/MKK - LR*5.2*1033
DO HEADONE^BLRGMENU(.HDRONE)
+13 ;
+14 ; S HEADER(3)=$$CJ^XLFSTR(LABEL)
+15 ; IHS/MSC/MKK - LR*5.2*1033
SET HEADER(3)=$$CJ^XLFSTR(LABEL,IOM)
+16 SET HEADER(4)=" "
+17 SET HEADER(5)="DUZ"
+18 SET $EXTRACT(HEADER(5),10)="Date/Time"
+19 SET $EXTRACT(HEADER(5),25)="Num"
+20 SET $EXTRACT(HEADER(5),30)="Variable"
+21 SET $EXTRACT(HEADER(5),40)="Value"
+22 ;
+23 ; IHS/MSC/MKK - LR*5.2*1033
SET MAXLINES=20
SET LINES=MAXLINES+10
+24 ; IHS/MSC/MKK - LR*5.2*1033
SET PG=0
SET QFLG="NO"
+25 ;
+26 DO ^%ZIS
IF POP
QUIT
+27 ; S (ENTRYNUM,LABEL,NOW,USER)=""
+28 ; IHS/MSC/MKK - LR*5.2*1033
SET (ENTRYNUM,SRCLABEL,NOW,USER)=""
+29 FOR
SET USER=$ORDER(^BLRENTRY(USER))
IF USER=""!(QFLG="Q")
QUIT
Begin DoDot:1
+30 FOR
SET NOW=$ORDER(^BLRENTRY(USER,NOW))
IF NOW=""!(QFLG="Q")
QUIT
Begin DoDot:2
+31 FOR
SET ENTRYNUM=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM))
IF ENTRYNUM=""!(QFLG="Q")
QUIT
Begin DoDot:3
+32 FOR
SET SRCLABEL=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL))
IF SRCLABEL=""!(QFLG="Q")
QUIT
Begin DoDot:4
+33 ; IHS/MSC/MKK - LR*5.2*1033
IF SRCLABEL'[LABEL
QUIT
+34 FOR
SET VARIABLE=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE))
IF VARIABLE=""!(QFLG="Q")
QUIT
Begin DoDot:5
+35 ; IHS/MSC/MKK - LR*5.2*1033
IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)
IF QFLG="Q"
QUIT
+36 ;
+37 SET VALUE=$GET(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE))
+38 WRITE USER
+39 WRITE ?9,NOW
+40 WRITE ?24,$JUSTIFY(ENTRYNUM,3)
+41 WRITE ?29,VARIABLE
+42 WRITE ?39,$EXTRACT(VALUE,1,40)
+43 WRITE !
+44 ; IHS/MSC/MKK - LR*5.2*1033
SET LINES=LINES+1
+45 ; IHS/MSC/MKK - LR*5.2*1033
DO SUBNODES
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+46 ;
+47 DO ^%ZISC
+48 ;
+49 ; IHS/MSC/MKK - LR*5.2*1033
IF QFLG'="Q"
DO PRESSKEY^BLRGMENU(9)
+50 QUIT
+51 ;
+52 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
SUBNODES ; EP
+1 NEW STR,SUB2,SUB3,SUB4,SUB5
+2 ;
+3 SET SUB1=""
+4 FOR
SET SUB1=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1))
IF SUB1=""
QUIT
Begin DoDot:1
+5 DO SUBLINE(SUB1,$GET(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1)))
+6 SET SUB2=""
+7 FOR
SET SUB2=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2))
IF SUB2=""
QUIT
Begin DoDot:2
+8 DO SUBLINE(SUB2,$GET(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2)))
+9 SET SUB3=""
+10 FOR
SET SUB3=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3))
IF SUB3=""
QUIT
Begin DoDot:3
+11 DO SUBLINE(SUB3,$GET(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3)))
+12 SET SUB4=""
+13 FOR
SET SUB4=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3,SUB4))
IF SUB4=""
QUIT
Begin DoDot:4
+14 DO SUBLINE(SUB4,$GET(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3,SUB4)))
+15 SET SUB5=""
+16 FOR
SET SUB5=$ORDER(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3,SUB4,SUB5))
IF SUB5=""
QUIT
Begin DoDot:5
+17 DO SUBLINE(SUB5,$GET(^BLRENTRY(USER,NOW,ENTRYNUM,SRCLABEL,VARIABLE,SUB1,SUB2,SUB3,SUB4,SUB5)))
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
SUBLINE(WOT,STR) ; EP - Line of Data
+1 WRITE ?39,WOT,!
SET LINES=LINES+1
+2 IF $LENGTH(STR)<1
QUIT
+3 ;
+4 IF $LENGTH(STR)<31
WRITE ?49,STR,!
SET LINES=LINES+1
QUIT
+5 ;
+6 IF $LENGTH(STR)>30
DO LINEWRAP^BLRGMENU(49,STR,30)
+7 ;
+8 QUIT
+9 ; ----- END IHS/MSC/MKK - LR*5.2*1033
+10 ;
+11 ; Purge BLRENTRY global of ALL entries up to (but NOT including) today
PURGBLRE ; EP
+1 NEW DTT,TODAY,WHO
+2 ;
+3 SET TODAY=$PIECE($$NOW^XLFDT,".")
+4 ;
+5 WRITE !!,"Purging BLRENTRY global",!,?5
+6 ;
+7 SET WHO=0
+8 FOR
SET WHO=$ORDER(^BLRENTRY(WHO))
IF WHO<1
QUIT
Begin DoDot:1
+9 SET DTT=0
+10 FOR
SET DTT=$ORDER(^BLRENTRY(WHO,DTT))
IF DTT<1
QUIT
Begin DoDot:2
+11 IF +$PIECE(DTT,".")'<TODAY
WRITE "."
+12 IF +$PIECE(DTT,".")<TODAY
Begin DoDot:3
+13 KILL ^BLRENTRY(WHO,DTT)
+14 WRITE "*"
End DoDot:3
+15 IF $X>70
WRITE !,?5
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT
