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

LRHYT1.m

Go to the documentation of this file. 
  1. LRHYT1 ;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
  1.  ;
  1.  ; Reference to ^DIC supported by DBIA #916.
  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.  ; MODIFIED BY HOAK 6/30/2000 FOR RCEV OPTION
  1. CONTROL ;
  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.  W @IOF
  1.  W !,$$CJ^XLFSTR("Barcode Specimen Processor",IOM)
  1.  ;
  1.  ;
  1.  K DIR,DIC,DIE,LRARIVE,LRDRAW
  1.  S LREND=0
  1.  D TECH
  1.  I U[X D END QUIT
  1.  Q:X=""  D SINGLE
  1.  G CONTROL
  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.  W !!,"Please swipe your ID badge: " D NINE^LRHYU
  1.  I U[X QUIT
  1.  I $L(X)'=9 G TECH
  1.  ;
  1.  ;
  1.  ;
  1.  K DIC,LRHYTECH
  1.  K Y
  1.  S DIC=200
  1.  S DIC(0)="MQZ"
  1.  D ^DIC
  1.  W Y
  1.  ;
  1.  I U[X QUIT
  1.  I Y<0 G CONTROL
  1.  S (LRHYDUZ,LRHYTECH)=+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.  ;
  1.  W !!
  1.  S LRACC=""
  1.  ;
  1.  ;
  1.  D ^LRHYU4 ; ask for accession ir uid
  1.  I LRAN<1 QUIT
  1.  D NOW^%DTC
  1.  S LRUID=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),U)
  1.  S LRCE=+^LRO(68,LRAA,1,LRAD,1,LRAN,.1)
  1.  S LRORDT1=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
  1.  S ^TMP("LRHYHOW1",$J,LRORDT1,LRUID)=U_LRHYTECH_U_%
  1.  S $P(^TMP("LRHYHOW1",$J,LRORDT1,LRUID),U,9)="RCEV"
  1.  I LRAN<1 QUIT
  1.  I $G(LRCE) D BUILD^LRHYT2
  1.  E  K LRCENO S LRCENO=1 S LRCE=+^LRO(68,LRAA,1,LRAD,1,LRAN,.1) D BUILD^LRHYT2
  1.  I $G(LRCENO)=1 K LRCE
  1.  ;
  1.  I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W !,"Doesn't exist." G SINGLE
  1.  ; construct orders file entry
  1.  K LRKUNKE
  1.  S LR3ODT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
  1.  S LR3SN=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,5)
  1.  ;
  1.  S LRTEST=0
  1.  K DIR S DIR(0)="E" D ^DIR K DIR
  1.  ;
  1.  S LRUNC=1
  1.  S LRDAT=+$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4),LRSN=+$P(^(0),U,5)
  1.  W @IOF
  1.  ;
  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.  D EDIT
  1.  ;
  1.  ;
  1.  I $G(LREND) W !,"Please start over..." K LREND,LRIDTNEW
  1.  D END
  1.  ;
  1.  QUIT
  1.  ;
  1. LEFTOVER ;
  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.  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.  QUIT