BLRALAF ;DAOU/ALA-Set Lab Results Flag
;;5.2T9;LR;**1018**;Nov 17, 2004
;;5.2;LR;**1013,1015**;Nov 18, 2002
;
;**Program Description**
; This program will check for the results flag and
; set up all pertinent information in the results file #63
;
;**PARAMETERS**
; BLRARFL = Review Flag
; BLRARPHY = Responsible Physician
; BLRACT = Count of Abnormal Results
; BLRPCT = Count of Pending Results
; BLRCCT = Count of Critical Results
; BLRRCT = Count of Results with no references
;
CHK ; Check to see if Accession has results before setting in BLRA queue
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
; THIS SET MOVED TO CHKNXT+3
;S BLRACHK=0
;----- END IHS MODIFICATIONS
CHKNXT I $G(LRSS)="",$G(LRAA)'="" S LRSS=$P($G(^LRO(68,LRAA,0)),U,2) ;IHS/ITSC/TPF 03/18/03 FIX LRSS UNDEFINED ERROR REPORTED AT BLACKFEET COMMUNITY **1016**
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S BLRACHK=$S(LRSS="CH":1,1:0) ;BYPASS COMMENTS FOR CH; NOT PERFORMED TESTS WILL HAVE COMMENTS ;START AT 0 FOR MICROS
;----- END IHS MODIFICATIONS
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
;THIS IGNORES ENTRY BY OPTION:
; Itemized routine lab collection" and "Receipt of routine lab collection from wards" as these are not processed at this time. They will be when resulted
I $G(LRIDT)="",((U_"LRPHEXCPT"_U_"LRPHITEM"_U)[$P(XQY0,U)) Q
;----- END IHS MODIFICATIONS
;
S BLRACHK=$O(^LR(LRDFN,LRSS,LRIDT,BLRACHK)) ; FIX #40
;I '(BLRACHK>0&(BLRACHK<9009027)) Q
I BLRACHK=9009027 G CHKNXT
I BLRACHK<1 Q
KILL BLRACHK
;
PHY ; Physician setup
; Get the ordering physician
S BLRAPRAC=$P($G(^LR(LRDFN,LRSS,LRIDT,0)),U,$S(LRSS="MI":7,1:10))
; If no requesting person not found then this is a referral patient
; requesting person is not prompted for.
Q:'$G(BLRAPRAC)
; If not a participating physician, quit
I '$D(^BLRALAB(9009027.1,BLRAPRAC)) K BLRAPRAC Q
; If physician is INACTIVE, quit -ejn 3/22/02
I $P($G(^BLRALAB(9009027.1,BLRAPRAC,0)),U,7)="I" Q
; Check what's there
S BLRADATA=$G(^LR(LRDFN,LRSS,LRIDT,9009027))
S BLRARFL=+$P(BLRADATA,U,1),BLRARPHY=$P(BLRADATA,U,2)
;
;I LRSS="CH"&(BLRARFL)&('$D(LRSA)) K BLRARFL,BLRAPRAC,BLRADATA,BLRARPHY Q
;
; If the Clin Chem accession was already reviewed or completed and
; then amended, the status will be set back for completion
; again. The record of the previous reviewed or completion
; are to be added to the amended values.
I LRSS="CH"&(BLRARFL)&($D(LRSA)) D RSET
;
I BLRARPHY="" S BLRARPHY=BLRAPRAC
;
; Count the number of abnormal and pending results
S BLRACT=0,BLRPCT=0,BLRCCT=0,BLRRCT=0
I LRSS="CH" S BLRAJ=1 D
. D ACC
. ;F S BLRAJ=$O(^LR(LRDFN,LRSS,LRIDT,BLRAJ)) Q:'BLRAJ!(BLRAJ=9009027) D ; FIX #40
. F S BLRAJ=$O(^LR(LRDFN,LRSS,LRIDT,BLRAJ)) Q:'BLRAJ D
.. Q:BLRAJ=9009027
.. I $P($G(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,2)["*" S BLRCCT=BLRCCT+1 Q
.. I $P($G(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,2)'="" S BLRACT=BLRACT+1
.. ;I $P($G(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,1)="pending" S BLRPCT=BLRPCT+1 ; FIX #41 for dup pendings
;
; If microbiology check for preliminary and set the pending flag
; if set to final, set pending flag to complete
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
I LRSS="MI" Q:'$D(^LR(LRDFN,LRSS,LRIDT,1))
;----- END IHS MODIFICATIONS THIS TAKES CARE OF "EMPTY" MICROS THAT ARE DELETED. IF THE DOCTORS WISH TO SEE MICROS WHICH WERE ORDERS BUT THEN "NOT PERFORMED" COMMENT THIS LINE OUT
I LRSS="MI" D
. S BLRAJ=0
. F S BLRAJ=$O(^LR(LRDFN,LRSS,LRIDT,3,BLRAJ)) Q:'BLRAJ D
.. I $P($G(^LR(LRDFN,LRSS,LRIDT,3,BLRAJ,0)),U,1)'="" S BLRACT=BLRACT+1
. I $P($G(^LR(LRDFN,LRSS,LRIDT,1)),U,2)="P" S BLRPCT=1
. I $P($G(^LR(LRDFN,LRSS,LRIDT,1)),U,2)="F" S BLRPCT=0
. D ACC
;
S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,1)=BLRARFL
S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,2)=BLRARPHY
S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,6)=BLRACT
S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,7)=BLRPCT
S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,8)=BLRCCT
S $P(^LR(LRDFN,LRSS,LRIDT,9009027),U,9)=BLRRCT
;
; Set the cross-reference
D SX^BLRALUT1
;
K BLRACT,BLRPCT,BLRCCT,BLRARFL,BLRARPHY,BLRAJ,BLRNM,BLRADATA,BLRAPRAC
K BLRPFL,BLRPRDT,BLRPSDT,BLRPSPH,BLRATXT,BLRRCT
K BREF,RFL,BLRLOW,BLRCLOW,BLRCHI,BLRHI,TST,TST1,SUBTEST,NUM
Q
;
ACC ; Check the Accession File
I LRSS'="MI" D
. S LRORU=$G(^LR(LRDFN,LRSS,LRIDT,"ORU")) Q:LRORU=""
. I $D(^LRO(68,"C",LRORU)) D
.. S LRAA=$O(^LRO(68,"C",LRORU,"")) Q:'LRAA
.. S LRAD=$O(^LRO(68,"C",LRORU,LRAA,"")) Q:'LRAD
.. S LRAN=$O(^LRO(68,"C",LRORU,LRAA,LRAD,"")) Q:'LRAN
;
NEW TST
S TST=0
F NUMTST=0:1 S TST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST)) Q:'TST D
.;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
.I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,6)[("*Not Performed") X:LRSS="MI" $S(BLRPCT=0:"S BLRPCT=0",1:"S BLRPCT=BLRPCT-1") Q
.;----- END IHS MODIFICATIONS
. I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,5)="" D
.. ;FORMAT OF SET BELOW ^LAB(60,1,0)=WBC^^B^CH^CH;384;1^^0^1^3^^^DD(63.04,384,^^^^1^1^9^^0
.. ;I.E. GET DATANAME
.. S LRDN=$P($P($G(^LAB(60,TST,0)),U,5),";",2)
.. ; Do not combine the 4 if statements below into fewer statements. ;DAOU/DJW 1/23/02
.. ;----- BEGIN IHS MODIFICATIONS
.. I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,6)[("*Not Performed") Q
.. ;----- END IHS MODIFCATIONS
.. I '$D(LRDN) D PEND Q
.. I $G(LRDN)="" D PEND Q
.. I '$D(^LR(LRDFN,LRSS,LRIDT,LRDN)) D PEND Q
.. I $P($G(^LR(LRDFN,LRSS,LRIDT,LRDN)),U,1)["pending" D PEND Q
. ; FIX #45 EJN
. ; Check for lab test references
. ;LAB(60,D0,2,0)=^60.02P^^ (#200) LAB TEST INCLUDED IN PANEL
. I $P($G(^LAB(60,TST,1,0)),U,4)'>0 S BLRRCT=BLRRCT+1
. S TST1=TST D CHKREF
. ; Check to see if it is a panel, reset BLRRCT for panels
. I $P($G(^LAB(60,TST,2,0)),U,4)>0 D
.. S BLRRCT=0
.. S NUM=0,SUBTST=""
.. F S NUM=$O(^LAB(60,TST,2,NUM)) Q:'NUM D
... S SUBTST=$P($G(^LAB(60,TST,2,NUM,0)),U,1)
... S TST1=SUBTST D CHKREF
Q
CHKREF ;
S BREF=0,RFL=0
I $G(TST1)="" Q
F S BREF=$O(^LAB(60,TST1,1,BREF)) Q:'BREF D
. S BLRLOW=$P($G(^LAB(60,TST1,1,BREF,0)),U,2),BLRLOW=$$STRIP^XLFSTR(BLRLOW,"""")
. S BLRHI=$P($G(^LAB(60,TST1,1,BREF,0)),U,3),BLRHI=$$STRIP^XLFSTR(BLRHI,"""")
. S BLRCLOW=$P($G(^LAB(60,TST1,1,BREF,0)),U,4),BLRCLOW=$$STRIP^XLFSTR(BLRCLOW,"""")
. S BLRCHI=$P($G(^LAB(60,TST1,1,BREF,0)),U,5),BLRCHI=$$STRIP^XLFSTR(BLRCHI,"""")
. I BLRLOW=""&(BLRHI="")&(BLRCLOW="")&(BLRCHI="") S RFL=1
. I ((BLRLOW?.A)&(BLRLOW'["$S")&(BLRLOW'=""))!((BLRHI?.A)&(BLRHI'["$S")&(BLRHI'="")) S RFL=1
. I ((BLRCLOW?.A)&(BLRCLOW'["$S")&(BLRCLOW'=""))!((BLRCHI?.A)&(BLRCHI'["$S")&(BLRCHI'="")) S RFL=1
. I BLRLOW["<"!(BLRLOW[">")!(BLRHI["<")!(BLRHI[">")!(BLRCLOW["<")!(BLRCLOW[">")!(BLRCHI["<")!(BLRCHI[">") S RFL=1
I RFL>0 S BLRRCT=BLRRCT+1
Q
PEND ; Add 1 to the pending count
S BLRPCT=$G(BLRPCT)+1
I BLRARFL=2 D RSET
Q
RSET ; Reset if signed
S BLRPFL=BLRARFL,BLRPRDT=$P(BLRADATA,U,4)
D KX^BLRALUT1
S BLRPSDT=$P(BLRADATA,U,5),BLRPSPH=$P(BLRADATA,U,3)
S BLRARFL=0,$P(BLRADATA,U,5)="",$P(BLRADATA,U,3)=""
;I BLRPFL=2 D
;. S BLRATXT="Changed lab results previously signed by "_$P(^VA(200,BLRPSPH,0),U,1)_" on "_$$FMTE^XLFDT(BLRPSDT)
;. S BLRNM=$P($G(^LR(LRDFN,LRSS,LRIDT,1,0)),U,3),BLRNM=BLRNM+1
;. S $P(^LR(LRDFN,LRSS,LRIDT,1,0),U,3,4)=BLRNM_U_BLRNM
;. S ^LR(LRDFN,LRSS,LRIDT,1,BLRNM,0)=BLRATXT
;. S ^LR(LRDFN,LRSS,LRIDT,1,"B",$E(BLRATXT,1,30),BLRNM)=""
Q
BLRALAF ;DAOU/ALA-Set Lab Results Flag
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;5.2;LR;**1013,1015**;Nov 18, 2002
+3 ;
+4 ;**Program Description**
+5 ; This program will check for the results flag and
+6 ; set up all pertinent information in the results file #63
+7 ;
+8 ;**PARAMETERS**
+9 ; BLRARFL = Review Flag
+10 ; BLRARPHY = Responsible Physician
+11 ; BLRACT = Count of Abnormal Results
+12 ; BLRPCT = Count of Pending Results
+13 ; BLRCCT = Count of Critical Results
+14 ; BLRRCT = Count of Results with no references
+15 ;
CHK ; Check to see if Accession has results before setting in BLRA queue
+1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+2 ; THIS SET MOVED TO CHKNXT+3
+3 ;S BLRACHK=0
+4 ;----- END IHS MODIFICATIONS
CHKNXT ;IHS/ITSC/TPF 03/18/03 FIX LRSS UNDEFINED ERROR REPORTED AT BLACKFEET COMMUNITY **1016**
IF $GET(LRSS)=""
IF $GET(LRAA)'=""
SET LRSS=$PIECE($GET(^LRO(68,LRAA,0)),U,2)
+1 ;
+2 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+3 ;BYPASS COMMENTS FOR CH; NOT PERFORMED TESTS WILL HAVE COMMENTS ;START AT 0 FOR MICROS
SET BLRACHK=$SELECT(LRSS="CH":1,1:0)
+4 ;----- END IHS MODIFICATIONS
+5 ;
+6 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+7 ;THIS IGNORES ENTRY BY OPTION:
+8 ; Itemized routine lab collection" and "Receipt of routine lab collection from wards" as these are not processed at this time. They will be when resulted
+9 IF $GET(LRIDT)=""
IF ((U_"LRPHEXCPT"_U_"LRPHITEM"_U)[$PIECE(XQY0,U))
QUIT
+10 ;----- END IHS MODIFICATIONS
+11 ;
+12 ; FIX #40
SET BLRACHK=$ORDER(^LR(LRDFN,LRSS,LRIDT,BLRACHK))
+13 ;I '(BLRACHK>0&(BLRACHK<9009027)) Q
+14 IF BLRACHK=9009027
GOTO CHKNXT
+15 IF BLRACHK<1
QUIT
+16 KILL BLRACHK
+17 ;
PHY ; Physician setup
+1 ; Get the ordering physician
+2 SET BLRAPRAC=$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,0)),U,$SELECT(LRSS="MI":7,1:10))
+3 ; If no requesting person not found then this is a referral patient
+4 ; requesting person is not prompted for.
+5 IF '$GET(BLRAPRAC)
QUIT
+6 ; If not a participating physician, quit
+7 IF '$DATA(^BLRALAB(9009027.1,BLRAPRAC))
KILL BLRAPRAC
QUIT
+8 ; If physician is INACTIVE, quit -ejn 3/22/02
+9 IF $PIECE($GET(^BLRALAB(9009027.1,BLRAPRAC,0)),U,7)="I"
QUIT
+10 ; Check what's there
+11 SET BLRADATA=$GET(^LR(LRDFN,LRSS,LRIDT,9009027))
+12 SET BLRARFL=+$PIECE(BLRADATA,U,1)
SET BLRARPHY=$PIECE(BLRADATA,U,2)
+13 ;
+14 ;I LRSS="CH"&(BLRARFL)&('$D(LRSA)) K BLRARFL,BLRAPRAC,BLRADATA,BLRARPHY Q
+15 ;
+16 ; If the Clin Chem accession was already reviewed or completed and
+17 ; then amended, the status will be set back for completion
+18 ; again. The record of the previous reviewed or completion
+19 ; are to be added to the amended values.
+20 IF LRSS="CH"&(BLRARFL)&($DATA(LRSA))
DO RSET
+21 ;
+22 IF BLRARPHY=""
SET BLRARPHY=BLRAPRAC
+23 ;
+24 ; Count the number of abnormal and pending results
+25 SET BLRACT=0
SET BLRPCT=0
SET BLRCCT=0
SET BLRRCT=0
+26 IF LRSS="CH"
SET BLRAJ=1
Begin DoDot:1
+27 DO ACC
+28 ;F S BLRAJ=$O(^LR(LRDFN,LRSS,LRIDT,BLRAJ)) Q:'BLRAJ!(BLRAJ=9009027) D ; FIX #40
+29 FOR
SET BLRAJ=$ORDER(^LR(LRDFN,LRSS,LRIDT,BLRAJ))
IF 'BLRAJ
QUIT
Begin DoDot:2
+30 IF BLRAJ=9009027
QUIT
+31 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,2)["*"
SET BLRCCT=BLRCCT+1
QUIT
+32 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,2)'=""
SET BLRACT=BLRACT+1
+33 ;I $P($G(^LR(LRDFN,LRSS,LRIDT,BLRAJ)),U,1)="pending" S BLRPCT=BLRPCT+1 ; FIX #41 for dup pendings
End DoDot:2
End DoDot:1
+34 ;
+35 ; If microbiology check for preliminary and set the pending flag
+36 ; if set to final, set pending flag to complete
+37 ;
+38 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+39 IF LRSS="MI"
IF '$DATA(^LR(LRDFN,LRSS,LRIDT,1))
QUIT
+40 ;----- END IHS MODIFICATIONS THIS TAKES CARE OF "EMPTY" MICROS THAT ARE DELETED. IF THE DOCTORS WISH TO SEE MICROS WHICH WERE ORDERS BUT THEN "NOT PERFORMED" COMMENT THIS LINE OUT
+41 IF LRSS="MI"
Begin DoDot:1
+42 SET BLRAJ=0
+43 FOR
SET BLRAJ=$ORDER(^LR(LRDFN,LRSS,LRIDT,3,BLRAJ))
IF 'BLRAJ
QUIT
Begin DoDot:2
+44 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,3,BLRAJ,0)),U,1)'=""
SET BLRACT=BLRACT+1
End DoDot:2
+45 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,1)),U,2)="P"
SET BLRPCT=1
+46 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,1)),U,2)="F"
SET BLRPCT=0
+47 DO ACC
End DoDot:1
+48 ;
+49 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,9009027),U,1)=BLRARFL
+50 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,9009027),U,2)=BLRARPHY
+51 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,9009027),U,6)=BLRACT
+52 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,9009027),U,7)=BLRPCT
+53 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,9009027),U,8)=BLRCCT
+54 SET $PIECE(^LR(LRDFN,LRSS,LRIDT,9009027),U,9)=BLRRCT
+55 ;
+56 ; Set the cross-reference
+57 DO SX^BLRALUT1
+58 ;
+59 KILL BLRACT,BLRPCT,BLRCCT,BLRARFL,BLRARPHY,BLRAJ,BLRNM,BLRADATA,BLRAPRAC
+60 KILL BLRPFL,BLRPRDT,BLRPSDT,BLRPSPH,BLRATXT,BLRRCT
+61 KILL BREF,RFL,BLRLOW,BLRCLOW,BLRCHI,BLRHI,TST,TST1,SUBTEST,NUM
+62 QUIT
+63 ;
ACC ; Check the Accession File
+1 IF LRSS'="MI"
Begin DoDot:1
+2 SET LRORU=$GET(^LR(LRDFN,LRSS,LRIDT,"ORU"))
IF LRORU=""
QUIT
+3 IF $DATA(^LRO(68,"C",LRORU))
Begin DoDot:2
+4 SET LRAA=$ORDER(^LRO(68,"C",LRORU,""))
IF 'LRAA
QUIT
+5 SET LRAD=$ORDER(^LRO(68,"C",LRORU,LRAA,""))
IF 'LRAD
QUIT
+6 SET LRAN=$ORDER(^LRO(68,"C",LRORU,LRAA,LRAD,""))
IF 'LRAN
QUIT
End DoDot:2
End DoDot:1
+7 ;
+8 NEW TST
+9 SET TST=0
+10 FOR NUMTST=0:1
SET TST=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST))
IF 'TST
QUIT
Begin DoDot:1
+11 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+12 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,6)[("*Not Performed")
IF LRSS="MI"
XECUTE $SELECT(BLRPCT=0:"S BLRPCT=0",1:"S BLRPCT=BLRPCT-1")
QUIT
+13 ;----- END IHS MODIFICATIONS
+14 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,5)=""
Begin DoDot:2
+15 ;FORMAT OF SET BELOW ^LAB(60,1,0)=WBC^^B^CH^CH;384;1^^0^1^3^^^DD(63.04,384,^^^^1^1^9^^0
+16 ;I.E. GET DATANAME
+17 SET LRDN=$PIECE($PIECE($GET(^LAB(60,TST,0)),U,5),";",2)
+18 ; Do not combine the 4 if statements below into fewer statements. ;DAOU/DJW 1/23/02
+19 ;----- BEGIN IHS MODIFICATIONS
+20 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,6)[("*Not Performed")
QUIT
+21 ;----- END IHS MODIFCATIONS
+22 IF '$DATA(LRDN)
DO PEND
QUIT
+23 IF $GET(LRDN)=""
DO PEND
QUIT
+24 IF '$DATA(^LR(LRDFN,LRSS,LRIDT,LRDN))
DO PEND
QUIT
+25 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,LRDN)),U,1)["pending"
DO PEND
QUIT
End DoDot:2
+26 ; FIX #45 EJN
+27 ; Check for lab test references
+28 ;LAB(60,D0,2,0)=^60.02P^^ (#200) LAB TEST INCLUDED IN PANEL
+29 IF $PIECE($GET(^LAB(60,TST,1,0)),U,4)'>0
SET BLRRCT=BLRRCT+1
+30 SET TST1=TST
DO CHKREF
+31 ; Check to see if it is a panel, reset BLRRCT for panels
+32 IF $PIECE($GET(^LAB(60,TST,2,0)),U,4)>0
Begin DoDot:2
+33 SET BLRRCT=0
+34 SET NUM=0
SET SUBTST=""
+35 FOR
SET NUM=$ORDER(^LAB(60,TST,2,NUM))
IF 'NUM
QUIT
Begin DoDot:3
+36 SET SUBTST=$PIECE($GET(^LAB(60,TST,2,NUM,0)),U,1)
+37 SET TST1=SUBTST
DO CHKREF
End DoDot:3
End DoDot:2
End DoDot:1
+38 QUIT
CHKREF ;
+1 SET BREF=0
SET RFL=0
+2 IF $GET(TST1)=""
QUIT
+3 FOR
SET BREF=$ORDER(^LAB(60,TST1,1,BREF))
IF 'BREF
QUIT
Begin DoDot:1
+4 SET BLRLOW=$PIECE($GET(^LAB(60,TST1,1,BREF,0)),U,2)
SET BLRLOW=$$STRIP^XLFSTR(BLRLOW,"""")
+5 SET BLRHI=$PIECE($GET(^LAB(60,TST1,1,BREF,0)),U,3)
SET BLRHI=$$STRIP^XLFSTR(BLRHI,"""")
+6 SET BLRCLOW=$PIECE($GET(^LAB(60,TST1,1,BREF,0)),U,4)
SET BLRCLOW=$$STRIP^XLFSTR(BLRCLOW,"""")
+7 SET BLRCHI=$PIECE($GET(^LAB(60,TST1,1,BREF,0)),U,5)
SET BLRCHI=$$STRIP^XLFSTR(BLRCHI,"""")
+8 IF BLRLOW=""&(BLRHI="")&(BLRCLOW="")&(BLRCHI="")
SET RFL=1
+9 IF ((BLRLOW?.A)&(BLRLOW'["$S")&(BLRLOW'=""))!((BLRHI?.A)&(BLRHI'["$S")&(BLRHI'=""))
SET RFL=1
+10 IF ((BLRCLOW?.A)&(BLRCLOW'["$S")&(BLRCLOW'=""))!((BLRCHI?.A)&(BLRCHI'["$S")&(BLRCHI'=""))
SET RFL=1
+11 IF BLRLOW["<"!(BLRLOW[">")!(BLRHI["<")!(BLRHI[">")!(BLRCLOW["<")!(BLRCLOW[">")!(BLRCHI["<")!(BLRCHI[">")
SET RFL=1
End DoDot:1
+12 IF RFL>0
SET BLRRCT=BLRRCT+1
+13 QUIT
PEND ; Add 1 to the pending count
+1 SET BLRPCT=$GET(BLRPCT)+1
+2 IF BLRARFL=2
DO RSET
+3 QUIT
RSET ; Reset if signed
+1 SET BLRPFL=BLRARFL
SET BLRPRDT=$PIECE(BLRADATA,U,4)
+2 DO KX^BLRALUT1
+3 SET BLRPSDT=$PIECE(BLRADATA,U,5)
SET BLRPSPH=$PIECE(BLRADATA,U,3)
+4 SET BLRARFL=0
SET $PIECE(BLRADATA,U,5)=""
SET $PIECE(BLRADATA,U,3)=""
+5 ;I BLRPFL=2 D
+6 ;. S BLRATXT="Changed lab results previously signed by "_$P(^VA(200,BLRPSPH,0),U,1)_" on "_$$FMTE^XLFDT(BLRPSDT)
+7 ;. S BLRNM=$P($G(^LR(LRDFN,LRSS,LRIDT,1,0)),U,3),BLRNM=BLRNM+1
+8 ;. S $P(^LR(LRDFN,LRSS,LRIDT,1,0),U,3,4)=BLRNM_U_BLRNM
+9 ;. S ^LR(LRDFN,LRSS,LRIDT,1,BLRNM,0)=BLRATXT
+10 ;. S ^LR(LRDFN,LRSS,LRIDT,1,"B",$E(BLRATXT,1,30),BLRNM)=""
+11 QUIT
