- LRHYPL ;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.
- ;
- 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
- ;
- LRHYPL ;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 ;
- +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 ;
