LRHYPL ;DALOI/HOAK - LAB PHLEB AND COLLECTION TIME UPDATER ;4/13/1999
;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93
;
; Reference to ^DIC supported by DBIA #916
;
;
; 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 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
S LRCNTX=0
I U[X D END QUIT
Q:X="" D SINGLE
K LRPL
G CONTROL
QUIT
FINDER ; Get the phlebotomist
S DIC="^VA(200,"
S DIC(0)="AEMQZ"
S DIC("A")="Please enter employee number: "
D ^DIC
QUIT
TECH ; Get the phlebotomist
K DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
K DIR,DIC,DIE,LRARIVE,LRDRAW
W @IOF
;
X ^%ZOSF("EOFF")
D NINE^LRHYU
X ^%ZOSF("EON")
I U[X QUIT
I $L(X)'=9 K DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECV G TECH
;
;
;
K DIC,LRHYTECH,LRHYDUZ
K Y
S DIC=200
S DIC(0)="MQZ"
D ^DIC
W Y
;
I U[X QUIT
I Y<0 G CONTROL
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 ;
S LRCNTX=LRCNTX+1
; This block calls up the testing demographics.
; LRHYD123 IS LRUID
W !!,"RECORDING UID: ",LRCNTX
S LRACC=""
;
;
K LRHYD123
;
K LRHN0,LRHNODE,LRN0,LR0NODE,LRPHLEB
D ^LRHYU4
I LRAN<1 QUIT
;
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))
; mdofied by Hoak per Joe for prior to free t-4
D NOW^%DTC
S LRDRAW=%
S LRSN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)
I '$G(LRDAT) S LRDAT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
;
;
S $P(^TMP("LRHYHOW1",$J,LRHYD123),U,3)=%
S $P(^TMP("LRHYHOW1",$J,LRHYD123),U,11)=LRHYTECH
S $P(^TMP("LRHYHOW1",$J,LRHYD123),U,12)=%
S $P(^TMP("LRHYHOW1",$J,LRHYD123),U,13)=$G(LRHYTECH)
S $P(^TMP("LRHYHOW1",$J,LRHYD123),U,14)=$G(%)
S $P(^TMP("LRHYHOW1",$J,LRHYD123),U,9)="PL"
;
I '^TMP("LRHYHOW1",$J,LRHYD123) S ^(LRHYD123)=$G(LRDRAW)
; USE NEW SPECIMEN DEMOGRAPHICS FILE #69.87
D SETFILE^LRHYBC1
H 2
K LRAN,LRHYD123,LRAN,LRAA,LRADT,LRDRAW
G SINGLE
QUIT
END ;
K %,LRDAT,LRAN,LRAD,LRAA,LRDFN,LRDRAW,LRHYTECH,LRHYDUZ
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRHYPL 2536 printed Sep 23, 2025@19:51:05 Page 2
LRHYPL ;DALOI/HOAK - LAB PHLEB AND COLLECTION TIME UPDATER ;4/13/1999
+1 ;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93
+2 ;
+3 ; Reference to ^DIC supported by DBIA #916
+4 ;
+5 ;
+6 ; This routine will be used to capture the phlebotomist and the
+7 ; specimen collection time.
+8 ;
+9 ; The barcoded specimen tubes will be waunded.
+10 ; The phlebotomist ID will then be waunded.
+11 ;
CONTROL ;
+1 KILL DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
+2 KILL DIR,DIC,DIE,LRARIVE,LRDRAW
+3 KILL DIC,LRHYTECH,LRHYDUZ,LRPHLEB
+4 KILL DIR,DIC,DIE,LRARIVE,LRDRAW
+5 SET LRPL=1
+6 SET LREND=0
+7 DO TECH
+8 SET LRCNTX=0
+9 IF U[X
DO END
QUIT
+10 if X=""
QUIT
DO SINGLE
+11 KILL LRPL
+12 GOTO CONTROL
+13 QUIT
FINDER ; Get the phlebotomist
+1 SET DIC="^VA(200,"
+2 SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Please enter employee number: "
+4 DO ^DIC
+5 QUIT
TECH ; Get the phlebotomist
+1 KILL DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
+2 KILL DIR,DIC,DIE,LRARIVE,LRDRAW
+3 WRITE @IOF
+4 ;
+5 XECUTE ^%ZOSF("EOFF")
+6 DO NINE^LRHYU
+7 XECUTE ^%ZOSF("EON")
+8 IF U[X
QUIT
+9 IF $LENGTH(X)'=9
KILL DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECV
GOTO TECH
+10 ;
+11 ;
+12 ;
+13 KILL DIC,LRHYTECH,LRHYDUZ
+14 KILL Y
+15 SET DIC=200
+16 SET DIC(0)="MQZ"
+17 DO ^DIC
+18 WRITE Y
+19 ;
+20 IF U[X
QUIT
+21 IF Y<0
GOTO CONTROL
+22 SET (LRHYDUZ,LRHYTECH,LRPHLEB,LRRECVR)=+Y
+23 SET LRHYDUZ=$PIECE($GET(^VA(200,LRHYDUZ,0)),U)
+24 QUIT
+25 ;
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 SET LRCNTX=LRCNTX+1
+2 ; This block calls up the testing demographics.
+3 ; LRHYD123 IS LRUID
+4 WRITE !!,"RECORDING UID: ",LRCNTX
+5 SET LRACC=""
+6 ;
+7 ;
+8 KILL LRHYD123
+9 ;
+10 KILL LRHN0,LRHNODE,LRN0,LR0NODE,LRPHLEB
+11 DO ^LRHYU4
+12 IF LRAN<1
QUIT
+13 ;
+14 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
GOTO SINGLE
+15 SET LRUNC=1
+16 SET LRORDT1=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
+17 SET LRHYD123=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+18 ; mdofied by Hoak per Joe for prior to free t-4
+19 DO NOW^%DTC
+20 SET LRDRAW=%
+21 SET LRSN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)
+22 IF '$GET(LRDAT)
SET LRDAT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
+23 ;
+24 ;
+25 SET $PIECE(^TMP("LRHYHOW1",$JOB,LRHYD123),U,3)=%
+26 SET $PIECE(^TMP("LRHYHOW1",$JOB,LRHYD123),U,11)=LRHYTECH
+27 SET $PIECE(^TMP("LRHYHOW1",$JOB,LRHYD123),U,12)=%
+28 SET $PIECE(^TMP("LRHYHOW1",$JOB,LRHYD123),U,13)=$GET(LRHYTECH)
+29 SET $PIECE(^TMP("LRHYHOW1",$JOB,LRHYD123),U,14)=$GET(%)
+30 SET $PIECE(^TMP("LRHYHOW1",$JOB,LRHYD123),U,9)="PL"
+31 ;
+32 IF '^TMP("LRHYHOW1",$JOB,LRHYD123)
SET ^(LRHYD123)=$GET(LRDRAW)
+33 ; USE NEW SPECIMEN DEMOGRAPHICS FILE #69.87
+34 DO SETFILE^LRHYBC1
+35 HANG 2
+36 KILL LRAN,LRHYD123,LRAN,LRAA,LRADT,LRDRAW
+37 GOTO SINGLE
+38 QUIT
END ;
+1 KILL %,LRDAT,LRAN,LRAD,LRAA,LRDFN,LRDRAW,LRHYTECH,LRHYDUZ
+2 ;
