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

LRHYF1.m

Go to the documentation of this file.
  1. LRHYF1 ;DALOI/HOAK - LAB ARRIVAL AND DRAW TIME UPDATER ;4/13/1999
  1. ;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93
  1. ;
  1. ;
  1. PAT ;
  1. ;
  1. ; This routine is used by lab to display updated lab arrival
  1. ; and collection time as well as the phlebotomist and the provider
  1. ; as well as the date time ordered.
  1. ;
  1. ;
  1. QUIT
  1. ORD ;
  1. ;
  1. QUIT
  1. ;
  1. SINGLE ;
  1. K LRAA,LRAN,LRAD,LRUID,LRACC6
  1. ; This block calls up the testing demographics.
  1. ;
  1. W !!
  1. S LRACC="" K LRHN0
  1. D ^LRHYU4
  1. I $G(LRORD) D ORD
  1. I LRAN<1 D END QUIT
  1. I $L(X)'=10 S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1. I X S LRUID=X
  1. ;
  1. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." G SINGLE
  1. ; KUNKE OPTION TY-IN
  1. KUNKE ;
  1. S LRUNC=1
  1. S LRDAT=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4),LRSN=+$P(^(0),U,5)
  1. D:'$G(LRKUNKE) LST1^LRHYLS1
  1. ;
  1. ;
  1. ; Adding urgency to the display
  1. S LRTEST=0
  1. K LRURG2
  1. F S LRTEST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST)) Q:+LRTEST'>0 D
  1. . W !,$P($G(^LAB(60,LRTEST,0)),U)
  1. . S LRURG7=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0)),U,2)
  1. . I LRURG7=1 S LRURG=LRURG7
  1. . I LRURG7=2 S LRURG2=2
  1. I $G(LRURG2)=2 D
  1. . Q:$G(LRURG)=1 S LRURG=2
  1. ;
  1. ;
  1. ; Blink urgency if MED-EMERGE
  1. S LRURG=$G(LRURG,LRURG7)
  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. I $G(LRKUNKE) G SINGLE^LRHYT1 QUIT
  1. G SINGLE
  1. ;
  1. QUIT
  1. ;
  1. END ;
  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
  1. QUIT
  1. ;
  1. EDIT ;
  1. Q:LRAA=-1
  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. ; Check for results. Quit if results present
  1. ;
  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. I $G(LRKUNKE)'=1 I $D(^XUSEC("LRLAB",DUZ)) D EDIT^LRHYF2
  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)) DRAW
  1. G DRAW
  1. K %DT
  1. D NOW^%DTC
  1. S %DT="AERSZ"
  1. D ^%DT
  1. I Y=-1 S LREND=1 QUIT
  1. I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
  1. D NOW^%DTC
  1. I Y>% W !!,"Can't accept future times!" W *7 G BACK
  1. S LRARIVE=Y I +LRARIVE'>0 S LRARIVE=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)
  1. ;
  1. SET ;
  1. S $P(^LRO(69,LRDAT,1,LRSN,3),U)=$G(LRARIVE)
  1. ;
  1. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,3)=$G(LRARIVE)
  1. S $P(^LR(LRDFN,"MI",LRIDT,0),U,10)=$G(LRARIVE)
  1. I $G(LRARIVE) S ^LRO(68,LRAA,1,LRAD,1,"E",LRARIVE,LRAN)=""
  1. ;
  1. ;
  1. DRAW ;
  1. QUIT
  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. D ^%DT
  1. I X="" G DRAW
  1. I $D(DTOUT)!($D(DUOUT)) S LREND=1 QUIT
  1. I Y=-1 S LRUP="YES"
  1. E S LRUP="NO"
  1. S LRDRAW=Y I +LRDRAW'>0 S LRDRAW=LRDRAW7
  1. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U)=LRDRAW
  1. ;
  1. ;
  1. I $D(^XUSEC("LRLAB",DUZ)) G TIC
  1. ;
  1. GUY ; COLLECTOR DEMOGRAPHICS stuff this into LR...99 COMMENT FIELD.
  1. S LRHYNISH=$P(^VA(200,DUZ,0),U,2)
  1. I '$D(^XUSEC("LRLAB",DUZ)) S LRPON=$P($G(^VA(200,DUZ,0)),U)
  1. W !!!
  1. ;
  1. D
  1. . D SCRNON^LRHYUTL
  1. . W IOBON
  1. . W IORVON
  1. . W IODHLT,LRHYNISH
  1. . W !
  1. . W IODHLB,LRHYNISH
  1. . W !!
  1. . W IORVOFF
  1. . W IOBOFF
  1. . D SCRNOFF^LRHYUTL
  1. ;
  1. W !!,"Your initials have been captured." D
  1. . S DIR(0)="Y" S DIR("B")="YES"
  1. . S DIR("A")="Is this correct?"
  1. . D ^DIR
  1. . I $D(DTOUT)!($D(DUOUT)) QUIT
  1. . ;
  1. . I Y S LRHYDUZ=LRPON
  1. . Q:Y>0
  1. . S DIC("A")="Enter collector here."
  1. . S DIC="^VA(200,"
  1. . S DIC(0)="AEMQZ"
  1. . D ^DIC
  1. . I +Y>0 S LRHYDUZ=$P(Y(0),U) S LRPON=$P(^VA(200,DUZ,0),U)
  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))