LRHYT1 ;VA/DALOI/HOAK - LAB PHLEB AND COLLECTION TIME UPDATER ; 13-Aug-2013 09:16 ; MKK
;;5.2;LAB SERVICE;**405,1033**;NOV 01, 1997
;
; 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.
;
; MODIFIED BY HOAK 6/30/2000 FOR RCEV OPTION
CONTROL ;
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
W @IOF
W !,$$CJ^XLFSTR("Barcode Specimen Processor",IOM)
;
;
K DIR,DIC,DIE,LRARIVE,LRDRAW
S LREND=0
D TECH
I U[X D END QUIT
Q:X="" D SINGLE
G CONTROL
QUIT
FINDER ;
S DIC="^VA(200,"
S DIC(0)="AEMQZ"
S DIC("A")="Please enter employee number: "
D ^DIC
QUIT
TECH ;
W !!,"Please swipe your ID badge: " D NINE^LRHYU
I U[X QUIT
I $L(X)'=9 G TECH
;
;
;
K DIC,LRHYTECH
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)=+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.
;
W !!
S LRACC=""
;
;
D ^LRHYU4 ; ask for accession ir uid
I LRAN<1 QUIT
D NOW^%DTC
S LRUID=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),U)
S LRCE=+^LRO(68,LRAA,1,LRAD,1,LRAN,.1)
S LRORDT1=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
S ^TMP("LRHYHOW1",$J,LRORDT1,LRUID)=U_LRHYTECH_U_%
S $P(^TMP("LRHYHOW1",$J,LRORDT1,LRUID),U,9)="RCEV"
I LRAN<1 QUIT
I $G(LRCE) D BUILD^LRHYT2
E K LRCENO S LRCENO=1 S LRCE=+^LRO(68,LRAA,1,LRAD,1,LRAN,.1) D BUILD^LRHYT2
I $G(LRCENO)=1 K LRCE
;
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." G SINGLE
; construct orders file entry
K LRKUNKE
S LR3ODT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
S LR3SN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)
;
S LRTEST=0
K DIR S DIR(0)="E" D ^DIR K DIR
;
S LRUNC=1
S LRDAT=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4),LRSN=+$P(^(0),U,5)
W @IOF
;
; 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
;
LEFTOVER ;
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 ;
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 ;
QUIT
LRHYT1 ;VA/DALOI/HOAK - LAB PHLEB AND COLLECTION TIME UPDATER ; 13-Aug-2013 09:16 ; MKK
+1 ;;5.2;LAB SERVICE;**405,1033**;NOV 01, 1997
+2 ;
+3 ; Reference to ^DIC supported by DBIA #916.
+4 ;
+5 ; This routine will be used to capture the phlebotomist and the
+6 ; specimen collection time.
+7 ;
+8 ; The barcoded specimen tubes will be waunded.
+9 ; The phlebotomist ID will then be waunded.
+10 ;
+11 ; MODIFIED BY HOAK 6/30/2000 FOR RCEV OPTION
CONTROL ;
+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 WRITE @IOF
+5 WRITE !,$$CJ^XLFSTR("Barcode Specimen Processor",IOM)
+6 ;
+7 ;
+8 KILL DIR,DIC,DIE,LRARIVE,LRDRAW
+9 SET LREND=0
+10 DO TECH
+11 IF U[X
DO END
QUIT
+12 IF X=""
QUIT
DO SINGLE
+13 GOTO CONTROL
+14 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 WRITE !!,"Please swipe your ID badge: "
DO NINE^LRHYU
+2 IF U[X
QUIT
+3 IF $LENGTH(X)'=9
GOTO TECH
+4 ;
+5 ;
+6 ;
+7 KILL DIC,LRHYTECH
+8 KILL Y
+9 SET DIC=200
+10 SET DIC(0)="MQZ"
+11 DO ^DIC
+12 WRITE Y
+13 ;
+14 IF U[X
QUIT
+15 IF Y<0
GOTO CONTROL
+16 SET (LRHYDUZ,LRHYTECH)=+Y
+17 SET LRHYDUZ=$PIECE($GET(^VA(200,LRHYDUZ,0)),U)
+18 QUIT
+19 ;
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 ;
+3 WRITE !!
+4 SET LRACC=""
+5 ;
+6 ;
+7 ; ask for accession ir uid
DO ^LRHYU4
+8 IF LRAN<1
QUIT
+9 DO NOW^%DTC
+10 SET LRUID=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),U)
+11 SET LRCE=+^LRO(68,LRAA,1,LRAD,1,LRAN,.1)
+12 SET LRORDT1=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
+13 SET ^TMP("LRHYHOW1",$JOB,LRORDT1,LRUID)=U_LRHYTECH_U_%
+14 SET $PIECE(^TMP("LRHYHOW1",$JOB,LRORDT1,LRUID),U,9)="RCEV"
+15 IF LRAN<1
QUIT
+16 IF $GET(LRCE)
DO BUILD^LRHYT2
+17 IF '$TEST
KILL LRCENO
SET LRCENO=1
SET LRCE=+^LRO(68,LRAA,1,LRAD,1,LRAN,.1)
DO BUILD^LRHYT2
+18 IF $GET(LRCENO)=1
KILL LRCE
+19 ;
+20 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
WRITE !,"Doesn't exist."
GOTO SINGLE
+21 ; construct orders file entry
+22 KILL LRKUNKE
+23 SET LR3ODT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
+24 SET LR3SN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)
+25 ;
+26 SET LRTEST=0
+27 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+28 ;
+29 SET LRUNC=1
+30 SET LRDAT=+$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
SET LRSN=+$PIECE(^(0),U,5)
+31 WRITE @IOF
+32 ;
+33 ; Adding urgency to the display
+34 SET LRTEST=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
+35 SET LRURG=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
+36 ;
+37 ; Blink urgency if MED-EMERGE
+38 WRITE !,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "
+39 ;
+40 DO EDIT
+41 ;
+42 ;
+43 IF $GET(LREND)
WRITE !,"Please start over..."
KILL LREND,LRIDTNEW
+44 DO END
+45 ;
+46 QUIT
+47 ;
LEFTOVER ;
+1 QUIT
+2 ;
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 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 QUIT
