LAMIVTL3 ;DAL/HOAK 3RD VITEK LITERAL VERIFY RCR ; 01/02/96 08:00
;;5.2;AUTOMATED LAB INSTRUMENTS;**12,40**;Sep 27,1994
INIT ;
;FROM LAMIAUT2 BY FHS
MOVE ;Move data into ^LR(LRDFN,"MI",LRIDT,3,
;I LREND S LREND=0,^LAH(LRLL,1,LRIFN,3,IR,0)=LRCNODE K LRMOVE(IR) Q
;
S %X="^LAH("_LRLL_",1,"_LRIFN_",3,"
S %Y="^LAH("_LRLL_",1,"_LRIFN_",3,"
D %XY^%RCR
SET ;
S %X="^LAH("_LRLL_",1,"_LRIFN(LRIFN)_",3,"_LRISO_","
S %Y="^LR("_LRDFN_","""_LRSUB_""","_LRIDT_",3,"_LRISO_","
D %XY^%RCR
S $P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,0),U,2)=$G(LRQUANT(LRISO)),$P(^(0),U,3)=""
;
I '$D(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0)) D
. S ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0)="^63.31A"
S LRORG93=$P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,3)
S LRORG94=$P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,4)
S $P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,3)=$G(LRORG93)+1
S $P(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,4)=$G(LRORG94)+1
Q
CHKLAH ;
S LRNOT=0
S LRTIC=""
S LRTIC=$O(^TMP($J,"LA",3,LRISO,LRIFN(LRIFN),LRTIC))
I $D(^LAH(LRLL,1,"VITLIT",3,LRISO,LRIFN(LRIFN),LRTIC)) D
. S LRNOT=1 K ^TMP($J,"LA",LRISO,3,LRIFN(LRIFN),LRTIC)
. ;REMOVEING DUPS FROM VITLIT XREF
. S LRIF=LRIFN(LRIFN)
. F S LRIF=$O(^LAH(LRLL,1,"VITLIT",3,LRISO,LRIF)) Q:LRIF="" D
.. S LRPRG=""
.. F S LRPRG=$O(^LAH(LRLL,1,"VITLIT",3,LRISO,LRIF,LRPRG)) Q:LRPRG="" D
... I LRTIC=LRPRG K ^LAH(LRLL,1,"VITLIT",3,LRISO,LRIF,LRPRG) D
.... K ^LAH(LRLL,1,"VITLIT",3,LRISO,LRIFN(LRIFN),LRPRG)
Q
SLICK ;
S LRIK=1
F S LRIK=$O(^LAH(LRLL,1,"C",LRAN,LRIK)) Q:+LRIK'>0 D
. S LRISO=0
. F S LRISO=$O(^LAH(LRLL,1,LRIK,3,LRISO)) Q:+LRISO'>0 D
.. S LRDRUG=0
.. F S LRDRUG=$O(^LAH(LRLL,1,LRIK,3,LRISO,LRDRUG)) Q:+LRDRUG'>0 D
... I $G(^LAH(LRLL,1,LRPC,3,LRISO,LRDRUG))=^LAH(LRLL,1,LRIK,3,LRISO,LRDRUG) D
.... K ^LAH(LRLL,1,LRIK)
Q
GLEEP ;
; This block removes all ^LR except logging node and comments
K DIR
W !
S DIR(0)="Y"
S DIR("A")=" Shall I delete this data?: "
S DIR("B")="Yes"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!(Y=0) S OK=0 QUIT
K ^LR(LRDFN,LRSUB,LRIDT,3)
K ^LR(LRDFN,LRSUB,LRIDT,1)
; This is optional.-----\/
W @IOF
S LRJOB=" REMOVING ^LR DATA"
D JOBTIME
QUIT
JOBTIME ;
;CAN BE USED INSTEAD OF dots TO SHOW USER HOW JOB IS PROCEEDING
D ENS^%ZISS S %ZIS="I"
W !!,IODHLT,LRJOB,!,IODHLB,LRJOB
S DX=2,DY=10 X IOXY
F I=1:1:35 S DX=I*2+2,DY=16 X IOXY D ;add a factor here as job proceeds
. S DX=2*(2+I),DY=10 X IOXY
. W IORVON
. W "->"
. W IORVOFF
. S DX=16,DY=17 X IOXY
. W IODHLT,2*($E((I/70)*100,1,4)),"% "
. S DX=16,DY=18 X IOXY
. W IODHLB,2*($E((I/70)*100,1,4)),"% "
W !!,IODHLT,"DONE",!,IODHLB,"DONE"
D KILL^%ZISS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAMIVTL3 2696 printed Dec 13, 2024@01:43:28 Page 2
LAMIVTL3 ;DAL/HOAK 3RD VITEK LITERAL VERIFY RCR ; 01/02/96 08:00
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**12,40**;Sep 27,1994
INIT ;
+1 ;FROM LAMIAUT2 BY FHS
MOVE ;Move data into ^LR(LRDFN,"MI",LRIDT,3,
+1 ;I LREND S LREND=0,^LAH(LRLL,1,LRIFN,3,IR,0)=LRCNODE K LRMOVE(IR) Q
+2 ;
+3 SET %X="^LAH("_LRLL_",1,"_LRIFN_",3,"
+4 SET %Y="^LAH("_LRLL_",1,"_LRIFN_",3,"
+5 DO %XY^%RCR
SET ;
+1 SET %X="^LAH("_LRLL_",1,"_LRIFN(LRIFN)_",3,"_LRISO_","
+2 SET %Y="^LR("_LRDFN_","""_LRSUB_""","_LRIDT_",3,"_LRISO_","
+3 DO %XY^%RCR
+4 SET $PIECE(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,0),U,2)=$GET(LRQUANT(LRISO))
SET $PIECE(^(0),U,3)=""
+5 ;
+6 IF '$DATA(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0))
Begin DoDot:1
+7 SET ^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0)="^63.31A"
End DoDot:1
+8 SET LRORG93=$PIECE(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,3)
+9 SET LRORG94=$PIECE(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,4)
+10 SET $PIECE(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,3)=$GET(LRORG93)+1
+11 SET $PIECE(^LR(LRDFN,LRSUB,LRIDT,3,LRISO,1,0),U,4)=$GET(LRORG94)+1
+12 QUIT
CHKLAH ;
+1 SET LRNOT=0
+2 SET LRTIC=""
+3 SET LRTIC=$ORDER(^TMP($JOB,"LA",3,LRISO,LRIFN(LRIFN),LRTIC))
+4 IF $DATA(^LAH(LRLL,1,"VITLIT",3,LRISO,LRIFN(LRIFN),LRTIC))
Begin DoDot:1
+5 SET LRNOT=1
KILL ^TMP($JOB,"LA",LRISO,3,LRIFN(LRIFN),LRTIC)
+6 ;REMOVEING DUPS FROM VITLIT XREF
+7 SET LRIF=LRIFN(LRIFN)
+8 FOR
SET LRIF=$ORDER(^LAH(LRLL,1,"VITLIT",3,LRISO,LRIF))
if LRIF=""
QUIT
Begin DoDot:2
+9 SET LRPRG=""
+10 FOR
SET LRPRG=$ORDER(^LAH(LRLL,1,"VITLIT",3,LRISO,LRIF,LRPRG))
if LRPRG=""
QUIT
Begin DoDot:3
+11 IF LRTIC=LRPRG
KILL ^LAH(LRLL,1,"VITLIT",3,LRISO,LRIF,LRPRG)
Begin DoDot:4
+12 KILL ^LAH(LRLL,1,"VITLIT",3,LRISO,LRIFN(LRIFN),LRPRG)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
SLICK ;
+1 SET LRIK=1
+2 FOR
SET LRIK=$ORDER(^LAH(LRLL,1,"C",LRAN,LRIK))
if +LRIK'>0
QUIT
Begin DoDot:1
+3 SET LRISO=0
+4 FOR
SET LRISO=$ORDER(^LAH(LRLL,1,LRIK,3,LRISO))
if +LRISO'>0
QUIT
Begin DoDot:2
+5 SET LRDRUG=0
+6 FOR
SET LRDRUG=$ORDER(^LAH(LRLL,1,LRIK,3,LRISO,LRDRUG))
if +LRDRUG'>0
QUIT
Begin DoDot:3
+7 IF $GET(^LAH(LRLL,1,LRPC,3,LRISO,LRDRUG))=^LAH(LRLL,1,LRIK,3,LRISO,LRDRUG)
Begin DoDot:4
+8 KILL ^LAH(LRLL,1,LRIK)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT
GLEEP ;
+1 ; This block removes all ^LR except logging node and comments
+2 KILL DIR
+3 WRITE !
+4 SET DIR(0)="Y"
+5 SET DIR("A")=" Shall I delete this data?: "
+6 SET DIR("B")="Yes"
+7 DO ^DIR
+8 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=0)
SET OK=0
QUIT
+9 KILL ^LR(LRDFN,LRSUB,LRIDT,3)
+10 KILL ^LR(LRDFN,LRSUB,LRIDT,1)
+11 ; This is optional.-----\/
+12 WRITE @IOF
+13 SET LRJOB=" REMOVING ^LR DATA"
+14 DO JOBTIME
+15 QUIT
JOBTIME ;
+1 ;CAN BE USED INSTEAD OF dots TO SHOW USER HOW JOB IS PROCEEDING
+2 DO ENS^%ZISS
SET %ZIS="I"
+3 WRITE !!,IODHLT,LRJOB,!,IODHLB,LRJOB
+4 SET DX=2
SET DY=10
XECUTE IOXY
+5 ;add a factor here as job proceeds
FOR I=1:1:35
SET DX=I*2+2
SET DY=16
XECUTE IOXY
Begin DoDot:1
+6 SET DX=2*(2+I)
SET DY=10
XECUTE IOXY
+7 WRITE IORVON
+8 WRITE "->"
+9 WRITE IORVOFF
+10 SET DX=16
SET DY=17
XECUTE IOXY
+11 WRITE IODHLT,2*($EXTRACT((I/70)*100,1,4)),"% "
+12 SET DX=16
SET DY=18
XECUTE IOXY
+13 WRITE IODHLB,2*($EXTRACT((I/70)*100,1,4)),"% "
End DoDot:1
+14 WRITE !!,IODHLT,"DONE",!,IODHLB,"DONE"
+15 DO KILL^%ZISS
+16 QUIT
