LRLLS.m

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 ---LRLLS   5178     printed  Feb 18, 2025@23:42:16                                                                                                                                                                                                       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