LAMIVTL4 ;DAL/HOAK 4th Vitek literal verify rtn
;;5.2;AUTOMATED LAB INSTRUMENTS;**12,31,40,83**;Sep 27,1994;Build 4
INIT ;
I '$G(LRTS) S LRTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
I 'OK D GLEEP^LAMIVTL3 QUIT
S OK=1
DR ; FROM LAMIAUT1 BY FHS
;-----------------------------------------------------------------------
; This block runs edit template for comment, final report, bact etc.
K DR,DIC,DIE,DA
S DA(1)=LRDFN
S DA=LRIDT
S Y(0)=^LR(LRDFN,"MI",LRIDT,0),DIE="^LR("_LRDFN_",""MI"","
S DR="11.55////^S X=DUZ;11.5;11.6;13"
D ^DIE
;-----------------------------------------------------------------------
S LREND=0
D ^LAMIAUT3 Q:LREND
D VERIFY
L -(^LR(LRDFN,"MI",LRIDT),^LRO(68,LRAA,1,LRAD,1,LRAN))
Q
VERIFY ;
R !!," ('E'dit data, 'C'omments, 'O'rganism 'W'orklist) // ",LREDIT:DTIME
I '$T D GLEEP^LAMIVTL3 S OK=0 QUIT
I $E(LREDIT)="?" D HLP^LAMIAUT4,^LAMIAUT3 G VERIFY
I $E(LREDIT)="^"!($E(LREDIT="@")) D GLEEP^LAMIVTL3 S OK=0 K LRBDUP,LRMOVE Q
K DIC,DR,DIE,DA
S DA=LRIDT,DA(1)=LRDFN
S LRY(0)=^LR(LRDFN,"MI",LRIDT,0)
S DIE="^LR("_DA(1)_",""MI"",",DIC=DIE
I $E(LREDIT)="E" S ZX9=X9 D EDIT^LAMIAUT4,^LAMIAUT3 S X9=ZX9 K ZX9 G VERIFY
I $E(LREDIT)="O" S ZX9=X9 D ^LRMIBUG,^LAMIAUT3 S X9=ZX9 K ZX9 G VERIFY
I $E(LREDIT)="C" K DR S DR=".99;1;13" D ^DIE D ^LAMIAUT3 G VERIFY
I $E(LREDIT)="W" D EN^LRCAPV D ^LAMIAUT3 G VERIFY
R !,"Approve for release by entering your initials: ",X:DTIME
I '$T!($E(X)="^") D GLEEP^LAMIVTL3 Q
I X'=LRINI W !!,$C(7)," NOT APPROVED " Q
I X=LRINI W !!,"Approved for Release" D VER D QUIT
. ;time stamp
. D NOW^%DTC
. S $P(^LR(LRDFN,LRSUB,LRIDT,0),U,3)=%,$P(^(0),U,4)=$G(DUZ)
. S $P(^LR(LRDFN,LRSUB,LRIDT,1),U)=DT
. S LRODT=$P(^LR(LRDFN,LRSUB,LRIDT,0),U),LRODT=$P(LRODT,".")
. I $G(LRORGCNT) D
.. I $D(^LR(LRDFN,LRSUB,LRIDT,3,0)) S LRN12=$G(^(0)) D
... S LRORGCNT=$P($G(LRN12),U,4)+LRORGCNT
.. S ^LR(LRDFN,LRSUB,LRIDT,3,0)=U_"63.3PA"_U_LRORGCNT_U_LRORGCNT
. S ^LRO(69,LRODT,1,"AL",LRLLOC,PNM,LRDFN)=""
. S ^LRO(69,LRODT,1,"AN",LRLLOC,LRDFN,LRIDT)=""
. S ^LRO(69,LRODT,1,"AP",LRPHYN,PNM,LRDFN)=""
. S ^LRO(69,LRODT,1,"AR",LRLLOC,PNM,LRDFN)=""
. S $P(^LRO(69,LRODT,1,LRSN,3),U,2)=%
;-----------------------------------------------------------------
VER ;Final report after initials
S LRSS=LRSUB
S LRUNDO=1
;
S LRDPF=2,LRSSD=LRAA,LRACC="",LRADDF=LRSUB,LRORCOM=""
Q:'$G(LRBUX)
S LRORG(+LRBUX)=LRORGCNT
S LRORGN=+LRBUX
S LAMIAUTO=1
S LAMIAUT0=1
;
S LRFIFO=0
S T1=1
D VER1 Q
TIC ;
;
;I '$D(X9) S X9="F T1=1 "
N LRBG0
Q:X9="" S (LRBG0,Y(0))=^LR(LRDFN,"MI",LRIDT,0),LRCAPOK=1,LRUNDO=0 I '$P(Y(0),U,3) S:$P(Y(0),U,9) LRUNDO=1 G VER1
I $P(^LR(LRDFN,"MI",LRIDT,0),U,3) W !,"Final report has been verified by micro supervisor,",$C(7),!,"If you proceed in editing, the report will be reprinted"
F I=0:0 W !?10,"OK" S %=1 D YN^DICN Q:% W !," Enter 'Y' or 'N' : "
I %=2!(%<0) Q
VER1 ;
S LRCAPOK=1
S LRT=LRTS
I '$L(LRT) S LRTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
S LRCB7=LRIFN
D:'$P(^LAB(69.9,1,"NITE"),U) ANN^LRCAPV
;N LRADD,GLB,LRBUG,LRBUGY
S LRSB=1
W !
X (X9_"S LRPTP=$O(LRNAME(T1,0))")
S LRCAPOK=1,Y(0)=^LR(LRDFN,"MI",LRIDT,0) D
. K DR
. S DR=11,LRSAME=0
. D:LRUNDO UNDO^LRMIEDZ
. I $G(^LAB(61.38,1,4))'>0 D
.. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0),U,5)=""
. D ^DIE,TIME^LRMIEDZ3
. S LRTS=LRPTP I $G(LRTS) I LRCAPOK&($P(LRPARAM,U,14)) D
.. S LRIFN=0
.. S LRIFN=$O(LRIFN(LRIFN)) Q:LRIFN="" D WKLD
;
;
;
N LRWRDVEW
S LRWRDVEW=1
D VT^LRMIUT1 I $L($G(LRVT)) D STF^LRMIUT
S ^LRO(68,"AVS",LRAA,LRAD,LRAN)=LRDFN_U_LRIDT
K ^LAH(LRLL,1,"C",LRAN)
S LRPLA=0
;-->make certain we get'em all
F S LRPLA=$O(^LAH(LRLL,1,"C",LRAN,LRPLA)) Q:+LRPLA'>0 K ^(LRAN,LRPLA)
D END^LAMIVTL0
W @IOF D S1^LAMIVTL0 W !!
Q
; VITEK WORKLOAD----ETIOLOGY
WKLD ;
D LOOK^LRCAPV1
Q
S LRT=LRTS
S LRPLUK=0
F S LRPLUK=$O(^LAH(LRLL,1,LRPLUK)) Q:+LRPLUK'>0 D
. Q:$P(^LAH(LRLL,1,LRPLUK,0),U,5)'=LRAN
. S LRORG=0
. S LRIFN=LRPLUK
. F S LRORG=$O(^LAH(LRLL,1,LRIFN,3,LRORG)) K LRADD Q:LRORG<1 D
.. I $D(^LAH(LRLL,1,LRIFN,3,LRORG,0))#2 S LRGB1=+^(0) D
... S GLB="^LAB(61.2,LRGB1,9,A)",LRADD=""
... D DISP1 Q:'$G(LRIFN) D ETIOL^LRCAPV1
K GLB
F W !!?10,"(D)isplay (A)dd Work Load " R X:DTIME S X=$E(X) S:'$T!(X=U)!(X="") LREND=1 Q:X="A"!(LREND) D:X="D" DIS^LRCAPU
Q
DISP1 ;
W !,"PROCESSING: ",^LAB(61.2,LRGB1,0),?60,$G(LRCODE)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAMIVTL4 4492 printed Dec 13, 2024@01:43:29 Page 2
LAMIVTL4 ;DAL/HOAK 4th Vitek literal verify rtn
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**12,31,40,83**;Sep 27,1994;Build 4
INIT ;
+1 IF '$GET(LRTS)
SET LRTS=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
+2 IF 'OK
DO GLEEP^LAMIVTL3
QUIT
+3 SET OK=1
DR ; FROM LAMIAUT1 BY FHS
+1 ;-----------------------------------------------------------------------
+2 ; This block runs edit template for comment, final report, bact etc.
+3 KILL DR,DIC,DIE,DA
+4 SET DA(1)=LRDFN
+5 SET DA=LRIDT
+6 SET Y(0)=^LR(LRDFN,"MI",LRIDT,0)
SET DIE="^LR("_LRDFN_",""MI"","
+7 SET DR="11.55////^S X=DUZ;11.5;11.6;13"
+8 DO ^DIE
+9 ;-----------------------------------------------------------------------
+10 SET LREND=0
+11 DO ^LAMIAUT3
if LREND
QUIT
+12 DO VERIFY
+13 LOCK -(^LR(LRDFN,"MI",LRIDT),^LRO(68,LRAA,1,LRAD,1,LRAN))
+14 QUIT
VERIFY ;
+1 READ !!," ('E'dit data, 'C'omments, 'O'rganism 'W'orklist) // ",LREDIT:DTIME
+2 IF '$TEST
DO GLEEP^LAMIVTL3
SET OK=0
QUIT
+3 IF $EXTRACT(LREDIT)="?"
DO HLP^LAMIAUT4
DO ^LAMIAUT3
GOTO VERIFY
+4 IF $EXTRACT(LREDIT)="^"!($EXTRACT(LREDIT="@"))
DO GLEEP^LAMIVTL3
SET OK=0
KILL LRBDUP,LRMOVE
QUIT
+5 KILL DIC,DR,DIE,DA
+6 SET DA=LRIDT
SET DA(1)=LRDFN
+7 SET LRY(0)=^LR(LRDFN,"MI",LRIDT,0)
+8 SET DIE="^LR("_DA(1)_",""MI"","
SET DIC=DIE
+9 IF $EXTRACT(LREDIT)="E"
SET ZX9=X9
DO EDIT^LAMIAUT4
DO ^LAMIAUT3
SET X9=ZX9
KILL ZX9
GOTO VERIFY
+10 IF $EXTRACT(LREDIT)="O"
SET ZX9=X9
DO ^LRMIBUG
DO ^LAMIAUT3
SET X9=ZX9
KILL ZX9
GOTO VERIFY
+11 IF $EXTRACT(LREDIT)="C"
KILL DR
SET DR=".99;1;13"
DO ^DIE
DO ^LAMIAUT3
GOTO VERIFY
+12 IF $EXTRACT(LREDIT)="W"
DO EN^LRCAPV
DO ^LAMIAUT3
GOTO VERIFY
+13 READ !,"Approve for release by entering your initials: ",X:DTIME
+14 IF '$TEST!($EXTRACT(X)="^")
DO GLEEP^LAMIVTL3
QUIT
+15 IF X'=LRINI
WRITE !!,$CHAR(7)," NOT APPROVED "
QUIT
+16 IF X=LRINI
WRITE !!,"Approved for Release"
DO VER
Begin DoDot:1
+17 ;time stamp
+18 DO NOW^%DTC
+19 SET $PIECE(^LR(LRDFN,LRSUB,LRIDT,0),U,3)=%
SET $PIECE(^(0),U,4)=$GET(DUZ)
+20 SET $PIECE(^LR(LRDFN,LRSUB,LRIDT,1),U)=DT
+21 SET LRODT=$PIECE(^LR(LRDFN,LRSUB,LRIDT,0),U)
SET LRODT=$PIECE(LRODT,".")
+22 IF $GET(LRORGCNT)
Begin DoDot:2
+23 IF $DATA(^LR(LRDFN,LRSUB,LRIDT,3,0))
SET LRN12=$GET(^(0))
Begin DoDot:3
+24 SET LRORGCNT=$PIECE($GET(LRN12),U,4)+LRORGCNT
End DoDot:3
+25 SET ^LR(LRDFN,LRSUB,LRIDT,3,0)=U_"63.3PA"_U_LRORGCNT_U_LRORGCNT
End DoDot:2
+26 SET ^LRO(69,LRODT,1,"AL",LRLLOC,PNM,LRDFN)=""
+27 SET ^LRO(69,LRODT,1,"AN",LRLLOC,LRDFN,LRIDT)=""
+28 SET ^LRO(69,LRODT,1,"AP",LRPHYN,PNM,LRDFN)=""
+29 SET ^LRO(69,LRODT,1,"AR",LRLLOC,PNM,LRDFN)=""
+30 SET $PIECE(^LRO(69,LRODT,1,LRSN,3),U,2)=%
End DoDot:1
QUIT
+31 ;-----------------------------------------------------------------
VER ;Final report after initials
+1 SET LRSS=LRSUB
+2 SET LRUNDO=1
+3 ;
+4 SET LRDPF=2
SET LRSSD=LRAA
SET LRACC=""
SET LRADDF=LRSUB
SET LRORCOM=""
+5 if '$GET(LRBUX)
QUIT
+6 SET LRORG(+LRBUX)=LRORGCNT
+7 SET LRORGN=+LRBUX
+8 SET LAMIAUTO=1
+9 SET LAMIAUT0=1
+10 ;
+11 SET LRFIFO=0
+12 SET T1=1
+13 DO VER1
QUIT
TIC ;
+1 ;
+2 ;I '$D(X9) S X9="F T1=1 "
+3 NEW LRBG0
+4 if X9=""
QUIT
SET (LRBG0,Y(0))=^LR(LRDFN,"MI",LRIDT,0)
SET LRCAPOK=1
SET LRUNDO=0
IF '$PIECE(Y(0),U,3)
if $PIECE(Y(0),U,9)
SET LRUNDO=1
GOTO VER1
+5 IF $PIECE(^LR(LRDFN,"MI",LRIDT,0),U,3)
WRITE !,"Final report has been verified by micro supervisor,",$CHAR(7),!,"If you proceed in editing, the report will be reprinted"
+6 FOR I=0:0
WRITE !?10,"OK"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !," Enter 'Y' or 'N' : "
+7 IF %=2!(%<0)
QUIT
VER1 ;
+1 SET LRCAPOK=1
+2 SET LRT=LRTS
+3 IF '$LENGTH(LRT)
SET LRTS=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
+4 SET LRCB7=LRIFN
+5 if '$PIECE(^LAB(69.9,1,"NITE"),U)
DO ANN^LRCAPV
+6 ;N LRADD,GLB,LRBUG,LRBUGY
+7 SET LRSB=1
+8 WRITE !
+9 XECUTE (X9_"S LRPTP=$O(LRNAME(T1,0))")
+10 SET LRCAPOK=1
SET Y(0)=^LR(LRDFN,"MI",LRIDT,0)
Begin DoDot:1
+11 KILL DR
+12 SET DR=11
SET LRSAME=0
+13 if LRUNDO
DO UNDO^LRMIEDZ
+14 IF $GET(^LAB(61.38,1,4))'>0
Begin DoDot:2
+15 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0),U,5)=""
End DoDot:2
+16 DO ^DIE
DO TIME^LRMIEDZ3
+17 SET LRTS=LRPTP
IF $GET(LRTS)
IF LRCAPOK&($PIECE(LRPARAM,U,14))
Begin DoDot:2
+18 SET LRIFN=0
+19 SET LRIFN=$ORDER(LRIFN(LRIFN))
if LRIFN=""
QUIT
DO WKLD
End DoDot:2
End DoDot:1
+20 ;
+21 ;
+22 ;
+23 NEW LRWRDVEW
+24 SET LRWRDVEW=1
+25 DO VT^LRMIUT1
IF $LENGTH($GET(LRVT))
DO STF^LRMIUT
+26 SET ^LRO(68,"AVS",LRAA,LRAD,LRAN)=LRDFN_U_LRIDT
+27 KILL ^LAH(LRLL,1,"C",LRAN)
+28 SET LRPLA=0
+29 ;-->make certain we get'em all
+30 FOR
SET LRPLA=$ORDER(^LAH(LRLL,1,"C",LRAN,LRPLA))
if +LRPLA'>0
QUIT
KILL ^(LRAN,LRPLA)
+31 DO END^LAMIVTL0
+32 WRITE @IOF
DO S1^LAMIVTL0
WRITE !!
+33 QUIT
+34 ; VITEK WORKLOAD----ETIOLOGY
WKLD ;
+1 DO LOOK^LRCAPV1
+2 QUIT
+3 SET LRT=LRTS
+4 SET LRPLUK=0
+5 FOR
SET LRPLUK=$ORDER(^LAH(LRLL,1,LRPLUK))
if +LRPLUK'>0
QUIT
Begin DoDot:1
+6 if $PIECE(^LAH(LRLL,1,LRPLUK,0),U,5)'=LRAN
QUIT
+7 SET LRORG=0
+8 SET LRIFN=LRPLUK
+9 FOR
SET LRORG=$ORDER(^LAH(LRLL,1,LRIFN,3,LRORG))
KILL LRADD
if LRORG<1
QUIT
Begin DoDot:2
+10 IF $DATA(^LAH(LRLL,1,LRIFN,3,LRORG,0))#2
SET LRGB1=+^(0)
Begin DoDot:3
+11 SET GLB="^LAB(61.2,LRGB1,9,A)"
SET LRADD=""
+12 DO DISP1
if '$GET(LRIFN)
QUIT
DO ETIOL^LRCAPV1
End DoDot:3
End DoDot:2
End DoDot:1
+13 KILL GLB
+14 FOR
WRITE !!?10,"(D)isplay (A)dd Work Load "
READ X:DTIME
SET X=$EXTRACT(X)
if '$TEST!(X=U)!(X="")
SET LREND=1
if X="A"!(LREND)
QUIT
if X="D"
DO DIS^LRCAPU
+15 QUIT
DISP1 ;
+1 WRITE !,"PROCESSING: ",^LAB(61.2,LRGB1,0),?60,$GET(LRCODE)
+2 QUIT
