LAMIVTL0 ;DAL/HOAK 1st routine for Vitek Literal Verification ;1/22/96 08:30 ;
;;5.2;AUTOMATED LAB INSTRUMENTS;**12,37,42**;Sep 27,1994
INIT ;
S OK=1
D CONTROL
D END
Q
CONTROL ;
D INTRO I 'OK D END QUIT
Q
END ;
K LRNOTO,LRBUG,LRBUX,LRTIC,LRTAC,LRTAD,LRPIC,LRNODE,LRSUM,LRIFN
K LRQUANT,LAMIAUTO,LRINST
;LR*5.2*37___/\______/\ added to fix undef in LRCAPVM
Q
INTRO ;FROM LAMIAUT0 BY FHS
;-----------------------------------------------------------------
D ^LRPARAM
S LRMIDEF=$P(^LAB(69.9,1,1),U,10) S LRMIOTH=$P(^(1),U,11)
S LRINI=$P(^VA(200,DUZ,0),U,2)
S LRMICOM=$S($D(^DD(63.31,.01,0)):$P(^(0),U,5,99),1:"S Q9=""1,68,KM"" D COM^LRNUM")
S LRMICOMS=$P($P(LRMICOM,",",3),"""",1)
S LRTEC=LRINI
;
MACHINE ;
K DIC
W @IOF
D S1
S DIC="^LAB(62.4,"
S DIC(0)="AEMQZ"
S DIC("A")="Select auto instrument here: "
D ^DIC I Y=-1 S OK=0 QUIT ;------------------Back to Control
S LRINST=+Y
S LRNODE=Y(0)
S LRAA=$P(LRNODE,U,11)
;----------------------------------------------------------------------
S LRLL=$P(LRNODE,U,4) ;-----------> load/work list
I '$G(LRLL) S OK=0 QUIT ;--------------------Back to Control
;----------------------------------------------------------------------
AREA ;
K DIC("A") K Y(0)
S DIC="^LRO(68,"
S DIC("B")=$P(^LRO(68,LRAA,0),U)
D ^DIC ;----------------->ACCESSION AREA
I Y=-1 S OK=0 QUIT ;-------------------------Back to Control
I +Y'=LRAA S LRAA=+Y
;-----------------------------------------------------------------------
LRAD ;
S %DT="AEP"
S %DT("A")=" Accession date: "
S %DT("B")=$$FMTE^XLFDT($$CADT^LA7UTIL(LRAA),"1D")
D DATE^LRWU I Y=-1 S OK=0 QUIT ;--------------Back to Control
S LRAD=+Y
;-----------------------------------------------------------------------
LMIP ;
S LRVT=$P(LRNODE,U,15) I '$G(LRVT) S LRVT="VS"
S LRFMT=$P(^LAB(69.9,1,0),U,11),LRFMT=$S(LRFMT="":"I",1:LRFMT)
D AUTO^LRCAPV ;--------------->Work Load
I Y=-1 S OK=0 QUIT ;--------------------------Back to Control
;-----------------------------------------------------------------------
ACCN ;
I '$D(^LAH(LRLL,1,"C")) S OK=0 D NODATA QUIT ;no data in LAH
S OK=1
K DIR
S LRAN=0
F S LRAN=$O(^LAH(LRLL,1,"C",LRAN)) Q:LRAN'>0 D Q:'OK
. S DIR(0)="N"
. S DIR("A")="Enter the number portion of the Accession"
. S DIR("B")=LRAN
. S DIR("?")="^D LIST^LAMIVTL0"
. D ^DIR
. I $D(DUOUT)!($D(DTOUT)) S OK=0 QUIT ;---------Back to Control
. I Y'=LRAN S LRAN=+Y
. S LRANX=LRAN
. ;LA*5.2*37 Check for accns not in Vista
. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D REMOVE QUIT
. ;
. ;^LAH(65,1,"C",3,32)
. D LRIFN
Q:'OK D:$G(OK1)'>0 LIST
G:$G(OK1)'>0 ACCN
Q
S1 ;
W !!," Vitek Literal verification screen 1",!
Q
;---------------------------------------------------------------------
LIST ;
W !!
S LRLIST=0
W !,"Choose from: "
F S LRLIST=$O(^LAH(LRLL,1,"C",LRLIST)) Q:LRLIST="" D
. W !,LRLIST
Q
REMOVE ;
;
;--^LAH(65,1,"C",3659,69) =
;_____________________/\
; \/
;--^LAH(65,1,69,0) = 1^1^^^3659^^VITEK^3659
;--^LAH(65,1,69,2,2) = CARD^gni
;--^LAH(65,1,69,3,1,0) = 1^^gni
;
;
S DIR("A")=$P(^LRO(68,12,0),U)_" "_LRAN_" is not in Vista data base. I've removed the C x-ref Shall I remove ^LAH Data?"
S DIR(0)="Y" S DIR("B")="YES"
D ^DIR
I $D(DTOUT)!($D(DUOUT)) S OK=0 QUIT
;
I Y=1 D
. S LRTIC=0
. F S LRTIC=$O(^LAH(LRLL,1,"C",LRAN,LRTIC)) Q:+LRTIC'>0 D
.. I $D(^LAH(LRLL,1,LRTIC,0)) K ^LAH(LRLL,1,LRTIC)
K ^LAH(LRLL,1,"C",LRAN)
K ^LAH(LRLL,1,"E",LRAN)
;
;
W !,"Please continue...",!
Q
LRIFN ;
S OK1=1
S LRIFN=0,LRCNT=0
F S LRIFN=$O(^LAH(LRLL,1,"C",LRAN,LRIFN)) Q:LRIFN'>0 D Q:'OK1
. S LRCNT=LRCNT+1
. S LRIFN(LRCNT)=LRIFN
I '$G(LRCNT) W !!,"There is no data in LAH for accession ",LRAN S OK1=0 QUIT
Q:'OK1
D ^LAMIVTL5 ;check for zero isolate
Q:'OK
D ^LAMIVTL1 ;continue processing
D END
Q
NODATA ;
W !!," There is no data in LAH. Run another upload "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAMIVTL0 4055 printed Dec 13, 2024@01:43:25 Page 2
LAMIVTL0 ;DAL/HOAK 1st routine for Vitek Literal Verification ;1/22/96 08:30 ;
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**12,37,42**;Sep 27,1994
INIT ;
+1 SET OK=1
+2 DO CONTROL
+3 DO END
+4 QUIT
CONTROL ;
+1 DO INTRO
IF 'OK
DO END
QUIT
+2 QUIT
END ;
+1 KILL LRNOTO,LRBUG,LRBUX,LRTIC,LRTAC,LRTAD,LRPIC,LRNODE,LRSUM,LRIFN
+2 KILL LRQUANT,LAMIAUTO,LRINST
+3 ;LR*5.2*37___/\______/\ added to fix undef in LRCAPVM
+4 QUIT
INTRO ;FROM LAMIAUT0 BY FHS
+1 ;-----------------------------------------------------------------
+2 DO ^LRPARAM
+3 SET LRMIDEF=$PIECE(^LAB(69.9,1,1),U,10)
SET LRMIOTH=$PIECE(^(1),U,11)
+4 SET LRINI=$PIECE(^VA(200,DUZ,0),U,2)
+5 SET LRMICOM=$SELECT($DATA(^DD(63.31,.01,0)):$PIECE(^(0),U,5,99),1:"S Q9=""1,68,KM"" D COM^LRNUM")
+6 SET LRMICOMS=$PIECE($PIECE(LRMICOM,",",3),"""",1)
+7 SET LRTEC=LRINI
+8 ;
MACHINE ;
+1 KILL DIC
+2 WRITE @IOF
+3 DO S1
+4 SET DIC="^LAB(62.4,"
+5 SET DIC(0)="AEMQZ"
+6 SET DIC("A")="Select auto instrument here: "
+7 ;------------------Back to Control
DO ^DIC
IF Y=-1
SET OK=0
QUIT
+8 SET LRINST=+Y
+9 SET LRNODE=Y(0)
+10 SET LRAA=$PIECE(LRNODE,U,11)
+11 ;----------------------------------------------------------------------
+12 ;-----------> load/work list
SET LRLL=$PIECE(LRNODE,U,4)
+13 ;--------------------Back to Control
IF '$GET(LRLL)
SET OK=0
QUIT
+14 ;----------------------------------------------------------------------
AREA ;
+1 KILL DIC("A")
KILL Y(0)
+2 SET DIC="^LRO(68,"
+3 SET DIC("B")=$PIECE(^LRO(68,LRAA,0),U)
+4 ;----------------->ACCESSION AREA
DO ^DIC
+5 ;-------------------------Back to Control
IF Y=-1
SET OK=0
QUIT
+6 IF +Y'=LRAA
SET LRAA=+Y
+7 ;-----------------------------------------------------------------------
LRAD ;
+1 SET %DT="AEP"
+2 SET %DT("A")=" Accession date: "
+3 SET %DT("B")=$$FMTE^XLFDT($$CADT^LA7UTIL(LRAA),"1D")
+4 ;--------------Back to Control
DO DATE^LRWU
IF Y=-1
SET OK=0
QUIT
+5 SET LRAD=+Y
+6 ;-----------------------------------------------------------------------
LMIP ;
+1 SET LRVT=$PIECE(LRNODE,U,15)
IF '$GET(LRVT)
SET LRVT="VS"
+2 SET LRFMT=$PIECE(^LAB(69.9,1,0),U,11)
SET LRFMT=$SELECT(LRFMT="":"I",1:LRFMT)
+3 ;--------------->Work Load
DO AUTO^LRCAPV
+4 ;--------------------------Back to Control
IF Y=-1
SET OK=0
QUIT
+5 ;-----------------------------------------------------------------------
ACCN ;
+1 ;no data in LAH
IF '$DATA(^LAH(LRLL,1,"C"))
SET OK=0
DO NODATA
QUIT
+2 SET OK=1
+3 KILL DIR
+4 SET LRAN=0
+5 FOR
SET LRAN=$ORDER(^LAH(LRLL,1,"C",LRAN))
if LRAN'>0
QUIT
Begin DoDot:1
+6 SET DIR(0)="N"
+7 SET DIR("A")="Enter the number portion of the Accession"
+8 SET DIR("B")=LRAN
+9 SET DIR("?")="^D LIST^LAMIVTL0"
+10 DO ^DIR
+11 ;---------Back to Control
IF $DATA(DUOUT)!($DATA(DTOUT))
SET OK=0
QUIT
+12 IF Y'=LRAN
SET LRAN=+Y
+13 SET LRANX=LRAN
+14 ;LA*5.2*37 Check for accns not in Vista
+15 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
DO REMOVE
QUIT
+16 ;
+17 ;^LAH(65,1,"C",3,32)
+18 DO LRIFN
End DoDot:1
if 'OK
QUIT
+19 if 'OK
QUIT
if $GET(OK1)'>0
DO LIST
+20 if $GET(OK1)'>0
GOTO ACCN
+21 QUIT
S1 ;
+1 WRITE !!," Vitek Literal verification screen 1",!
+2 QUIT
+3 ;---------------------------------------------------------------------
LIST ;
+1 WRITE !!
+2 SET LRLIST=0
+3 WRITE !,"Choose from: "
+4 FOR
SET LRLIST=$ORDER(^LAH(LRLL,1,"C",LRLIST))
if LRLIST=""
QUIT
Begin DoDot:1
+5 WRITE !,LRLIST
End DoDot:1
+6 QUIT
REMOVE ;
+1 ;
+2 ;--^LAH(65,1,"C",3659,69) =
+3 ;_____________________/\
+4 ; \/
+5 ;--^LAH(65,1,69,0) = 1^1^^^3659^^VITEK^3659
+6 ;--^LAH(65,1,69,2,2) = CARD^gni
+7 ;--^LAH(65,1,69,3,1,0) = 1^^gni
+8 ;
+9 ;
+10 SET DIR("A")=$PIECE(^LRO(68,12,0),U)_" "_LRAN_" is not in Vista data base. I've removed the C x-ref Shall I remove ^LAH Data?"
+11 SET DIR(0)="Y"
SET DIR("B")="YES"
+12 DO ^DIR
+13 IF $DATA(DTOUT)!($DATA(DUOUT))
SET OK=0
QUIT
+14 ;
+15 IF Y=1
Begin DoDot:1
+16 SET LRTIC=0
+17 FOR
SET LRTIC=$ORDER(^LAH(LRLL,1,"C",LRAN,LRTIC))
if +LRTIC'>0
QUIT
Begin DoDot:2
+18 IF $DATA(^LAH(LRLL,1,LRTIC,0))
KILL ^LAH(LRLL,1,LRTIC)
End DoDot:2
End DoDot:1
+19 KILL ^LAH(LRLL,1,"C",LRAN)
+20 KILL ^LAH(LRLL,1,"E",LRAN)
+21 ;
+22 ;
+23 WRITE !,"Please continue...",!
+24 QUIT
LRIFN ;
+1 SET OK1=1
+2 SET LRIFN=0
SET LRCNT=0
+3 FOR
SET LRIFN=$ORDER(^LAH(LRLL,1,"C",LRAN,LRIFN))
if LRIFN'>0
QUIT
Begin DoDot:1
+4 SET LRCNT=LRCNT+1
+5 SET LRIFN(LRCNT)=LRIFN
End DoDot:1
if 'OK1
QUIT
+6 IF '$GET(LRCNT)
WRITE !!,"There is no data in LAH for accession ",LRAN
SET OK1=0
QUIT
+7 if 'OK1
QUIT
+8 ;check for zero isolate
DO ^LAMIVTL5
+9 if 'OK
QUIT
+10 ;continue processing
DO ^LAMIVTL1
+11 DO END
+12 QUIT
NODATA ;
+1 WRITE !!," There is no data in LAH. Run another upload "
+2 QUIT
