- LAMIAUT8 ;FHS/SLC - ADD OR DELETE FROM VITEK LOAD LIST ;7/20/90 09:35
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**81**;Sep 27, 1994;Build 2
- ADD ;
- I '$D(^LRO(68,LRAA,1,LRAD,1,X,0)) W !,$C(7),"THIS IS NOT A VALID ACCESSION NUMBER " Q
- S ^TMP("LR",$J,"T",X)=+^(0)_U_+(^(5,1,0)) W !," <<< ADDED >>> ",! Q
- Q
- DELETE ;
- I '$D(^TMP("LR",$J,"T",X)) W !,$C(7),"THIS NUMBER IS NOT ON THE LIST " Q
- K ^TMP("LR",$J,"T",X) W !," <<< DELETED >>> ",! Q
- Q
- STUFF ;
- S LRAA=$S(LRALL:$P(^LRO(68.2,LRINST,10,+$O(^LRO(68.2,LRINST,10,0)),0),U,2),1:$P(^LRO(68.2,LRINST,10,LRPROF,0),U,2))
- S:'$D(^LRO(68.2,LRINST,1,0)) ^(0)="^68.21^"
- F LRAN=0:0 S LRAN=$O(^TMP("LR",$J,"T",LRAN)) Q:LRAN<1 S LRSPEC=$P(^(LRAN),U,2) D STUFF1 I $O(X(0)) D STUFF3
- S $P(^LRO(68.2,LRINST,2),U,4)=LRTRAY,$P(^(2),U,5)=LRCUP,$P(^(2),U)=DT
- Q
- STUFF1 ;
- K X F AA=0:0 S AA=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,AA)) Q:AA<1 I $D(^(AA,0)) S LRURG=$S($P(^(0),U,2):$P(^(0),U,2),1:9) I $D(LRTP(AA)) D STUFF2
- Q
- STUFF2 ;
- I LRTP(AA) Q:LRSPEC=LRTP(AA)
- S X(AA)=AA_U_LRURG,X(AA,$O(LRTP(AA,0)))="" Q
- STUFF3 ;
- X LRTRANS I '$D(^LRO(68.2,LRINST,1,LRTRAY,0)) S ^(0)=LRTRAY_U_DT_U_DUZ_U_LRAA,$P(^LRO(68.2,LRINST,1,0),U,3)=LRTRAY,$P(^(0),U,4)=$P(^(0),U,4)+1 W !,"B"
- S:'$D(^LRO(68.2,LRINST,1,LRTRAY,1,0)) ^(0)="^68.22PA^1^1"
- I '$D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,0)) S ^(0)="^68.222^" W "."
- S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)=LRAA_U_LRAD_U_LRAN_U_$O(LRTP($O(X(0)),0))_U_LRSPEC
- F X=0:0 S X=$O(X(X)) Q:X="" S ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,X,0)=X(X),$P(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,0),U,3)=X,$P(^(0),U,4)=$P(^(0),U,4)+1 D LRO
- Q
- LRO S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,X,0),U,3)=LRINST_";"_LRTRAY_";"_LRCUP Q ;LA*5.2*81 change LRAN,1,4 to LRAN,4 for node/piece set
- Q
- PROF ;
- S LRAA=$S($D(^LRO(68.2,LRINST,10,1,0)):+$P(^(0),U,2),1:0) I 'LRAA W !!?10,"NO ACCESSION AREA ASSIGNED " S LREND=1 Q
- S Y(0)=^LRO(68,LRAA,0) I $P(Y(0),U,14) S LRP=14 D ACCESS I LREND W !!?10,"Access denied to this Accession Area." Q
- F I=0:0 S I=$O(^LRO(68.2,LRINST,10,LRPROF,1,I)) Q:I<1 I $D(^(I,0)) S LRTP(+^(0))=$P(^(0),U,2),LRTP(+^(0),LRPROF)=""
- F T=0:0 S T=$O(^LRO(68.2,LRINST,10,LRPROF,2,T)) Q:T<1 F C=0:0 S C=$O(^LRO(68.2,LRINST,10,LRPROF,2,T,1,C)) Q:C<1 S LRCT=^(C,0) D CTRLTST S LRCTRL(T,C)=X
- F I=0:0 S I=$O(^LRO(68.2,LRINST,10,LRPROF,3,I)) Q:I<1 S LRDSPEC(+^(I,0))=""
- Q
- CTRLTST ;from LRLL1, LRLL2
- S X=LRCT_U F J=0:0 S J=$O(^LAB(62.3,LRCT,2,J)) Q:J<1 S Y=+^(J,0) S:$D(^LRO(68.2,LRINST,10,LRPROF,1,"B",+Y)) X=X_+Y_U
- I '$P(X,U,2) W !,"CONTROL ",$P(^LAB(62.3,+X,0),U,1)," HAS NO TEST FOR THIS PROFILE."
- Q
- CLEAR ;from LRLL
- W !,"WANT TO UNLOAD THE ",$S(LRTYPE:"LOAD",1:"WORK")," LIST FIRST" S %=2 D YN^DICN W:%=0 !,"If you're not sure, we'll skip it." W:%=-1 !,"Nothing cleared." S DUOUT=(%=-1) Q:%'=1
- D CLEAR^LRLLS3 S (LAST,^LRO(68.2,LRINST,2))=DT_"^1^1^0^0",$P(^(1,0),U,3,4)=0 F I=0:0 S I=$O(^LRO(68.2,LRINST,1,0)) Q:I<1 S $P(^(0),U,3)=I,$P(^(0),U,4)=I
- I LRTYPE W !,"Do you want to delete all unverified ",$P(^LRO(68.2,LRINST,0),U)," instrument data" S %=2 D YN^DICN S DUOUT=(%=-1) Q:%'=1 K ^LAH(LRINST)
- Q
- ACCESS ;
- S LRKEY=+$P(Y(0),U,LRP),LRKEY=$S($D(^DIC(19.1,LRKEY,0)):$P(^(0),U),1:0),LREND=$S($D(^XUSEC(LRKEY,DUZ)):0,1:1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAMIAUT8 3230 printed Apr 23, 2025@17:57:38 Page 2
- LAMIAUT8 ;FHS/SLC - ADD OR DELETE FROM VITEK LOAD LIST ;7/20/90 09:35
- +1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**81**;Sep 27, 1994;Build 2
- ADD ;
- +1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,X,0))
- WRITE !,$CHAR(7),"THIS IS NOT A VALID ACCESSION NUMBER "
- QUIT
- +2 SET ^TMP("LR",$JOB,"T",X)=+^(0)_U_+(^(5,1,0))
- WRITE !," <<< ADDED >>> ",!
- QUIT
- +3 QUIT
- DELETE ;
- +1 IF '$DATA(^TMP("LR",$JOB,"T",X))
- WRITE !,$CHAR(7),"THIS NUMBER IS NOT ON THE LIST "
- QUIT
- +2 KILL ^TMP("LR",$JOB,"T",X)
- WRITE !," <<< DELETED >>> ",!
- QUIT
- +3 QUIT
- STUFF ;
- +1 SET LRAA=$SELECT(LRALL:$PIECE(^LRO(68.2,LRINST,10,+$ORDER(^LRO(68.2,LRINST,10,0)),0),U,2),1:$PIECE(^LRO(68.2,LRINST,10,LRPROF,0),U,2))
- +2 if '$DATA(^LRO(68.2,LRINST,1,0))
- SET ^(0)="^68.21^"
- +3 FOR LRAN=0:0
- SET LRAN=$ORDER(^TMP("LR",$JOB,"T",LRAN))
- if LRAN<1
- QUIT
- SET LRSPEC=$PIECE(^(LRAN),U,2)
- DO STUFF1
- IF $ORDER(X(0))
- DO STUFF3
- +4 SET $PIECE(^LRO(68.2,LRINST,2),U,4)=LRTRAY
- SET $PIECE(^(2),U,5)=LRCUP
- SET $PIECE(^(2),U)=DT
- +5 QUIT
- STUFF1 ;
- +1 KILL X
- FOR AA=0:0
- SET AA=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,AA))
- if AA<1
- QUIT
- IF $DATA(^(AA,0))
- SET LRURG=$SELECT($PIECE(^(0),U,2):$PIECE(^(0),U,2),1:9)
- IF $DATA(LRTP(AA))
- DO STUFF2
- +2 QUIT
- STUFF2 ;
- +1 IF LRTP(AA)
- if LRSPEC=LRTP(AA)
- QUIT
- +2 SET X(AA)=AA_U_LRURG
- SET X(AA,$ORDER(LRTP(AA,0)))=""
- QUIT
- STUFF3 ;
- +1 XECUTE LRTRANS
- IF '$DATA(^LRO(68.2,LRINST,1,LRTRAY,0))
- SET ^(0)=LRTRAY_U_DT_U_DUZ_U_LRAA
- SET $PIECE(^LRO(68.2,LRINST,1,0),U,3)=LRTRAY
- SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
- WRITE !,"B"
- +2 if '$DATA(^LRO(68.2,LRINST,1,LRTRAY,1,0))
- SET ^(0)="^68.22PA^1^1"
- +3 IF '$DATA(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,0))
- SET ^(0)="^68.222^"
- WRITE "."
- +4 SET ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)=LRAA_U_LRAD_U_LRAN_U_$ORDER(LRTP($ORDER(X(0)),0))_U_LRSPEC
- +5 FOR X=0:0
- SET X=$ORDER(X(X))
- if X=""
- QUIT
- SET ^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,X,0)=X(X)
- SET $PIECE(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,0),U,3)=X
- SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
- DO LRO
- +6 QUIT
- LRO ;LA*5.2*81 change LRAN,1,4 to LRAN,4 for node/piece set
- SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,X,0),U,3)=LRINST_";"_LRTRAY_";"_LRCUP
- QUIT
- +1 QUIT
- PROF ;
- +1 SET LRAA=$SELECT($DATA(^LRO(68.2,LRINST,10,1,0)):+$PIECE(^(0),U,2),1:0)
- IF 'LRAA
- WRITE !!?10,"NO ACCESSION AREA ASSIGNED "
- SET LREND=1
- QUIT
- +2 SET Y(0)=^LRO(68,LRAA,0)
- IF $PIECE(Y(0),U,14)
- SET LRP=14
- DO ACCESS
- IF LREND
- WRITE !!?10,"Access denied to this Accession Area."
- QUIT
- +3 FOR I=0:0
- SET I=$ORDER(^LRO(68.2,LRINST,10,LRPROF,1,I))
- if I<1
- QUIT
- IF $DATA(^(I,0))
- SET LRTP(+^(0))=$PIECE(^(0),U,2)
- SET LRTP(+^(0),LRPROF)=""
- +4 FOR T=0:0
- SET T=$ORDER(^LRO(68.2,LRINST,10,LRPROF,2,T))
- if T<1
- QUIT
- FOR C=0:0
- SET C=$ORDER(^LRO(68.2,LRINST,10,LRPROF,2,T,1,C))
- if C<1
- QUIT
- SET LRCT=^(C,0)
- DO CTRLTST
- SET LRCTRL(T,C)=X
- +5 FOR I=0:0
- SET I=$ORDER(^LRO(68.2,LRINST,10,LRPROF,3,I))
- if I<1
- QUIT
- SET LRDSPEC(+^(I,0))=""
- +6 QUIT
- CTRLTST ;from LRLL1, LRLL2
- +1 SET X=LRCT_U
- FOR J=0:0
- SET J=$ORDER(^LAB(62.3,LRCT,2,J))
- if J<1
- QUIT
- SET Y=+^(J,0)
- if $DATA(^LRO(68.2,LRINST,10,LRPROF,1,"B",+Y))
- SET X=X_+Y_U
- +2 IF '$PIECE(X,U,2)
- WRITE !,"CONTROL ",$PIECE(^LAB(62.3,+X,0),U,1)," HAS NO TEST FOR THIS PROFILE."
- +3 QUIT
- CLEAR ;from LRLL
- +1 WRITE !,"WANT TO UNLOAD THE ",$SELECT(LRTYPE:"LOAD",1:"WORK")," LIST FIRST"
- SET %=2
- DO YN^DICN
- if %=0
- WRITE !,"If you're not sure, we'll skip it."
- if %=-1
- WRITE !,"Nothing cleared."
- SET DUOUT=(%=-1)
- if %'=1
- QUIT
- +2 DO CLEAR^LRLLS3
- SET (LAST,^LRO(68.2,LRINST,2))=DT_"^1^1^0^0"
- SET $PIECE(^(1,0),U,3,4)=0
- FOR I=0:0
- SET I=$ORDER(^LRO(68.2,LRINST,1,0))
- if I<1
- QUIT
- SET $PIECE(^(0),U,3)=I
- SET $PIECE(^(0),U,4)=I
- +3 IF LRTYPE
- WRITE !,"Do you want to delete all unverified ",$PIECE(^LRO(68.2,LRINST,0),U)," instrument data"
- SET %=2
- DO YN^DICN
- SET DUOUT=(%=-1)
- if %'=1
- QUIT
- KILL ^LAH(LRINST)
- +4 QUIT
- ACCESS ;
- +1 SET LRKEY=+$PIECE(Y(0),U,LRP)
- SET LRKEY=$SELECT($DATA(^DIC(19.1,LRKEY,0)):$PIECE(^(0),U),1:0)
- SET LREND=$SELECT($DATA(^XUSEC(LRKEY,DUZ)):0,1:1)
- +2 QUIT
