Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRHYBC1

LRHYBC1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; This routine will be used to capture the phlebotomist and the
  1. ; specimen collection time.
  1. ;
  1. ; The barcoded specimen tubes will be waunded.
  1. ; The phlebotomist ID will then be waunded.
  1. ;
  1. CONTROL ;
  1. K LRPTARIV
  1. K ^TMP("LRHY ASH",$J)
  1. K LRSCAN
  1. K DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
  1. K DIR,DIC,DIE,LRARIVE,LRDRAW
  1. K DIC,LRHYTECH,LRHYDUZ,LRPHLEB
  1. K DIR,DIC,DIE,LRARIVE,LRDRAW
  1. S LRPL=1
  1. S LREND=0
  1. D TECH
  1. I U[X D END QUIT
  1. Q:X="" D SINGLE
  1. D PTSCAN
  1. Q:X[U
  1. K LRPL
  1. K LRPTARIV
  1. QUIT
  1. FINDER ;
  1. S DIC="^VA(200,"
  1. S DIC(0)="AEMQZ"
  1. S DIC("A")="Please enter employee number: "
  1. D ^DIC
  1. QUIT
  1. TECH ;
  1. K DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECVR
  1. K DIR,DIC,DIE,LRARIVE,LRDRAW
  1. ;
  1. S X=""
  1. ;
  1. I X="" S X=DUZ G PST
  1. I U[X QUIT
  1. I $L(X)'=9 K DIC,LRHYTECH,LRHYDUZ,LRPHLEB,LRRECV G TECH
  1. ;
  1. ;
  1. ;
  1. ;
  1. K DIC
  1. K DIC,LRHYTECH,LRHYDUZ
  1. K Y
  1. S DIC=200
  1. S DIC(0)="MQZ"
  1. D ^DIC
  1. ;
  1. W Y
  1. ;
  1. I X[U QUIT
  1. PST S Y=DUZ
  1. S (LRHYDUZ,LRHYTECH,LRPHLEB,LRRECVR)=+Y
  1. S LRHYDUZ=$P($G(^VA(200,LRHYDUZ,0)),U)
  1. QUIT
  1. ;
  1. TIME ;
  1. ;
  1. ;
  1. ;
  1. S LREND=0
  1. S DIC="^DPT("
  1. S DIC(0)="AEMQZ"
  1. D ^DIC
  1. S DFN=+Y
  1. S LRDFN=$G(^DPT(DFN,"LR"))
  1. D ^VADPT,INP^VADPT
  1. ;
  1. QUIT
  1. ;
  1. SINGLE ;
  1. ; This block calls up the testing demographics.
  1. ; LRHYD123 IS LRUID
  1. W !!
  1. S LRACC=""
  1. I $G(LRHYD123)'="" D EN^LA7ADL(LRHYD123)
  1. ;
  1. K LRHYD123
  1. ;
  1. K LRHN0,LRHNODE,LRN0,LR0NODE,LRPHLEB
  1. S X="D"
  1. D ^LRHYU5
  1. I LRAN<1 QUIT
  1. SETFILE ;
  1. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." G SINGLE
  1. S LRUNC=1
  1. S LRORDT1=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
  1. S LRHYD123=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1. I $G(LRHYD123)>0,$D(^LRHY(69.87,"B",LRHYD123)) D Q
  1. . W !,"Sorry, Collection Time already recorded!!.",! H 2
  1. . I $G(LRCNTX) S LRCNTX=LRCNTX-1
  1. ; modified by Hoak per Joe for prior to free t-4
  1. I '$O(^LRHY(69.87,"B",LRHYD123,0)) D
  1. . S DA=$P(^LRHY(69.87,0),U,3)
  1. . S DA=DA+1
  1. . S X=LRHYD123
  1. . S DIE="^LRHY(69.87,"
  1. . S DR=".01///"_X
  1. . S DIK=DIE
  1. . D ^DIE
  1. I '$G(DA) S DA=$P(^LRHY(69.87,0),U,3)+1
  1. S LRUID=LRHYD123
  1. S $P(^LRHY(69.87,0),U,3)=DA,$P(^LRHY(69.87,0),U,4)=DA
  1. S LRSPIEN=$O(^LRHY(69.87,"B",LRUID,0)) I $G(LRSPIEN) D
  1. . N LRDT,LRSCAN
  1. . S LRDT=$$NOW^XLFDT
  1. . I '$G(LRLABTIM) S LRLABTIM=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
  1. . S LRSCAN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
  1. . K DIE S DIE="^LRHY(69.87," S DR="2///"_LRSCAN S DA=LRSPIEN D ^DIE
  1. . K DIE S DIE="^LRHY(69.87," S DR="4///"_LRDT S DA=LRSPIEN D ^DIE
  1. . K DIE S DIE="^LRHY(69.87," S DR="6////"_LRHYTECH S DA=LRSPIEN D ^DIE
  1. . K DIE S DIE="^LRHY(69.87," S DR="8///"_LRDT S DA=LRSPIEN D ^DIE
  1. S DIK=DIE D IX1^DIK
  1. ZZ1 ;
  1. QUIT:$G(XQY0)'["PPOC"
  1. H 3
  1. S ^TMP("LRHY ASH",$J,LRAA,LRAD,LRAN)=""
  1. G SINGLE
  1. G END
  1. ; Adding urgency to the display
  1. S LRTEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
  1. S LRURG=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
  1. ;
  1. ; Blink urgency if MED-EMERGE
  1. W !,$S($D(^LAB(62.05,+LRURG,0)):$P(^(0),U),1:"")," "
  1. ;
  1. ;
  1. D EDIT
  1. ;
  1. ;
  1. I $G(LREND) W !,"Please start over..." K LREND,LRIDTNEW
  1. D END
  1. QUIT
  1. ;
  1. END ;
  1. K ^TMP("LRHY ASH",$J)
  1. K LRAA,LRAD,LRAN,LRBLOOD,LRARIVE,LRBLOOD,LRCE,LRDAT,LRDFN,LRIDT
  1. K LRDLA,LRDLC,LRDPF,LRDRAW,LRDT0,LRDTO,LRHYDUZ,LRHYNISH,LRPRAC
  1. K LRSN,LRTEST,LRURG,PNM,SSN,VAIN,VADM,LRHYTECH
  1. QUIT
  1. ;
  1. EDIT ;
  1. S LRDFN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
  1. S LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5) ; old LRIDT
  1. CHECK ;
  1. ;
  1. PAST ;
  1. K LRHYDUZ
  1. ; look at Micro And CH subscripted tests
  1. I $D(^LR(LRDFN,"CH",LRIDT)) S LRSS="CH"
  1. E S LRSS="MI"
  1. ;
  1. ; run review option here and show it there has been a previous
  1. ; updating of this accession
  1. ;
  1. K LRARIVE
  1. ;
  1. ;
  1. W !
  1. ; WE need an event to stop non-LRLAB key holders from entering
  1. ; LAB ARRIVAL TIME
  1. BACK G:'$D(^XUSEC("LRLAB",DUZ)) THERE
  1. G THERE
  1. THERE ;
  1. W !
  1. K %DT
  1. D NOW^%DTC
  1. S %DT="AESRZ"
  1. S %DT("A")="Please enter updated DRAW/COLLECTION TIME: "
  1. ;
  1. ; Only default if lrlab owner
  1. I +LRDRAW7>0 S LRDRAW7=$$Y2K^LRX(LRDRAW7)
  1. E S LRDRAW7=$$Y2K^LRX($P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U))
  1. I $D(^XUSEC("LRLAB",DUZ)) S %DT("B")=$P(LRDRAW7,"@")_"@"_$E($P(LRDRAW7,"@",2),1,5)
  1. ;
  1. I X="" G THERE
  1. I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
  1. I Y=-1 S LRUP="YES"
  1. E S LRUP="NO"
  1. D NOW^%DTC S LRDRAW=%
  1. ;
  1. ;
  1. I $D(^XUSEC("LRLAB",DUZ)) G TIC
  1. ;
  1. GUY ; COLLECTOR DEMOGRAPHICS stuff this into LR...99 COMMENT FIELD.
  1. K LRPON
  1. S LRHYNISH=$P(^VA(200,LRHYTECH,0),U,2)
  1. I '$D(^XUSEC("LRLAB",LRHYTECH)) S LRPON=$P($G(^VA(200,LRHYTECH,0)),U)
  1. W !!!
  1. ;
  1. ; This global serves as an interim solution until lab files can
  1. ; be updated
  1. TIC ;
  1. S LRARIVE=$G(LRARIVE,$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3))
  1. S LRPTARIV=$G(LRPTARIV,LRARIVE)
  1. ;
  1. S LRAAX5=LRAA,LRADX6=LRAD,LRANX6=LRAN
  1. S LRHYDUZ=LRHYTECH
  1. SET ;
  1. S $P(^LRO(69,LRDAT,1,LRSN,3),U)=$G(LRDRAW)
  1. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=$G(LRDRAW)
  1. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=$G(LRDRAW)
  1. ;
  1. H 2
  1. G SINGLE
  1. QUIT
  1. PTSCAN ;
  1. ;
  1. W !!,"Please swipe PATIENT ID CARD or Type SSN: "
  1. R X:9999999 W !
  1. Q:X[U
  1. Q:X=""
  1. I $L(X)'=9 W !,"NO SUCH PATIENT" QUIT
  1. S DFN=$O(^DPT("SSN",X,0))
  1. S PNM=$P(^DPT(DFN,0),U) W !,PNM
  1. S LRDFN=$G(^DPT(DFN,"LR"))
  1. ACCNX ;
  1. S LRAA=0
  1. F S LRAA=$O(^TMP("LRHY ASH",$J,LRAA)) Q:+LRAA'>0 D
  1. . S LRAD=0
  1. . F S LRAD=$O(^TMP("LRHY ASH",$J,LRAA,LRAD)) Q:+LRAD'>0 D
  1. .. S LRAN=0
  1. .. F S LRAN=$O(^TMP("LRHY ASH",$J,LRAA,LRAD,LRAN)) Q:+LRAN'>0 D P2
  1. QUIT
  1. P2 ;
  1. N LRX S LRX=0
  1. F S LRX=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRX)) Q:+LRX'>0 D
  1. . I LRDFN'=+^LRO(68,LRAA,1,LRAD,1,LRAN,0) W !,"WRONG PATIENT" QUIT
  1. . W !,^LRO(68,LRAA,1,LRAD,1,LRAN,.2),?20,$P(^LAB(60,LRX,0),U)
  1. . W !,"EVERYTHING MATCHES UP ",$P($P(^VA(200,LRHYTECH,0),U),",",2),", GREAT JOB!"
  1. . H 3
  1. QUIT
  1. LABIN ;
  1. D ^LRHYU4
  1. ;
  1. Q:LRAN=-1
  1. ;
  1. I $L(X)'=10 S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1. S LRUID=X
  1. S DA=$O(^LRHY(69.87,"B",LRUID,0))
  1. I '$G(DA) W !,"Incorrect UID try again..." H 2 G LABIN
  1. I $D(^LRHY(69.87,DA,10)) W !,"Sorry, Lab Arrival Time already recorded!!",! H 2 G LABIN
  1. D NOW^%DTC K LRLABIN S LRLABIN=%
  1. K DIE
  1. S DIE=69.87
  1. S DR="10///"_LRLABIN_";12///"_DUZ
  1. D ^DIE
  1. G LABIN
  1. DISPLAY ;
  1. S X="D"
  1. D ^LRHYU5 I 'LRAN W !,"MUST ENTER UID, TRY AGAIN" H 2 QUIT
  1. S LRUID=X
  1. S ZTRTN="D1^LRHYBC1" D IO^LRWU
  1. QUIT
  1. D1 ;
  1. I $L(LRUID)'=10 S LRUID=X
  1. S LRDA=$O(^LRHY(69.87,"B",LRUID,0))
  1. ;
  1. ; FIX FOR NOT RUN PL
  1. I +$G(LRDA)'>0 W !,"NO Entry in HOWDY SPECIMEN TIMES BY UID File. Run Phlebotomy log." H 1 QUIT
  1. I '$G(^LRHY(69.87,LRDA,2)) D
  1. . K DA,DR S DIE="^LRHY(69.87,",DA=LRDA,DR="2///"_$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U) D ^DIE
  1. W !,"UID: ",LRUID
  1. W !,"WALK-UP SCAN TIME:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,2))
  1. W !,"COLLECTOR:",?50,?50,$P(^VA(200,^LRHY(69.87,LRDA,6),0),U)
  1. W !,"TIME SPECIMEN COLLECTED:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,8))
  1. Q:'$D(^LRHY(69.87,LRDA,10))
  1. W !,"TIME SCANNED INTO LAB:",?50,$$Y2K^LRX(^LRHY(69.87,LRDA,10))
  1. I $G(^LRHY(69.87,LRDA,12)) W !,"RECEIVED INTO LAB BY: ",?50,$P(^VA(200,^LRHY(69.87,LRDA,12),0),U)
  1. QUIT
  1. BINBRD ;
  1. S ZTRTN="D2^LRHYBC1",ZTSAVE("PNM")=""
  1. S LRBBRD=$O(^LRHY(69.86,7,54,"B",0)) I $G(LRBBRD) S ZTIO=LRBBRD,ZTDTH=$H S:$D(ZTQUEUED) ZTREQ="@" D ^%ZTLOAD
  1. QUIT
  1. D2 ;
  1. U IO
  1. W !,"PT:",PNM
  1. D ^%ZISC
  1. QUIT