LRHYBC1 ;DALOI/HOAK - LAB PHLEB AND COLLECTION TIME UPDATER ;11/8/10 1:50pm
;;5.2;LAB SERVICE;**405,417,430,446**;Sep 27, 1994;Build 1
;
; This routine will be used to capture the phlebotomist and the
; specimen collection time.
;
; The barcoded specimen tubes will be waunded.
; The phlebotomist ID will then be waunded.
;
CONTROL ;
K LRPTARIV
K ^TMP("LRHY ASH",$J)
K LRSCAN
K DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
K DIR,DIC,DIE,LRARIVE,LRDRAW
K DIC,LRHYTECH,LRHYDUZ,LRPHLEB
K DIR,DIC,DIE,LRARIVE,LRDRAW
S LRPL=1
S LREND=0
D TECH
I U[X D END QUIT
Q:X="" D SINGLE
D PTSCAN
Q:X[U
K LRPL
K LRPTARIV
QUIT
FINDER ;
S DIC="^VA(200,"
S DIC(0)="AEMQZ"
S DIC("A")="Please enter employee number: "
D ^DIC
QUIT
TECH ;
K DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
K DIR,DIC,DIE,LRARIVE,LRDRAW
;
S X=""
;
I X="" S X=DUZ G PST
I U[X QUIT
I $L(X)'=9 K DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECV G TECH
;
;
;
;
K DIC
K DIC,LRHYTECH,LRHYDUZ
K Y
S DIC=200
S DIC(0)="MQZ"
D ^DIC
;
W Y
;
I X[U QUIT
PST S Y=DUZ
S (LRHYDUZ,LRHYTECH,LRPHLEB,LRRECVR)=+Y
S LRHYDUZ=$P($G(^VA(200,LRHYDUZ,0)),U)
QUIT
;
TIME ;
;
;
;
S LREND=0
S DIC="^DPT("
S DIC(0)="AEMQZ"
D ^DIC
S DFN=+Y
S LRDFN=$G(^DPT(DFN,"LR"))
D ^VADPT,INP^VADPT
;
QUIT
;
SINGLE ;
; This block calls up the testing demographics.
; LRHYD123 IS LRUID
W !!
S LRACC=""
I $G(LRHYD123)'="" D EN^LA7ADL(LRHYD123)
;
K LRHYD123
;
K LRHN0,LRHNODE,LRN0,LR0NODE,LRPHLEB
S X="D"
D ^LRHYU5
I LRAN<1 QUIT
SETFILE ;
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." G SINGLE
S LRUNC=1
S LRORDT1=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
S LRHYD123=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
I $G(LRHYD123)>0,$D(^LRHY(69.87,"B",LRHYD123)) D Q
. W !,"Sorry, Collection Time already recorded!!.",! H 2
. I $G(LRCNTX) S LRCNTX=LRCNTX-1
; modified by Hoak per Joe for prior to free t-4
I '$O(^LRHY(69.87,"B",LRHYD123,0)) D
. S DA=$P(^LRHY(69.87,0),U,3)
. S DA=DA+1
. S X=LRHYD123
. S DIE="^LRHY(69.87,"
. S DR=".01///"_X
. S DIK=DIE
. D ^DIE
I '$G(DA) S DA=$P(^LRHY(69.87,0),U,3)+1
S LRUID=LRHYD123
S $P(^LRHY(69.87,0),U,3)=DA,$P(^LRHY(69.87,0),U,4)=DA
S LRSPIEN=$O(^LRHY(69.87,"B",LRUID,0)) I $G(LRSPIEN) D
. N LRDT,LRSCAN
. S LRDT=$$NOW^XLFDT
. I '$G(LRLABTIM) S LRLABTIM=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
. S LRSCAN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
. K DIE S DIE="^LRHY(69.87," S DR="2///"_LRSCAN S DA=LRSPIEN D ^DIE
. K DIE S DIE="^LRHY(69.87," S DR="4///"_LRDT S DA=LRSPIEN D ^DIE
. K DIE S DIE="^LRHY(69.87," S DR="6////"_LRHYTECH S DA=LRSPIEN D ^DIE
. K DIE S DIE="^LRHY(69.87," S DR="8///"_LRDT S DA=LRSPIEN D ^DIE
S DIK=DIE D IX1^DIK
ZZ1 ;
QUIT:$G(XQY0)'["PPOC"
H 3
S ^TMP("LRHY ASH",$J,LRAA,LRAD,LRAN)=""
G SINGLE
G END
; Adding urgency to the display
S LRTEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
S LRURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
;
; Blink urgency if MED-EMERGE
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
QUIT
;
END ;
K ^TMP("LRHY ASH",$J)
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,LRHYTECH
QUIT
;
EDIT ;
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 ;
;
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
;
K LRARIVE
;
;
W !
; WE need an event to stop non-LRLAB key holders from entering
; LAB ARRIVAL TIME
BACK G:'$D(^XUSEC("LRLAB",DUZ)) THERE
G THERE
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)
;
I X="" G THERE
I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
I Y=-1 S LRUP="YES"
E S LRUP="NO"
D NOW^%DTC S LRDRAW=%
;
;
I $D(^XUSEC("LRLAB",DUZ)) G TIC
;
GUY ; COLLECTOR DEMOGRAPHICS stuff this into LR...99 COMMENT FIELD.
K LRPON
S LRHYNISH=$P(^VA(200,LRHYTECH,0),U,2)
I '$D(^XUSEC("LRLAB",LRHYTECH)) S LRPON=$P($G(^VA(200,LRHYTECH,0)),U)
W !!!
;
; 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))
S LRPTARIV=$G(LRPTARIV,LRARIVE)
;
S LRAAX5=LRAA,LRADX6=LRAD,LRANX6=LRAN
S LRHYDUZ=LRHYTECH
SET ;
S $P(^LRO(69,LRDAT,1,LRSN,3),U)=$G(LRDRAW)
S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=$G(LRDRAW)
S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=$G(LRDRAW)
;
H 2
G SINGLE
QUIT
PTSCAN ;
;
W !!,"Please swipe PATIENT ID CARD or Type SSN: "
R X:9999999 W !
Q:X[U
Q:X=""
I $L(X)'=9 W !,"NO SUCH PATIENT" QUIT
S DFN=$O(^DPT("SSN",X,0))
S PNM=$P(^DPT(DFN,0),U) W !,PNM
S LRDFN=$G(^DPT(DFN,"LR"))
ACCNX ;
S LRAA=0
F S LRAA=$O(^TMP("LRHY ASH",$J,LRAA)) Q:+LRAA'>0 D
. S LRAD=0
. F S LRAD=$O(^TMP("LRHY ASH",$J,LRAA,LRAD)) Q:+LRAD'>0 D
.. S LRAN=0
.. F S LRAN=$O(^TMP("LRHY ASH",$J,LRAA,LRAD,LRAN)) Q:+LRAN'>0 D P2
QUIT
P2 ;
N LRX S LRX=0
F S LRX=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRX)) Q:+LRX'>0 D
. I LRDFN'=+^LRO(68,LRAA,1,LRAD,1,LRAN,0) W !,"WRONG PATIENT" QUIT
. W !,^LRO(68,LRAA,1,LRAD,1,LRAN,.2),?20,$P(^LAB(60,LRX,0),U)
. W !,"EVERYTHING MATCHES UP ",$P($P(^VA(200,LRHYTECH,0),U),",",2),", GREAT JOB!"
. H 3
QUIT
LABIN ;
D ^LRHYU4
;
Q:LRAN=-1
;
I $L(X)'=10 S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
S LRUID=X
S DA=$O(^LRHY(69.87,"B",LRUID,0))
I '$G(DA) W !,"Incorrect UID try again..." H 2 G LABIN
I $D(^LRHY(69.87,DA,10)) W !,"Sorry, Lab Arrival Time already recorded!!",! H 2 G LABIN
D NOW^%DTC K LRLABIN S LRLABIN=%
K DIE
S DIE=69.87
S DR="10///"_LRLABIN_";12///"_DUZ
D ^DIE
G LABIN
DISPLAY ;
S X="D"
D ^LRHYU5 I 'LRAN W !,"MUST ENTER UID, TRY AGAIN" H 2 QUIT
S LRUID=X
S ZTRTN="D1^LRHYBC1" D IO^LRWU
QUIT
D1 ;
I $L(LRUID)'=10 S LRUID=X
S LRDA=$O(^LRHY(69.87,"B",LRUID,0))
;
; FIX FOR NOT RUN PL
I +$G(LRDA)'>0 W !,"NO Entry in HOWDY SPECIMEN TIMES BY UID File. Run Phlebotomy log." H 1 QUIT
I '$G(^LRHY(69.87,LRDA,2)) D
. K DA,DR S DIE="^LRHY(69.87,",DA=LRDA,DR="2///"_$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U) D ^DIE
W !,"UID: ",LRUID
W !,"WALK-UP SCAN TIME:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,2))
W !,"COLLECTOR:",?50,?50,$P(^VA(200,^LRHY(69.87,LRDA,6),0),U)
W !,"TIME SPECIMEN COLLECTED:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,8))
Q:'$D(^LRHY(69.87,LRDA,10))
W !,"TIME SCANNED INTO LAB:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,10))
I $G(^LRHY(69.87,LRDA,12)) W !,"RECEIVED INTO LAB BY: ",?50,$P(^VA(200,^LRHY(69.87,LRDA,12),0),U)
QUIT
BINBRD ;
S ZTRTN="D2^LRHYBC1",ZTSAVE("PNM")=""
S LRBBRD=$O(^LRHY(69.86,7,54,"B",0)) I $G(LRBBRD) S ZTIO=LRBBRD,ZTDTH=$H S:$D(ZTQUEUED) ZTREQ="@" D ^%ZTLOAD
QUIT
D2 ;
U IO
W !,"PT:",PNM
D ^%ZISC
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRHYBC1 7400 printed Sep 23, 2025@19:50:52 Page 2
LRHYBC1 ;DALOI/HOAK - LAB PHLEB AND COLLECTION TIME UPDATER ;11/8/10 1:50pm
+1 ;;5.2;LAB SERVICE;**405,417,430,446**;Sep 27, 1994;Build 1
+2 ;
+3 ; This routine will be used to capture the phlebotomist and the
+4 ; specimen collection time.
+5 ;
+6 ; The barcoded specimen tubes will be waunded.
+7 ; The phlebotomist ID will then be waunded.
+8 ;
CONTROL ;
+1 KILL LRPTARIV
+2 KILL ^TMP("LRHY ASH",$JOB)
+3 KILL LRSCAN
+4 KILL DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
+5 KILL DIR,DIC,DIE,LRARIVE,LRDRAW
+6 KILL DIC,LRHYTECH,LRHYDUZ,LRPHLEB
+7 KILL DIR,DIC,DIE,LRARIVE,LRDRAW
+8 SET LRPL=1
+9 SET LREND=0
+10 DO TECH
+11 IF U[X
DO END
QUIT
+12 if X=""
QUIT
DO SINGLE
+13 DO PTSCAN
+14 if X[U
QUIT
+15 KILL LRPL
+16 KILL LRPTARIV
+17 QUIT
FINDER ;
+1 SET DIC="^VA(200,"
+2 SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Please enter employee number: "
+4 DO ^DIC
+5 QUIT
TECH ;
+1 KILL DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
+2 KILL DIR,DIC,DIE,LRARIVE,LRDRAW
+3 ;
+4 SET X=""
+5 ;
+6 IF X=""
SET X=DUZ
GOTO PST
+7 IF U[X
QUIT
+8 IF $LENGTH(X)'=9
KILL DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECV
GOTO TECH
+9 ;
+10 ;
+11 ;
+12 ;
+13 KILL DIC
+14 KILL DIC,LRHYTECH,LRHYDUZ
+15 KILL Y
+16 SET DIC=200
+17 SET DIC(0)="MQZ"
+18 DO ^DIC
+19 ;
+20 WRITE Y
+21 ;
+22 IF X[U
QUIT
PST SET Y=DUZ
+1 SET (LRHYDUZ,LRHYTECH,LRPHLEB,LRRECVR)=+Y
+2 SET LRHYDUZ=$PIECE($GET(^VA(200,LRHYDUZ,0)),U)
+3 QUIT
+4 ;
TIME ;
+1 ;
+2 ;
+3 ;
+4 SET LREND=0
+5 SET DIC="^DPT("
+6 SET DIC(0)="AEMQZ"
+7 DO ^DIC
+8 SET DFN=+Y
+9 SET LRDFN=$GET(^DPT(DFN,"LR"))
+10 DO ^VADPT
DO INP^VADPT
+11 ;
+12 QUIT
+13 ;
SINGLE ;
+1 ; This block calls up the testing demographics.
+2 ; LRHYD123 IS LRUID
+3 WRITE !!
+4 SET LRACC=""
+5 IF $GET(LRHYD123)'=""
DO EN^LA7ADL(LRHYD123)
+6 ;
+7 KILL LRHYD123
+8 ;
+9 KILL LRHN0,LRHNODE,LRN0,LR0NODE,LRPHLEB
+10 SET X="D"
+11 DO ^LRHYU5
+12 IF LRAN<1
QUIT
SETFILE ;
+1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
GOTO SINGLE
+2 SET LRUNC=1
+3 SET LRORDT1=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
+4 SET LRHYD123=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+5 IF $GET(LRHYD123)>0
IF $DATA(^LRHY(69.87,"B",LRHYD123))
Begin DoDot:1
+6 WRITE !,"Sorry, Collection Time already recorded!!.",!
HANG 2
+7 IF $GET(LRCNTX)
SET LRCNTX=LRCNTX-1
End DoDot:1
QUIT
+8 ; modified by Hoak per Joe for prior to free t-4
+9 IF '$ORDER(^LRHY(69.87,"B",LRHYD123,0))
Begin DoDot:1
+10 SET DA=$PIECE(^LRHY(69.87,0),U,3)
+11 SET DA=DA+1
+12 SET X=LRHYD123
+13 SET DIE="^LRHY(69.87,"
+14 SET DR=".01///"_X
+15 SET DIK=DIE
+16 DO ^DIE
End DoDot:1
+17 IF '$GET(DA)
SET DA=$PIECE(^LRHY(69.87,0),U,3)+1
+18 SET LRUID=LRHYD123
+19 SET $PIECE(^LRHY(69.87,0),U,3)=DA
SET $PIECE(^LRHY(69.87,0),U,4)=DA
+20 SET LRSPIEN=$ORDER(^LRHY(69.87,"B",LRUID,0))
IF $GET(LRSPIEN)
Begin DoDot:1
+21 NEW LRDT,LRSCAN
+22 SET LRDT=$$NOW^XLFDT
+23 IF '$GET(LRLABTIM)
SET LRLABTIM=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+24 SET LRSCAN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+25 KILL DIE
SET DIE="^LRHY(69.87,"
SET DR="2///"_LRSCAN
SET DA=LRSPIEN
DO ^DIE
+26 KILL DIE
SET DIE="^LRHY(69.87,"
SET DR="4///"_LRDT
SET DA=LRSPIEN
DO ^DIE
+27 KILL DIE
SET DIE="^LRHY(69.87,"
SET DR="6////"_LRHYTECH
SET DA=LRSPIEN
DO ^DIE
+28 KILL DIE
SET DIE="^LRHY(69.87,"
SET DR="8///"_LRDT
SET DA=LRSPIEN
DO ^DIE
End DoDot:1
+29 SET DIK=DIE
DO IX1^DIK
ZZ1 ;
+1 if $GET(XQY0)'["PPOC"
QUIT
+2 HANG 3
+3 SET ^TMP("LRHY ASH",$JOB,LRAA,LRAD,LRAN)=""
+4 GOTO SINGLE
+5 GOTO END
+6 ; Adding urgency to the display
+7 SET LRTEST=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
+8 SET LRURG=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
+9 ;
+10 ; Blink urgency if MED-EMERGE
+11 WRITE !,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "
+12 ;
+13 ;
+14 DO EDIT
+15 ;
+16 ;
+17 IF $GET(LREND)
WRITE !,"Please start over..."
KILL LREND,LRIDTNEW
+18 DO END
+19 QUIT
+20 ;
END ;
+1 KILL ^TMP("LRHY ASH",$JOB)
+2 KILL LRAA,LRAD,LRAN,LRBLOOD,LRARIVE,LRBLOOD,LRCE,LRDAT,LRDFN,LRIDT
+3 KILL LRDLA,LRDLC,LRDPF,LRDRAW,LRDT0,LRDTO,LRHYDUZ,LRHYNISH,LRPRAC
+4 KILL LRSN,LRTEST,LRURG,PNM,SSN,VAIN,VADM,LRHYTECH
+5 QUIT
+6 ;
EDIT ;
+1 SET LRDFN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
+2 ; old LRIDT
SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
CHECK ;
+1 ;
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 ;
+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 THERE
+1 GOTO THERE
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 IF X=""
GOTO THERE
+13 IF $DATA(DTOUT)!($DATA(DUOUT))
SET LREND=1
QUIT
+14 IF Y=-1
SET LRUP="YES"
+15 IF '$TEST
SET LRUP="NO"
+16 DO NOW^%DTC
SET LRDRAW=%
+17 ;
+18 ;
+19 IF $DATA(^XUSEC("LRLAB",DUZ))
GOTO TIC
+20 ;
GUY ; COLLECTOR DEMOGRAPHICS stuff this into LR...99 COMMENT FIELD.
+1 KILL LRPON
+2 SET LRHYNISH=$PIECE(^VA(200,LRHYTECH,0),U,2)
+3 IF '$DATA(^XUSEC("LRLAB",LRHYTECH))
SET LRPON=$PIECE($GET(^VA(200,LRHYTECH,0)),U)
+4 WRITE !!!
+5 ;
+6 ; This global serves as an interim solution until lab files can
+7 ; be updated
TIC ;
+1 SET LRARIVE=$GET(LRARIVE,$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3))
+2 SET LRPTARIV=$GET(LRPTARIV,LRARIVE)
+3 ;
+4 SET LRAAX5=LRAA
SET LRADX6=LRAD
SET LRANX6=LRAN
+5 SET LRHYDUZ=LRHYTECH
SET ;
+1 SET $PIECE(^LRO(69,LRDAT,1,LRSN,3),U)=$GET(LRDRAW)
+2 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=$GET(LRDRAW)
+3 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=$GET(LRDRAW)
+4 ;
+5 HANG 2
+6 GOTO SINGLE
+7 QUIT
PTSCAN ;
+1 ;
+2 WRITE !!,"Please swipe PATIENT ID CARD or Type SSN: "
+3 READ X:9999999
WRITE !
+4 if X[U
QUIT
+5 if X=""
QUIT
+6 IF $LENGTH(X)'=9
WRITE !,"NO SUCH PATIENT"
QUIT
+7 SET DFN=$ORDER(^DPT("SSN",X,0))
+8 SET PNM=$PIECE(^DPT(DFN,0),U)
WRITE !,PNM
+9 SET LRDFN=$GET(^DPT(DFN,"LR"))
ACCNX ;
+1 SET LRAA=0
+2 FOR
SET LRAA=$ORDER(^TMP("LRHY ASH",$JOB,LRAA))
if +LRAA'>0
QUIT
Begin DoDot:1
+3 SET LRAD=0
+4 FOR
SET LRAD=$ORDER(^TMP("LRHY ASH",$JOB,LRAA,LRAD))
if +LRAD'>0
QUIT
Begin DoDot:2
+5 SET LRAN=0
+6 FOR
SET LRAN=$ORDER(^TMP("LRHY ASH",$JOB,LRAA,LRAD,LRAN))
if +LRAN'>0
QUIT
DO P2
End DoDot:2
End DoDot:1
+7 QUIT
P2 ;
+1 NEW LRX
SET LRX=0
+2 FOR
SET LRX=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRX))
if +LRX'>0
QUIT
Begin DoDot:1
+3 IF LRDFN'=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
WRITE !,"WRONG PATIENT"
QUIT
+4 WRITE !,^LRO(68,LRAA,1,LRAD,1,LRAN,.2),?20,$PIECE(^LAB(60,LRX,0),U)
+5 WRITE !,"EVERYTHING MATCHES UP ",$PIECE($PIECE(^VA(200,LRHYTECH,0),U),",",2),", GREAT JOB!"
+6 HANG 3
End DoDot:1
+7 QUIT
LABIN ;
+1 DO ^LRHYU4
+2 ;
+3 if LRAN=-1
QUIT
+4 ;
+5 IF $LENGTH(X)'=10
SET X=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+6 SET LRUID=X
+7 SET DA=$ORDER(^LRHY(69.87,"B",LRUID,0))
+8 IF '$GET(DA)
WRITE !,"Incorrect UID try again..."
HANG 2
GOTO LABIN
+9 IF $DATA(^LRHY(69.87,DA,10))
WRITE !,"Sorry, Lab Arrival Time already recorded!!",!
HANG 2
GOTO LABIN
+10 DO NOW^%DTC
KILL LRLABIN
SET LRLABIN=%
+11 KILL DIE
+12 SET DIE=69.87
+13 SET DR="10///"_LRLABIN_";12///"_DUZ
+14 DO ^DIE
+15 GOTO LABIN
DISPLAY ;
+1 SET X="D"
+2 DO ^LRHYU5
IF 'LRAN
WRITE !,"MUST ENTER UID, TRY AGAIN"
HANG 2
QUIT
+3 SET LRUID=X
+4 SET ZTRTN="D1^LRHYBC1"
DO IO^LRWU
+5 QUIT
D1 ;
+1 IF $LENGTH(LRUID)'=10
SET LRUID=X
+2 SET LRDA=$ORDER(^LRHY(69.87,"B",LRUID,0))
+3 ;
+4 ; FIX FOR NOT RUN PL
+5 IF +$GET(LRDA)'>0
WRITE !,"NO Entry in HOWDY SPECIMEN TIMES BY UID File. Run Phlebotomy log."
HANG 1
QUIT
+6 IF '$GET(^LRHY(69.87,LRDA,2))
Begin DoDot:1
+7 KILL DA,DR
SET DIE="^LRHY(69.87,"
SET DA=LRDA
SET DR="2///"_$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)
DO ^DIE
End DoDot:1
+8 WRITE !,"UID: ",LRUID
+9 WRITE !,"WALK-UP SCAN TIME:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,2))
+10 WRITE !,"COLLECTOR:",?50,?50,$PIECE(^VA(200,^LRHY(69.87,LRDA,6),0),U)
+11 WRITE !,"TIME SPECIMEN COLLECTED:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,8))
+12 if '$DATA(^LRHY(69.87,LRDA,10))
QUIT
+13 WRITE !,"TIME SCANNED INTO LAB:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,10))
+14 IF $GET(^LRHY(69.87,LRDA,12))
WRITE !,"RECEIVED INTO LAB BY: ",?50,$PIECE(^VA(200,^LRHY(69.87,LRDA,12),0),U)
+15 QUIT
BINBRD ;
+1 SET ZTRTN="D2^LRHYBC1"
SET ZTSAVE("PNM")=""
+2 SET LRBBRD=$ORDER(^LRHY(69.86,7,54,"B",0))
IF $GET(LRBBRD)
SET ZTIO=LRBBRD
SET ZTDTH=$HOROLOG
if $DATA(ZTQUEUED)
SET ZTREQ="@"
DO ^%ZTLOAD
+3 QUIT
D2 ;
+1 USE IO
+2 WRITE !,"PT:",PNM
+3 DO ^%ZISC
+4 QUIT
