LRHYF1 ;DALOI/HOAK - LAB ARRIVAL AND DRAW TIME UPDATER ;4/13/1999
;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93
;
;
PAT ;
;
; This routine is used by lab to display updated lab arrival
; and collection time as well as the phlebotomist and the provider
; as well as the date time ordered.
;
;
QUIT
ORD ;
;
QUIT
;
SINGLE ;
K LRAA,LRAN,LRAD,LRUID,LRACC6
; This block calls up the testing demographics.
;
W !!
S LRACC="" K LRHN0
D ^LRHYU4
I $G(LRORD) D ORD
I LRAN<1 D END QUIT
I $L(X)'=10 S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
I X S LRUID=X
;
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." G SINGLE
; KUNKE OPTION TY-IN
KUNKE ;
S LRUNC=1
S LRDAT=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4),LRSN=+$P(^(0),U,5)
D:'$G(LRKUNKE) LST1^LRHYLS1
;
;
; Adding urgency to the display
S LRTEST=0
K LRURG2
F S LRTEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST)) Q:+LRTEST'>0 D
. W !,$P($G(^LAB(60,LRTEST,0)),U)
. S LRURG7=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
. I LRURG7=1 S LRURG=LRURG7
. I LRURG7=2 S LRURG2=2
I $G(LRURG2)=2 D
. Q:$G(LRURG)=1 S LRURG=2
;
;
; Blink urgency if MED-EMERGE
S LRURG=$G(LRURG,LRURG7)
W !,$S($D(^LAB(62.05,+LRURG,0)):$P(^(0),U),1:"")," "
;
;
D EDIT
;
;
I $G(LREND) W !,"Please start over..." K LREND,LRIDTNEW
D END
I $G(LRKUNKE) G SINGLE^LRHYT1 QUIT
G SINGLE
;
QUIT
;
END ;
K LRAA,LRAD,LRAN,LRBLOOD,LRARIVE,LRBLOOD,LRCE,LRDAT,LRDFN,LRIDT
K LRDLA,LRDLC,LRDPF,LRDRAW,LRDT0,LRDTO,LRHYDUZ,LRHYNISH,LRPRAC
K LRSN,LRTEST,LRURG,PNM,SSN,VAIN,VADM
QUIT
;
EDIT ;
Q:LRAA=-1
S LRDFN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
S LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5) ; old LRIDT
CHECK ;
; Check for results. Quit if results present
;
;
PAST ;
K LRHYDUZ
; look at Micro And CH subscripted tests
I $D(^LR(LRDFN,"CH",LRIDT)) S LRSS="CH"
E S LRSS="MI"
;
; run review option here and show it there has been a previous
; updating of this accession
I $G(LRKUNKE)'=1 I $D(^XUSEC("LRLAB",DUZ)) D EDIT^LRHYF2
K LRARIVE
;
;
W !
; WE need an event to stop non-LRLAB key holders from entering
; LAB ARRIVAL TIME
BACK G:'$D(^XUSEC("LRLAB",DUZ)) DRAW
G DRAW
K %DT
D NOW^%DTC
S %DT="AERSZ"
D ^%DT
I Y=-1 S LREND=1 QUIT
I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
D NOW^%DTC
I Y>% W !!,"Can't accept future times!" W *7 G BACK
S LRARIVE=Y I +LRARIVE'>0 S LRARIVE=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)
;
SET ;
S $P(^LRO(69,LRDAT,1,LRSN,3),U)=$G(LRARIVE)
;
S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=$G(LRARIVE)
S $P(^LR(LRDFN,"MI",LRIDT,0),U,10)=$G(LRARIVE)
I $G(LRARIVE) S ^LRO(68,LRAA,1,LRAD,1,"E",LRARIVE,LRAN)=""
;
;
DRAW ;
QUIT
THERE ;
W !
K %DT
D NOW^%DTC
S %DT="AESRZ"
S %DT("A")="Please enter updated DRAW/COLLECTION TIME: "
;
; Only default if lrlab owner
I +LRDRAW7>0 S LRDRAW7=$$Y2K^LRX(LRDRAW7)
E S LRDRAW7=$$Y2K^LRX($P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U))
I $D(^XUSEC("LRLAB",DUZ)) S %DT("B")=$P(LRDRAW7,"@")_"@"_$E($P(LRDRAW7,"@",2),1,5)
;
D ^%DT
I X="" G DRAW
I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
I Y=-1 S LRUP="YES"
E S LRUP="NO"
S LRDRAW=Y I +LRDRAW'>0 S LRDRAW=LRDRAW7
S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=LRDRAW
;
;
I $D(^XUSEC("LRLAB",DUZ)) G TIC
;
GUY ; COLLECTOR DEMOGRAPHICS stuff this into LR...99 COMMENT FIELD.
S LRHYNISH=$P(^VA(200,DUZ,0),U,2)
I '$D(^XUSEC("LRLAB",DUZ)) S LRPON=$P($G(^VA(200,DUZ,0)),U)
W !!!
;
D
. D SCRNON^LRHYUTL
. W IOBON
. W IORVON
. W IODHLT,LRHYNISH
. W !
. W IODHLB,LRHYNISH
. W !!
. W IORVOFF
. W IOBOFF
. D SCRNOFF^LRHYUTL
;
W !!,"Your initials have been captured." D
. S DIR(0)="Y" S DIR("B")="YES"
. S DIR("A")="Is this correct?"
. D ^DIR
. I $D(DTOUT)!($D(DUOUT)) QUIT
. ;
. I Y S LRHYDUZ=LRPON
. Q:Y>0
. S DIC("A")="Enter collector here."
. S DIC="^VA(200,"
. S DIC(0)="AEMQZ"
. D ^DIC
. I +Y>0 S LRHYDUZ=$P(Y(0),U) S LRPON=$P(^VA(200,DUZ,0),U)
;
; This global serves as an interim solution until lab files can
; be updated
TIC ;
S LRARIVE=$G(LRARIVE,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRHYF1 4208 printed Dec 13, 2024@02:15:19 Page 2
LRHYF1 ;DALOI/HOAK - LAB ARRIVAL AND DRAW TIME UPDATER ;4/13/1999
+1 ;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93
+2 ;
+3 ;
PAT ;
+1 ;
+2 ; This routine is used by lab to display updated lab arrival
+3 ; and collection time as well as the phlebotomist and the provider
+4 ; as well as the date time ordered.
+5 ;
+6 ;
+7 QUIT
ORD ;
+1 ;
+2 QUIT
+3 ;
SINGLE ;
+1 KILL LRAA,LRAN,LRAD,LRUID,LRACC6
+2 ; This block calls up the testing demographics.
+3 ;
+4 WRITE !!
+5 SET LRACC=""
KILL LRHN0
+6 DO ^LRHYU4
+7 IF $GET(LRORD)
DO ORD
+8 IF LRAN<1
DO END
QUIT
+9 IF $LENGTH(X)'=10
SET X=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+10 IF X
SET LRUID=X
+11 ;
+12 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
GOTO SINGLE
+13 ; KUNKE OPTION TY-IN
KUNKE ;
+1 SET LRUNC=1
+2 SET LRDAT=+$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
SET LRSN=+$PIECE(^(0),U,5)
+3 if '$GET(LRKUNKE)
DO LST1^LRHYLS1
+4 ;
+5 ;
+6 ; Adding urgency to the display
+7 SET LRTEST=0
+8 KILL LRURG2
+9 FOR
SET LRTEST=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST))
if +LRTEST'>0
QUIT
Begin DoDot:1
+10 WRITE !,$PIECE($GET(^LAB(60,LRTEST,0)),U)
+11 SET LRURG7=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
+12 IF LRURG7=1
SET LRURG=LRURG7
+13 IF LRURG7=2
SET LRURG2=2
End DoDot:1
+14 IF $GET(LRURG2)=2
Begin DoDot:1
+15 if $GET(LRURG)=1
QUIT
SET LRURG=2
End DoDot:1
+16 ;
+17 ;
+18 ; Blink urgency if MED-EMERGE
+19 SET LRURG=$GET(LRURG,LRURG7)
+20 WRITE !,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "
+21 ;
+22 ;
+23 DO EDIT
+24 ;
+25 ;
+26 IF $GET(LREND)
WRITE !,"Please start over..."
KILL LREND,LRIDTNEW
+27 DO END
+28 IF $GET(LRKUNKE)
GOTO SINGLE^LRHYT1
QUIT
+29 GOTO SINGLE
+30 ;
+31 QUIT
+32 ;
END ;
+1 KILL LRAA,LRAD,LRAN,LRBLOOD,LRARIVE,LRBLOOD,LRCE,LRDAT,LRDFN,LRIDT
+2 KILL LRDLA,LRDLC,LRDPF,LRDRAW,LRDT0,LRDTO,LRHYDUZ,LRHYNISH,LRPRAC
+3 KILL LRSN,LRTEST,LRURG,PNM,SSN,VAIN,VADM
+4 QUIT
+5 ;
EDIT ;
+1 if LRAA=-1
QUIT
+2 SET LRDFN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
+3 ; old LRIDT
SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
CHECK ;
+1 ; Check for results. Quit if results present
+2 ;
+3 ;
PAST ;
+1 KILL LRHYDUZ
+2 ; look at Micro And CH subscripted tests
+3 IF $DATA(^LR(LRDFN,"CH",LRIDT))
SET LRSS="CH"
+4 IF '$TEST
SET LRSS="MI"
+5 ;
+6 ; run review option here and show it there has been a previous
+7 ; updating of this accession
+8 IF $GET(LRKUNKE)'=1
IF $DATA(^XUSEC("LRLAB",DUZ))
DO EDIT^LRHYF2
+9 KILL LRARIVE
+10 ;
+11 ;
+12 WRITE !
+13 ; WE need an event to stop non-LRLAB key holders from entering
+14 ; LAB ARRIVAL TIME
BACK if '$DATA(^XUSEC("LRLAB",DUZ))
GOTO DRAW
+1 GOTO DRAW
+2 KILL %DT
+3 DO NOW^%DTC
+4 SET %DT="AERSZ"
+5 DO ^%DT
+6 IF Y=-1
SET LREND=1
QUIT
+7 IF $DATA(DTOUT)!($DATA(DUOUT))
SET LREND=1
QUIT
+8 DO NOW^%DTC
+9 IF Y>%
WRITE !!,"Can't accept future times!"
WRITE *7
GOTO BACK
+10 SET LRARIVE=Y
IF +LRARIVE'>0
SET LRARIVE=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)
+11 ;
SET ;
+1 SET $PIECE(^LRO(69,LRDAT,1,LRSN,3),U)=$GET(LRARIVE)
+2 ;
+3 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=$GET(LRARIVE)
+4 SET $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,10)=$GET(LRARIVE)
+5 IF $GET(LRARIVE)
SET ^LRO(68,LRAA,1,LRAD,1,"E",LRARIVE,LRAN)=""
+6 ;
+7 ;
DRAW ;
+1 QUIT
THERE ;
+1 WRITE !
+2 KILL %DT
+3 DO NOW^%DTC
+4 SET %DT="AESRZ"
+5 SET %DT("A")="Please enter updated DRAW/COLLECTION TIME: "
+6 ;
+7 ; Only default if lrlab owner
+8 IF +LRDRAW7>0
SET LRDRAW7=$$Y2K^LRX(LRDRAW7)
+9 IF '$TEST
SET LRDRAW7=$$Y2K^LRX($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U))
+10 IF $DATA(^XUSEC("LRLAB",DUZ))
SET %DT("B")=$PIECE(LRDRAW7,"@")_"@"_$EXTRACT($PIECE(LRDRAW7,"@",2),1,5)
+11 ;
+12 DO ^%DT
+13 IF X=""
GOTO DRAW
+14 IF $DATA(DTOUT)!($DATA(DUOUT))
SET LREND=1
QUIT
+15 IF Y=-1
SET LRUP="YES"
+16 IF '$TEST
SET LRUP="NO"
+17 SET LRDRAW=Y
IF +LRDRAW'>0
SET LRDRAW=LRDRAW7
+18 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=LRDRAW
+19 ;
+20 ;
+21 IF $DATA(^XUSEC("LRLAB",DUZ))
GOTO TIC
+22 ;
GUY ; COLLECTOR DEMOGRAPHICS stuff this into LR...99 COMMENT FIELD.
+1 SET LRHYNISH=$PIECE(^VA(200,DUZ,0),U,2)
+2 IF '$DATA(^XUSEC("LRLAB",DUZ))
SET LRPON=$PIECE($GET(^VA(200,DUZ,0)),U)
+3 WRITE !!!
+4 ;
+5 Begin DoDot:1
+6 DO SCRNON^LRHYUTL
+7 WRITE IOBON
+8 WRITE IORVON
+9 WRITE IODHLT,LRHYNISH
+10 WRITE !
+11 WRITE IODHLB,LRHYNISH
+12 WRITE !!
+13 WRITE IORVOFF
+14 WRITE IOBOFF
+15 DO SCRNOFF^LRHYUTL
End DoDot:1
+16 ;
+17 WRITE !!,"Your initials have been captured."
Begin DoDot:1
+18 SET DIR(0)="Y"
SET DIR("B")="YES"
+19 SET DIR("A")="Is this correct?"
+20 DO ^DIR
+21 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+22 ;
+23 IF Y
SET LRHYDUZ=LRPON
+24 if Y>0
QUIT
+25 SET DIC("A")="Enter collector here."
+26 SET DIC="^VA(200,"
+27 SET DIC(0)="AEMQZ"
+28 DO ^DIC
+29 IF +Y>0
SET LRHYDUZ=$PIECE(Y(0),U)
SET LRPON=$PIECE(^VA(200,DUZ,0),U)
End DoDot:1
+30 ;
+31 ; This global serves as an interim solution until lab files can
+32 ; be updated
TIC ;
+1 SET LRARIVE=$GET(LRARIVE,$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3))
