- LRHYF1 ;DALOI/HOAK - LAB ARRIVAL AND DRAW TIME UPDATER ;4/13/1999
- ;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93
- ;
- ;
- PAT ;
- ;
- ; This routine is used by lab to display updated lab arrival
- ; and collection time as well as the phlebotomist and the provider
- ; as well as the date time ordered.
- ;
- ;
- QUIT
- ORD ;
- ;
- QUIT
- ;
- SINGLE ;
- K LRAA,LRAN,LRAD,LRUID,LRACC6
- ; This block calls up the testing demographics.
- ;
- W !!
- S LRACC="" K LRHN0
- D ^LRHYU4
- I $G(LRORD) D ORD
- I LRAN<1 D END QUIT
- I $L(X)'=10 S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
- I X S LRUID=X
- ;
- I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." G SINGLE
- ; KUNKE OPTION TY-IN
- KUNKE ;
- S LRUNC=1
- S LRDAT=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4),LRSN=+$P(^(0),U,5)
- D:'$G(LRKUNKE) LST1^LRHYLS1
- ;
- ;
- ; Adding urgency to the display
- S LRTEST=0
- K LRURG2
- F S LRTEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST)) Q:+LRTEST'>0 D
- . W !,$P($G(^LAB(60,LRTEST,0)),U)
- . S LRURG7=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
- . I LRURG7=1 S LRURG=LRURG7
- . I LRURG7=2 S LRURG2=2
- I $G(LRURG2)=2 D
- . Q:$G(LRURG)=1 S LRURG=2
- ;
- ;
- ; Blink urgency if MED-EMERGE
- S LRURG=$G(LRURG,LRURG7)
- 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
- I $G(LRKUNKE) G SINGLE^LRHYT1 QUIT
- G SINGLE
- ;
- 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 ;
- Q:LRAA=-1
- 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 ;
- ; Check for results. Quit if results present
- ;
- ;
- 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
- I $G(LRKUNKE)'=1 I $D(^XUSEC("LRLAB",DUZ)) D EDIT^LRHYF2
- K LRARIVE
- ;
- ;
- W !
- ; WE need an event to stop non-LRLAB key holders from entering
- ; LAB ARRIVAL TIME
- BACK G:'$D(^XUSEC("LRLAB",DUZ)) DRAW
- G DRAW
- K %DT
- D NOW^%DTC
- S %DT="AERSZ"
- D ^%DT
- I Y=-1 S LREND=1 QUIT
- I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
- D NOW^%DTC
- I Y>% W !!,"Can't accept future times!" W *7 G BACK
- S LRARIVE=Y I +LRARIVE'>0 S LRARIVE=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)
- ;
- SET ;
- S $P(^LRO(69,LRDAT,1,LRSN,3),U)=$G(LRARIVE)
- ;
- S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=$G(LRARIVE)
- S $P(^LR(LRDFN,"MI",LRIDT,0),U,10)=$G(LRARIVE)
- I $G(LRARIVE) S ^LRO(68,LRAA,1,LRAD,1,"E",LRARIVE,LRAN)=""
- ;
- ;
- DRAW ;
- QUIT
- 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)
- ;
- D ^%DT
- I X="" G DRAW
- I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
- I Y=-1 S LRUP="YES"
- E S LRUP="NO"
- S LRDRAW=Y I +LRDRAW'>0 S LRDRAW=LRDRAW7
- S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=LRDRAW
- ;
- ;
- I $D(^XUSEC("LRLAB",DUZ)) G TIC
- ;
- GUY ; COLLECTOR DEMOGRAPHICS stuff this into LR...99 COMMENT FIELD.
- S LRHYNISH=$P(^VA(200,DUZ,0),U,2)
- I '$D(^XUSEC("LRLAB",DUZ)) S LRPON=$P($G(^VA(200,DUZ,0)),U)
- W !!!
- ;
- D
- . D SCRNON^LRHYUTL
- . W IOBON
- . W IORVON
- . W IODHLT,LRHYNISH
- . W !
- . W IODHLB,LRHYNISH
- . W !!
- . W IORVOFF
- . W IOBOFF
- . D SCRNOFF^LRHYUTL
- ;
- W !!,"Your initials have been captured." D
- . S DIR(0)="Y" S DIR("B")="YES"
- . S DIR("A")="Is this correct?"
- . D ^DIR
- . I $D(DTOUT)!($D(DUOUT)) QUIT
- . ;
- . I Y S LRHYDUZ=LRPON
- . Q:Y>0
- . S DIC("A")="Enter collector here."
- . S DIC="^VA(200,"
- . S DIC(0)="AEMQZ"
- . D ^DIC
- . I +Y>0 S LRHYDUZ=$P(Y(0),U) S LRPON=$P(^VA(200,DUZ,0),U)
- ;
- ; 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))
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRHYF1 4208 printed Feb 18, 2025@23:41:11 Page 2
- LRHYF1 ;DALOI/HOAK - LAB ARRIVAL AND DRAW TIME UPDATER ;4/13/1999
- +1 ;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93
- +2 ;
- +3 ;
- PAT ;
- +1 ;
- +2 ; This routine is used by lab to display updated lab arrival
- +3 ; and collection time as well as the phlebotomist and the provider
- +4 ; as well as the date time ordered.
- +5 ;
- +6 ;
- +7 QUIT
- ORD ;
- +1 ;
- +2 QUIT
- +3 ;
- SINGLE ;
- +1 KILL LRAA,LRAN,LRAD,LRUID,LRACC6
- +2 ; This block calls up the testing demographics.
- +3 ;
- +4 WRITE !!
- +5 SET LRACC=""
- KILL LRHN0
- +6 DO ^LRHYU4
- +7 IF $GET(LRORD)
- DO ORD
- +8 IF LRAN<1
- DO END
- QUIT
- +9 IF $LENGTH(X)'=10
- SET X=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
- +10 IF X
- SET LRUID=X
- +11 ;
- +12 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- WRITE !,"Doesn't exist."
- GOTO SINGLE
- +13 ; KUNKE OPTION TY-IN
- KUNKE ;
- +1 SET LRUNC=1
- +2 SET LRDAT=+$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
- SET LRSN=+$PIECE(^(0),U,5)
- +3 if '$GET(LRKUNKE)
- DO LST1^LRHYLS1
- +4 ;
- +5 ;
- +6 ; Adding urgency to the display
- +7 SET LRTEST=0
- +8 KILL LRURG2
- +9 FOR
- SET LRTEST=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST))
- if +LRTEST'>0
- QUIT
- Begin DoDot:1
- +10 WRITE !,$PIECE($GET(^LAB(60,LRTEST,0)),U)
- +11 SET LRURG7=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
- +12 IF LRURG7=1
- SET LRURG=LRURG7
- +13 IF LRURG7=2
- SET LRURG2=2
- End DoDot:1
- +14 IF $GET(LRURG2)=2
- Begin DoDot:1
- +15 if $GET(LRURG)=1
- QUIT
- SET LRURG=2
- End DoDot:1
- +16 ;
- +17 ;
- +18 ; Blink urgency if MED-EMERGE
- +19 SET LRURG=$GET(LRURG,LRURG7)
- +20 WRITE !,$SELECT($DATA(^LAB(62.05,+LRURG,0)):$PIECE(^(0),U),1:"")," "
- +21 ;
- +22 ;
- +23 DO EDIT
- +24 ;
- +25 ;
- +26 IF $GET(LREND)
- WRITE !,"Please start over..."
- KILL LREND,LRIDTNEW
- +27 DO END
- +28 IF $GET(LRKUNKE)
- GOTO SINGLE^LRHYT1
- QUIT
- +29 GOTO SINGLE
- +30 ;
- +31 QUIT
- +32 ;
- 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 if LRAA=-1
- QUIT
- +2 SET LRDFN=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U)
- +3 ; old LRIDT
- SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
- CHECK ;
- +1 ; Check for results. Quit if results present
- +2 ;
- +3 ;
- 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 IF $GET(LRKUNKE)'=1
- IF $DATA(^XUSEC("LRLAB",DUZ))
- DO EDIT^LRHYF2
- +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 DRAW
- +1 GOTO DRAW
- +2 KILL %DT
- +3 DO NOW^%DTC
- +4 SET %DT="AERSZ"
- +5 DO ^%DT
- +6 IF Y=-1
- SET LREND=1
- QUIT
- +7 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET LREND=1
- QUIT
- +8 DO NOW^%DTC
- +9 IF Y>%
- WRITE !!,"Can't accept future times!"
- WRITE *7
- GOTO BACK
- +10 SET LRARIVE=Y
- IF +LRARIVE'>0
- SET LRARIVE=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)
- +11 ;
- SET ;
- +1 SET $PIECE(^LRO(69,LRDAT,1,LRSN,3),U)=$GET(LRARIVE)
- +2 ;
- +3 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=$GET(LRARIVE)
- +4 SET $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,10)=$GET(LRARIVE)
- +5 IF $GET(LRARIVE)
- SET ^LRO(68,LRAA,1,LRAD,1,"E",LRARIVE,LRAN)=""
- +6 ;
- +7 ;
- DRAW ;
- +1 QUIT
- 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 DO ^%DT
- +13 IF X=""
- GOTO DRAW
- +14 IF $DATA(DTOUT)!($DATA(DUOUT))
- SET LREND=1
- QUIT
- +15 IF Y=-1
- SET LRUP="YES"
- +16 IF '$TEST
- SET LRUP="NO"
- +17 SET LRDRAW=Y
- IF +LRDRAW'>0
- SET LRDRAW=LRDRAW7
- +18 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=LRDRAW
- +19 ;
- +20 ;
- +21 IF $DATA(^XUSEC("LRLAB",DUZ))
- GOTO TIC
- +22 ;
- GUY ; COLLECTOR DEMOGRAPHICS stuff this into LR...99 COMMENT FIELD.
- +1 SET LRHYNISH=$PIECE(^VA(200,DUZ,0),U,2)
- +2 IF '$DATA(^XUSEC("LRLAB",DUZ))
- SET LRPON=$PIECE($GET(^VA(200,DUZ,0)),U)
- +3 WRITE !!!
- +4 ;
- +5 Begin DoDot:1
- +6 DO SCRNON^LRHYUTL
- +7 WRITE IOBON
- +8 WRITE IORVON
- +9 WRITE IODHLT,LRHYNISH
- +10 WRITE !
- +11 WRITE IODHLB,LRHYNISH
- +12 WRITE !!
- +13 WRITE IORVOFF
- +14 WRITE IOBOFF
- +15 DO SCRNOFF^LRHYUTL
- End DoDot:1
- +16 ;
- +17 WRITE !!,"Your initials have been captured."
- Begin DoDot:1
- +18 SET DIR(0)="Y"
- SET DIR("B")="YES"
- +19 SET DIR("A")="Is this correct?"
- +20 DO ^DIR
- +21 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +22 ;
- +23 IF Y
- SET LRHYDUZ=LRPON
- +24 if Y>0
- QUIT
- +25 SET DIC("A")="Enter collector here."
- +26 SET DIC="^VA(200,"
- +27 SET DIC(0)="AEMQZ"
- +28 DO ^DIC
- +29 IF +Y>0
- SET LRHYDUZ=$PIECE(Y(0),U)
- SET LRPON=$PIECE(^VA(200,DUZ,0),U)
- End DoDot:1
- +30 ;
- +31 ; This global serves as an interim solution until lab files can
- +32 ; be updated
- TIC ;
- +1 SET LRARIVE=$GET(LRARIVE,$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3))