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

LAMIVTL4.m

Go to the documentation of this file. 
  1. LAMIVTL4 ;DAL/HOAK 4th Vitek literal verify rtn
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**12,31,40,83**;Sep 27,1994;Build 4
  1. INIT ;
  1.  I '$G(LRTS) S LRTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
  1.  I 'OK D GLEEP^LAMIVTL3 QUIT
  1.  S OK=1
  1. DR ; FROM LAMIAUT1 BY FHS
  1.  ;-----------------------------------------------------------------------
  1.  ; This block runs edit template for comment, final report, bact etc.
  1.  K DR,DIC,DIE,DA
  1.  S DA(1)=LRDFN
  1.  S DA=LRIDT
  1.  S Y(0)=^LR(LRDFN,"MI",LRIDT,0),DIE="^LR("_LRDFN_",""MI"","
  1.  S DR="11.55////^S X=DUZ;11.5;11.6;13"
  1.  D ^DIE
  1.  ;-----------------------------------------------------------------------
  1.  S LREND=0
  1.  D ^LAMIAUT3 Q:LREND
  1.  D VERIFY
  1.  L -(^LR(LRDFN,"MI",LRIDT),^LRO(68,LRAA,1,LRAD,1,LRAN))
  1.  Q
  1. VERIFY ;
  1.  R !!," ('E'dit data, 'C'omments, 'O'rganism 'W'orklist) // ",LREDIT:DTIME
  1.  I '$T D GLEEP^LAMIVTL3 S OK=0 QUIT
  1.  I $E(LREDIT)="?" D HLP^LAMIAUT4,^LAMIAUT3 G VERIFY
  1.  I $E(LREDIT)="^"!($E(LREDIT="@")) D GLEEP^LAMIVTL3 S OK=0 K LRBDUP,LRMOVE Q
  1.  K DIC,DR,DIE,DA
  1.  S DA=LRIDT,DA(1)=LRDFN
  1.  S LRY(0)=^LR(LRDFN,"MI",LRIDT,0)
  1.  S DIE="^LR("_DA(1)_",""MI"",",DIC=DIE
  1.  I $E(LREDIT)="E" S ZX9=X9 D EDIT^LAMIAUT4,^LAMIAUT3 S X9=ZX9 K ZX9 G VERIFY
  1.  I $E(LREDIT)="O" S ZX9=X9 D ^LRMIBUG,^LAMIAUT3 S X9=ZX9 K ZX9 G VERIFY
  1.  I $E(LREDIT)="C" K DR S DR=".99;1;13" D ^DIE D ^LAMIAUT3 G VERIFY
  1.  I $E(LREDIT)="W" D EN^LRCAPV D ^LAMIAUT3 G VERIFY
  1.  R !,"Approve for release by entering your initials: ",X:DTIME
  1.  I '$T!($E(X)="^") D GLEEP^LAMIVTL3 Q
  1.  I X'=LRINI W !!,$C(7)," NOT APPROVED " Q
  1.  I X=LRINI W !!,"Approved for Release" D VER D  QUIT
  1.  .  ;time stamp
  1.  .  D NOW^%DTC
  1.  .  S $P(^LR(LRDFN,LRSUB,LRIDT,0),U,3)=%,$P(^(0),U,4)=$G(DUZ)
  1.  .  S $P(^LR(LRDFN,LRSUB,LRIDT,1),U)=DT
  1.  .  S LRODT=$P(^LR(LRDFN,LRSUB,LRIDT,0),U),LRODT=$P(LRODT,".")
  1.  .  I $G(LRORGCNT) D
  1.  ..  I $D(^LR(LRDFN,LRSUB,LRIDT,3,0)) S LRN12=$G(^(0)) D
  1.  ...  S LRORGCNT=$P($G(LRN12),U,4)+LRORGCNT
  1.  ..  S ^LR(LRDFN,LRSUB,LRIDT,3,0)=U_"63.3PA"_U_LRORGCNT_U_LRORGCNT
  1.  .  S ^LRO(69,LRODT,1,"AL",LRLLOC,PNM,LRDFN)=""
  1.  .  S ^LRO(69,LRODT,1,"AN",LRLLOC,LRDFN,LRIDT)=""
  1.  .  S ^LRO(69,LRODT,1,"AP",LRPHYN,PNM,LRDFN)=""
  1.  .  S ^LRO(69,LRODT,1,"AR",LRLLOC,PNM,LRDFN)=""
  1.  .  S $P(^LRO(69,LRODT,1,LRSN,3),U,2)=%
  1.  ;-----------------------------------------------------------------
  1. VER ;Final report after initials
  1.  S LRSS=LRSUB
  1.  S LRUNDO=1
  1.  ;
  1.  S LRDPF=2,LRSSD=LRAA,LRACC="",LRADDF=LRSUB,LRORCOM=""
  1.  Q:'$G(LRBUX)
  1.  S LRORG(+LRBUX)=LRORGCNT
  1.  S LRORGN=+LRBUX
  1.  S LAMIAUTO=1
  1.  S LAMIAUT0=1
  1.  ;
  1.  S LRFIFO=0
  1.  S T1=1
  1.  D VER1 Q
  1. TIC ;
  1.  ;
  1.  ;I '$D(X9) S X9="F T1=1 "
  1.  N LRBG0
  1.  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
  1.  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"
  1.  F I=0:0 W !?10,"OK" S %=1 D YN^DICN Q:%  W !," Enter  'Y' or 'N' : "
  1.  I %=2!(%<0) Q
  1. VER1 ;
  1.  S LRCAPOK=1
  1.  S LRT=LRTS
  1.  I '$L(LRT) S LRTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
  1.  S LRCB7=LRIFN
  1.  D:'$P(^LAB(69.9,1,"NITE"),U) ANN^LRCAPV
  1.  ;N LRADD,GLB,LRBUG,LRBUGY
  1.  S LRSB=1
  1.  W !
  1.  X (X9_"S LRPTP=$O(LRNAME(T1,0))")
  1.  S LRCAPOK=1,Y(0)=^LR(LRDFN,"MI",LRIDT,0) D
  1.  .  K DR
  1.  .  S DR=11,LRSAME=0
  1.  .  D:LRUNDO UNDO^LRMIEDZ
  1.  .  I $G(^LAB(61.38,1,4))'>0 D
  1.  ..  S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTS,0),U,5)=""
  1.  .  D ^DIE,TIME^LRMIEDZ3
  1.  .  S LRTS=LRPTP I $G(LRTS) I LRCAPOK&($P(LRPARAM,U,14)) D
  1.  ..  S LRIFN=0
  1.  ..  S LRIFN=$O(LRIFN(LRIFN)) Q:LRIFN=""  D WKLD
  1.  ;
  1.  ;
  1.  ;
  1.  N LRWRDVEW
  1.  S LRWRDVEW=1
  1.  D VT^LRMIUT1 I $L($G(LRVT)) D STF^LRMIUT
  1.  S ^LRO(68,"AVS",LRAA,LRAD,LRAN)=LRDFN_U_LRIDT
  1.  K ^LAH(LRLL,1,"C",LRAN)
  1.  S LRPLA=0
  1.  ;-->make certain we get'em all
  1.  F  S LRPLA=$O(^LAH(LRLL,1,"C",LRAN,LRPLA)) Q:+LRPLA'>0  K ^(LRAN,LRPLA)
  1.  D END^LAMIVTL0
  1.  W @IOF D S1^LAMIVTL0 W !!
  1.  Q
  1.  ;             VITEK WORKLOAD----ETIOLOGY
  1. WKLD ;
  1.  D LOOK^LRCAPV1
  1.  Q
  1.  S LRT=LRTS
  1.  S LRPLUK=0
  1.  F  S LRPLUK=$O(^LAH(LRLL,1,LRPLUK)) Q:+LRPLUK'>0  D
  1.  .  Q:$P(^LAH(LRLL,1,LRPLUK,0),U,5)'=LRAN
  1.  .  S LRORG=0
  1.  .  S LRIFN=LRPLUK
  1.  .  F  S LRORG=$O(^LAH(LRLL,1,LRIFN,3,LRORG)) K LRADD Q:LRORG<1  D
  1.  ..  I $D(^LAH(LRLL,1,LRIFN,3,LRORG,0))#2 S LRGB1=+^(0) D
  1.  ...  S GLB="^LAB(61.2,LRGB1,9,A)",LRADD=""
  1.  ...  D DISP1 Q:'$G(LRIFN)  D ETIOL^LRCAPV1
  1.  K GLB
  1.  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
  1.  Q
  1. DISP1 ;
  1.  W !,"PROCESSING: ",^LAB(61.2,LRGB1,0),?60,$G(LRCODE)
  1.  Q