- 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 Feb 18, 2025@23:41:06 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