LRLLS ;SLC/RWF-LOAD LIST FIX UP ;8/17/87 11:16
;;5.2;LAB SERVICE;**116,221**;Sep 27, 1994
LRINST ;from LRLLS2
S U="^" D DT^LRX S LRAD=DT K ^TMP("LR",$J,"T"),DIC,LRHOLD,LRTSTS
S DIC="^LRO(68.2,",DIC(0)="AEMZ",DIC("S")="S %=$P(^(0),U,12) X ""I '$L(%)"" Q:$T S %=$P(^DIC(19.1,%,0),U,1) I $D(^XUSEC(%,DUZ))" D ^DIC K DIC S LRINST=+Y Q:Y<1
S LRTRANS=+$P(Y(0),U,2),LRTYPE=+$P(Y(0),U,3),LRFULL=$P(Y(0),U,5),LRINSTIT=+$P(Y(0),U,7),LRMAXCUP=+$P(Y(0),U,4)
S LRTRANS=$S($D(^LAB(62.07,LRTRANS,.1)):^(.1),1:"S LRCUP=LRCUP+1"),LRINSTIT=$S($D(^LAB(62.07,LRINSTIT,.1)):^(.1),1:"Q")
Q
EN ;
INSERT ;INSERT A SAMPLE ON TO A TRAY
D END D LRINST G END:LRINST<1 D PROFILE G END:+$G(LRWPROF)<1
IN2 S LRACC=1 S:+$G(LRWPROF)<1 LRWPROF=0 D ^LRWU4 K LRACC G END:LRAN<1
D SHOW W !?15 S %=1 D YN^DICN G NOP:%<1,IN2:%=2
K ^TMP("LR",$J,"T"),LRTSTS D WHATEST G NOP:'$D(X),NOP:X=U
IN5 D PCUP G NOP:LRCUP[U D LIFT,SETONE W !!," >> INSERTED <<" I LRHOLD'="" W !,"NOW WHAT TO DO WITH" D NOW,SHOW G IN5
Q
LIFT K LRHOLD S LRHOLD=$S($D(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:"") Q:LRHOLD=""
F I=0:0 S I=$O(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,I)) Q:I<1 S LRHOLD(I)=^(I,0)
IF $D(^LRO(68,+$P(LRHOLD,U,1),1,+$P(LRHOLD,U,2),1,+$P(LRHOLD,U,3),0))[0 S LRHOLD=""
D DROP Q
NOW Q:LRHOLD="" K ^TMP("LR",$J,"T"),LRTSTS S LRAA=+LRHOLD,LRAD=$P(LRHOLD,U,2),LRAN=$P(LRHOLD,U,3),LRWPROF=$P(LRHOLD,U,4)
W:$D(^LRO(68,LRAA,1,+LRAD,1,+LRAN,.2)) " ACCESSION: ",^(.2)
F I=0:0 S I=$O(LRHOLD(I)) Q:I<1 S ^TMP("LR",$J,"T",I)=LRHOLD(I)
Q
PCUP S W="PUT THE SAMPLE IN " G CP1
GCUP S W="REMOVE THE SAMPLE FROM "
CP1 I 'LRTYPE S LRTRAY=1 W !,W,"SEQUENCE #: " R LRCUP:DTIME G CP4:LRCUP[U!(LRCUP=""),CPSH:+LRCUP'=LRCUP Q
CP2 W !,W,"TRAY: " R LRTRAY:DTIME G CP4:LRTRAY[U!(LRTRAY="") R " CUP: ",LRCUP:DTIME G CP4:LRCUP[U!(LRCUP=""),CPTH:+LRTRAY'=LRTRAY,CPTH:+LRCUP'=LRCUP Q
CP4 S LRCUP=U K W Q
CPSH W !,"Enter the SEQUENCE # to use." G CP1
CPTH W !,"Enter the TRAY or CUP that you want to use." G CP1
EN01 ;
CLEAR ; Clear data from LAH
N DIR,DIRUT,DTOUT,DUOUT,LRCNT,LRCUTDT,LREND,LRINST,LRISQN,LRCTYPE,X,Y
S DT=$$DT^XLFDT
S (LRCUTDT,LREND)=0
D LRINST
I LRINST<1 D END Q
I '$D(^LAH(LRINST)) D Q
. W !!,$C(7),"<<< No data in LAH global for this load/work list >>>",!
. D NOP
W !
L +^LAH(LRINST):1
I '$T D Q
. W !!,$C(7),"<<< Unable to lock global, try again later >>>",!
. D NOP
S DIR(0)="SO^0:All Results for this Load/Worklist;1:By Date Results First Received;2:By Date Results Last Updated",DIR("A")="Clear Results"
S DIR("?",1)="All results can be cleared or results can"
S DIR("?")="be cleared by date received or last updated."
D ^DIR
I $D(DIRUT) D UNLAH(LRINST),END Q
S LRCTYPE=+Y
I LRCTYPE D
. W !
. S DIR(0)="DO^:NOW:AEPTX",DIR("A")="Select Cutoff Date/Time",DIR("B")="T-1"
. S DIR("?",1)="Enter a date or a date/time."
. S DIR("?",2)="Date selected must be on or before "_$$HTE^XLFDT($H,"1")
. S DIR("?")="Results before this date/time will be removed from Load/Worklist "_$P($G(^LRO(68.2,+LRINST,0)),"^")_"."
. D ^DIR
. I $D(DIRUT) S LREND=1 Q
. S LRCUTDT=Y
I LREND D UNLAH(LRINST),NOP Q
W !
S DIR(0)="YO",DIR("B")="NO"
S DIR("A",1)="For Load/Worklist "_$P($G(^LRO(68.2,LRINST,0)),"^")_" clear "_$S(LRCUTDT:"results before "_$$FMTE^XLFDT(LRCUTDT),1:"ALL RESULTS")
S DIR("A")="Is this correct"
D ^DIR
I $D(DIRUT)!(Y'=1) D UNLAH(LRINST),NOP Q
W !!,"<< Clearing Instrument Data >>",!
I 'LRCUTDT K ^LAH(LRINST) ; Kill all results for this loadlist.
I LRCUTDT D
. W !,"Clearing sequence number: "
. S (LRCNT,LRISQN)=0
. F S LRISQN=$O(^LAH(LRINST,1,LRISQN)) Q:'LRISQN D
. . S $P(LRCNT,"^")=$P(LRCNT,"^")+1
. . I '$P($G(^LAH(LRINST,1,LRISQN,0)),"^",11) D UPDT^LAGEN(LRINST,LRISQN) Q ; No date, put current d/t, skip
. . I $P($G(^LAH(LRINST,1,LRISQN,0)),"^",9+LRCTYPE)'<LRCUTDT Q ; Skip - Keep
. . S LRLL=LRINST,I=LRISQN,$P(LRCNT,"^",2)=$P(LRCNT,"^",2)+1
. . I $X>(IOM-10) W !
. . W "[",LRISQN,"]"
. . N LRINST,LRISQN,LRCUTDT
. . D ZAP^LRVR3
. S X=$O(^LAH(LRINST,1,"A"),-1) ; Get last entry, reset zeroth node.
. I X S ^LAH(LRINST)=X
. I '$O(^LAH(LRINST,"")) K ^LAH(LRINST)
. W !,"Checked ",+$P(LRCNT,"^")," entries, removed ",+$P(LRCNT,"^",2),"."
D UNLAH(LRINST),END
Q
;
UNLAH(LRLL) ; Unlock node in LAH global
L -^LAH(+$G(LRLL))
Q
;
NOP W !,"Operation not complete"
END K ^TMP("LR",$J,"T"),A,DIC,I,LRFULL,LRDFN,LRDPF,LRFULL,LRIX,LRTSTS,LRTX,LRWPROF,LRWRD,LRINSTIT,LRMAXCUP,LRTRANS,LRTYPE,X,Y,Z,LRINST,%,LRPROF,LRTRAY,LRCUP,LRAA,LRAD
K AGE,DFN,DOB,K,PNM,SEX,T,D,G,LRAN,LREXEC,LRLLOC,SSN,X9
Q
PROFILE S DIC(0)="AEQ",DIC="^LRO(68.2,"_LRINST_",10," D ^DIC K DIC Q:Y<1
S LRWPROF=+Y
Q
EN02 ;
REMOVE D LRINST G NOP:LRINST<1
RM D GCUP G END:LRCUP[U D CURRENT,DROP:%=1 W:%=1 !,">> REMOVED <<" G RM
EN03 ;
MOVE D LRINST G NOP:LRINST<1
MOV D GCUP G END:LRCUP[U D LIFT I LRHOLD="" W !,"LOCATION EMPTY" G MOV
D NOW G IN5
SETONE G SETONE^LRLLS2
WHATEST G WHATEST^LRLLS2
SHOW G SHOW^LRLLS2
WHO G WHO^LRLLS2
CURRENT G CURRENT^LRLLS2
DROP G DROP^LRLLS2
CLRALL D LRINST G CLRALL^LRLLS2
EN04 ;
CLRBYTRY ;CLEAR LOAD LIST BY LRTRAY
G CLRBYTRY^LRLLS2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLLS 5178 printed Dec 13, 2024@02:16:24 Page 2
LRLLS ;SLC/RWF-LOAD LIST FIX UP ;8/17/87 11:16
+1 ;;5.2;LAB SERVICE;**116,221**;Sep 27, 1994
LRINST ;from LRLLS2
+1 SET U="^"
DO DT^LRX
SET LRAD=DT
KILL ^TMP("LR",$JOB,"T"),DIC,LRHOLD,LRTSTS
+2 SET DIC="^LRO(68.2,"
SET DIC(0)="AEMZ"
SET DIC("S")="S %=$P(^(0),U,12) X ""I '$L(%)"" Q:$T S %=$P(^DIC(19.1,%,0),U,1) I $D(^XUSEC(%,DUZ))"
DO ^DIC
KILL DIC
SET LRINST=+Y
if Y<1
QUIT
+3 SET LRTRANS=+$PIECE(Y(0),U,2)
SET LRTYPE=+$PIECE(Y(0),U,3)
SET LRFULL=$PIECE(Y(0),U,5)
SET LRINSTIT=+$PIECE(Y(0),U,7)
SET LRMAXCUP=+$PIECE(Y(0),U,4)
+4 SET LRTRANS=$SELECT($DATA(^LAB(62.07,LRTRANS,.1)):^(.1),1:"S LRCUP=LRCUP+1")
SET LRINSTIT=$SELECT($DATA(^LAB(62.07,LRINSTIT,.1)):^(.1),1:"Q")
+5 QUIT
EN ;
INSERT ;INSERT A SAMPLE ON TO A TRAY
+1 DO END
DO LRINST
if LRINST<1
GOTO END
DO PROFILE
if +$GET(LRWPROF)<1
GOTO END
IN2 SET LRACC=1
if +$GET(LRWPROF)<1
SET LRWPROF=0
DO ^LRWU4
KILL LRACC
if LRAN<1
GOTO END
+1 DO SHOW
WRITE !?15
SET %=1
DO YN^DICN
if %<1
GOTO NOP
if %=2
GOTO IN2
+2 KILL ^TMP("LR",$JOB,"T"),LRTSTS
DO WHATEST
if '$DATA(X)
GOTO NOP
if X=U
GOTO NOP
IN5 DO PCUP
if LRCUP[U
GOTO NOP
DO LIFT
DO SETONE
WRITE !!," >> INSERTED <<"
IF LRHOLD'=""
WRITE !,"NOW WHAT TO DO WITH"
DO NOW
DO SHOW
GOTO IN5
+1 QUIT
LIFT KILL LRHOLD
SET LRHOLD=$SELECT($DATA(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,0)):^(0),1:"")
if LRHOLD=""
QUIT
+1 FOR I=0:0
SET I=$ORDER(^LRO(68.2,LRINST,1,LRTRAY,1,LRCUP,1,I))
if I<1
QUIT
SET LRHOLD(I)=^(I,0)
+2 IF $DATA(^LRO(68,+$PIECE(LRHOLD,U,1),1,+$PIECE(LRHOLD,U,2),1,+$PIECE(LRHOLD,U,3),0))[0
SET LRHOLD=""
+3 DO DROP
QUIT
NOW if LRHOLD=""
QUIT
KILL ^TMP("LR",$JOB,"T"),LRTSTS
SET LRAA=+LRHOLD
SET LRAD=$PIECE(LRHOLD,U,2)
SET LRAN=$PIECE(LRHOLD,U,3)
SET LRWPROF=$PIECE(LRHOLD,U,4)
+1 if $DATA(^LRO(68,LRAA,1,+LRAD,1,+LRAN,.2))
WRITE " ACCESSION: ",^(.2)
+2 FOR I=0:0
SET I=$ORDER(LRHOLD(I))
if I<1
QUIT
SET ^TMP("LR",$JOB,"T",I)=LRHOLD(I)
+3 QUIT
PCUP SET W="PUT THE SAMPLE IN "
GOTO CP1
GCUP SET W="REMOVE THE SAMPLE FROM "
CP1 IF 'LRTYPE
SET LRTRAY=1
WRITE !,W,"SEQUENCE #: "
READ LRCUP:DTIME
if LRCUP[U!(LRCUP="")
GOTO CP4
if +LRCUP'=LRCUP
GOTO CPSH
QUIT
CP2 WRITE !,W,"TRAY: "
READ LRTRAY:DTIME
if LRTRAY[U!(LRTRAY="")
GOTO CP4
READ " CUP: ",LRCUP:DTIME
if LRCUP[U!(LRCUP="")
GOTO CP4
if +LRTRAY'=LRTRAY
GOTO CPTH
if +LRCUP'=LRCUP
GOTO CPTH
QUIT
CP4 SET LRCUP=U
KILL W
QUIT
CPSH WRITE !,"Enter the SEQUENCE # to use."
GOTO CP1
CPTH WRITE !,"Enter the TRAY or CUP that you want to use."
GOTO CP1
EN01 ;
CLEAR ; Clear data from LAH
+1 NEW DIR,DIRUT,DTOUT,DUOUT,LRCNT,LRCUTDT,LREND,LRINST,LRISQN,LRCTYPE,X,Y
+2 SET DT=$$DT^XLFDT
+3 SET (LRCUTDT,LREND)=0
+4 DO LRINST
+5 IF LRINST<1
DO END
QUIT
+6 IF '$DATA(^LAH(LRINST))
Begin DoDot:1
+7 WRITE !!,$CHAR(7),"<<< No data in LAH global for this load/work list >>>",!
+8 DO NOP
End DoDot:1
QUIT
+9 WRITE !
+10 LOCK +^LAH(LRINST):1
+11 IF '$TEST
Begin DoDot:1
+12 WRITE !!,$CHAR(7),"<<< Unable to lock global, try again later >>>",!
+13 DO NOP
End DoDot:1
QUIT
+14 SET DIR(0)="SO^0:All Results for this Load/Worklist;1:By Date Results First Received;2:By Date Results Last Updated"
SET DIR("A")="Clear Results"
+15 SET DIR("?",1)="All results can be cleared or results can"
+16 SET DIR("?")="be cleared by date received or last updated."
+17 DO ^DIR
+18 IF $DATA(DIRUT)
DO UNLAH(LRINST)
DO END
QUIT
+19 SET LRCTYPE=+Y
+20 IF LRCTYPE
Begin DoDot:1
+21 WRITE !
+22 SET DIR(0)="DO^:NOW:AEPTX"
SET DIR("A")="Select Cutoff Date/Time"
SET DIR("B")="T-1"
+23 SET DIR("?",1)="Enter a date or a date/time."
+24 SET DIR("?",2)="Date selected must be on or before "_$$HTE^XLFDT($HOROLOG,"1")
+25 SET DIR("?")="Results before this date/time will be removed from Load/Worklist "_$PIECE($GET(^LRO(68.2,+LRINST,0)),"^")_"."
+26 DO ^DIR
+27 IF $DATA(DIRUT)
SET LREND=1
QUIT
+28 SET LRCUTDT=Y
End DoDot:1
+29 IF LREND
DO UNLAH(LRINST)
DO NOP
QUIT
+30 WRITE !
+31 SET DIR(0)="YO"
SET DIR("B")="NO"
+32 SET DIR("A",1)="For Load/Worklist "_$PIECE($GET(^LRO(68.2,LRINST,0)),"^")_" clear "_$SELECT(LRCUTDT:"results before "_$$FMTE^XLFDT(LRCUTDT),1:"ALL RESULTS")
+33 SET DIR("A")="Is this correct"
+34 DO ^DIR
+35 IF $DATA(DIRUT)!(Y'=1)
DO UNLAH(LRINST)
DO NOP
QUIT
+36 WRITE !!,"<< Clearing Instrument Data >>",!
+37 ; Kill all results for this loadlist.
IF 'LRCUTDT
KILL ^LAH(LRINST)
+38 IF LRCUTDT
Begin DoDot:1
+39 WRITE !,"Clearing sequence number: "
+40 SET (LRCNT,LRISQN)=0
+41 FOR
SET LRISQN=$ORDER(^LAH(LRINST,1,LRISQN))
if 'LRISQN
QUIT
Begin DoDot:2
+42 SET $PIECE(LRCNT,"^")=$PIECE(LRCNT,"^")+1
+43 ; No date, put current d/t, skip
IF '$PIECE($GET(^LAH(LRINST,1,LRISQN,0)),"^",11)
DO UPDT^LAGEN(LRINST,LRISQN)
QUIT
+44 ; Skip - Keep
IF $PIECE($GET(^LAH(LRINST,1,LRISQN,0)),"^",9+LRCTYPE)'<LRCUTDT
QUIT
+45 SET LRLL=LRINST
SET I=LRISQN
SET $PIECE(LRCNT,"^",2)=$PIECE(LRCNT,"^",2)+1
+46 IF $X>(IOM-10)
WRITE !
+47 WRITE "[",LRISQN,"]"
+48 NEW LRINST,LRISQN,LRCUTDT
+49 DO ZAP^LRVR3
End DoDot:2
+50 ; Get last entry, reset zeroth node.
SET X=$ORDER(^LAH(LRINST,1,"A"),-1)
+51 IF X
SET ^LAH(LRINST)=X
+52 IF '$ORDER(^LAH(LRINST,""))
KILL ^LAH(LRINST)
+53 WRITE !,"Checked ",+$PIECE(LRCNT,"^")," entries, removed ",+$PIECE(LRCNT,"^",2),"."
End DoDot:1
+54 DO UNLAH(LRINST)
DO END
+55 QUIT
+56 ;
UNLAH(LRLL) ; Unlock node in LAH global
+1 LOCK -^LAH(+$GET(LRLL))
+2 QUIT
+3 ;
NOP WRITE !,"Operation not complete"
END KILL ^TMP("LR",$JOB,"T"),A,DIC,I,LRFULL,LRDFN,LRDPF,LRFULL,LRIX,LRTSTS,LRTX,LRWPROF,LRWRD,LRINSTIT,LRMAXCUP,LRTRANS,LRTYPE,X,Y,Z,LRINST,%,LRPROF,LRTRAY,LRCUP,LRAA,LRAD
+1 KILL AGE,DFN,DOB,K,PNM,SEX,T,D,G,LRAN,LREXEC,LRLLOC,SSN,X9
+2 QUIT
PROFILE SET DIC(0)="AEQ"
SET DIC="^LRO(68.2,"_LRINST_",10,"
DO ^DIC
KILL DIC
if Y<1
QUIT
+1 SET LRWPROF=+Y
+2 QUIT
EN02 ;
REMOVE DO LRINST
if LRINST<1
GOTO NOP
RM DO GCUP
if LRCUP[U
GOTO END
DO CURRENT
if %=1
DO DROP
if %=1
WRITE !,">> REMOVED <<"
GOTO RM
EN03 ;
MOVE DO LRINST
if LRINST<1
GOTO NOP
MOV DO GCUP
if LRCUP[U
GOTO END
DO LIFT
IF LRHOLD=""
WRITE !,"LOCATION EMPTY"
GOTO MOV
+1 DO NOW
GOTO IN5
SETONE GOTO SETONE^LRLLS2
WHATEST GOTO WHATEST^LRLLS2
SHOW GOTO SHOW^LRLLS2
WHO GOTO WHO^LRLLS2
CURRENT GOTO CURRENT^LRLLS2
DROP GOTO DROP^LRLLS2
CLRALL DO LRINST
GOTO CLRALL^LRLLS2
EN04 ;
CLRBYTRY ;CLEAR LOAD LIST BY LRTRAY
+1 GOTO CLRBYTRY^LRLLS2
