LAEKT7D.m

LAEKT7D ; IHS/DIR/FJE - KODAK EKTACHEM 700 BUILD DOWNLOAD FILE. 8/15/90 15:10 ;

 ;;5.2;LA;;NOV 01, 1997

 ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994

 ;Call with LRLL = load list to build

 ;Call with LRTRAY1 = Starting tray number

 ;Call with LRLL = Auto Instrument pointer

 ;Call with LRFORCE=1 if send tray and cup.

A S:$D(ZTQUEUED) ZTREQ="@" S F=$O(^LAB(61,"B","CSF",0)) ;Get CSF pointer value.

 S X=^LAB(69.9,1,1),LRFLUID=$P(X,"^",3)_"^"_F_"^"_$P(X,"^",2)

 F LRTRAY=LRTRAY1:0 D:$D(^LRO(68.2,LRLL,1,LRTRAY)) TRAY S LRTRAY=$O(^LRO(68.2,LRLL,1,LRTRAY)),LRCUP1=1 Q:LRTRAY'>0

 Q

TEST S X="" F LRTEST=0:0 S LRTEST=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST)) Q:LRTEST'>0  D T2

 Q

T2 Q:'$D(^TMP($J,LRTEST))  F I=0:0 S I=$O(^TMP($J,LRTEST,I)) Q:I'>0  S Y=^(I) S:X'[Y X=X_^(I) ;Don't repete a test

 Q

SAMPLE S LRL=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0),LRAA=+LRL,LRAD=$P(LRL,"^",2),LRAN=$P(LRL,"^",3),LRECORD=LRECORD_$E(LRAN_"               ",1,15) D PNM

 S F=$P(LRL,"^",5),F=$S($P(LRFLUID,"^",1)=F:1,$P(LRFLUID,"^",3)=F:3,$P(LRFLUID,"^",2)=F:2,1:0) ;If not one of the 3 fluids don't send

 I 'F W:'$D(ZTSK) !,"Accession not correct collection sample: ",LRACC Q

 S LRECORD=LRECORD_F_"0"_$S($G(LRFORCE):$C(LRCUP+32),1:" ")_"1.000" D TEST S LRECORD=LRECORD_X_PNM_"]"

 S ^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,2)=LRECORD

 Q

TRAY S LRECORD=$S($G(LRFORCE):$E("|"_"TRAY "_LRTRAY_"          ",1,16),1:"")

 F LRCUP=(LRCUP1-1):0 S LRCUP=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP)) Q:LRCUP'>0  D SAMPLE S LRECORD=""

 Q

PNM ;Get patient name and last 4 from an accession.

 ;S PNM="" Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))  S X=^(0),LRACC=^(.2),X=^LR(+X,0) I $P(X,"^",2)=2 S DFN=$P(X,"^",3) D PT^LRX S PNM=$E("|"_$E(PNM,1,20)_" "_$P(SSN,"-",3)_$J(" ",26),1,26)

 S PNM="" Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))  S X=^(0),LRACC=^(.2),X=^LR(+X,0),LRDFN=$P(X,"^") I $P(X,"^",2)=2 S DFN=$P(X,"^",3) D PT^LRX S PNM=$E("|"_$E(PNM,1,20)_" "_HRCN_$J(" ",26),1,26)  ;IHS/ANMC/CLS 11/1/95

 Q

LAEKT7D   ; IHS/DIR/FJE - KODAK EKTACHEM 700 BUILD DOWNLOAD FILE. 8/15/90 15:10 ;

 +1       ;;5.2;LA;;NOV 01, 1997

 +2       ;;5.2;AUTOMATED LAB INSTRUMENTS;;Sep 27, 1994

 +3       ;Call with LRLL = load list to build

 +4       ;Call with LRTRAY1 = Starting tray number

 +5       ;Call with LRLL = Auto Instrument pointer

 +6       ;Call with LRFORCE=1 if send tray and cup.

A         ;Get CSF pointer value.

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           SET F=$ORDER(^LAB(61,"B","CSF",0))

 +1        SET X=^LAB(69.9,1,1)

           SET LRFLUID=$PIECE(X,"^",3)_"^"_F_"^"_$PIECE(X,"^",2)

 +2        FOR LRTRAY=LRTRAY1:0

               IF $DATA(^LRO(68.2,LRLL,1,LRTRAY))

                   DO TRAY

               SET LRTRAY=$ORDER(^LRO(68.2,LRLL,1,LRTRAY))

               SET LRCUP1=1

               IF LRTRAY'>0

                   QUIT 

 +3        QUIT 

TEST       SET X=""

           FOR LRTEST=0:0

               SET LRTEST=$ORDER(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,1,LRTEST))

               IF LRTEST'>0

                   QUIT 

               DO T2

 +1        QUIT 

T2        ;Don't repete a test

           IF '$DATA(^TMP($JOB,LRTEST))

               QUIT 

           FOR I=0:0

               SET I=$ORDER(^TMP($JOB,LRTEST,I))

               IF I'>0

                   QUIT 

               SET Y=^(I)

               IF X'[Y

                   SET X=X_^(I)

 +1        QUIT 

SAMPLE     SET LRL=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0)

           SET LRAA=+LRL

           SET LRAD=$PIECE(LRL,"^",2)

           SET LRAN=$PIECE(LRL,"^",3)

           SET LRECORD=LRECORD_$EXTRACT(LRAN_"               ",1,15)

           DO PNM

 +1       ;If not one of the 3 fluids don't send

           SET F=$PIECE(LRL,"^",5)

           SET F=$SELECT($PIECE(LRFLUID,"^",1)=F:1,$PIECE(LRFLUID,"^",3)=F:3,$PIECE(LRFLUID,"^",2)=F:2,1:0)

 +2        IF 'F

               IF '$DATA(ZTSK)

                   WRITE !,"Accession not correct collection sample: ",LRACC

               QUIT 

 +3        SET LRECORD=LRECORD_F_"0"_$SELECT($GET(LRFORCE):$CHAR(LRCUP+32),1:" ")_"1.000"

           DO TEST

           SET LRECORD=LRECORD_X_PNM_"]"

 +4        SET ^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,2)=LRECORD

 +5        QUIT 

TRAY       SET LRECORD=$SELECT($GET(LRFORCE):$EXTRACT("|"_"TRAY "_LRTRAY_"          ",1,16),1:"")

 +1        FOR LRCUP=(LRCUP1-1):0

               SET LRCUP=$ORDER(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP))

               IF LRCUP'>0

                   QUIT 

               DO SAMPLE

               SET LRECORD=""

 +2        QUIT 

PNM       ;Get patient name and last 4 from an accession.

 +1       ;S PNM="" Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))  S X=^(0),LRACC=^(.2),X=^LR(+X,0) I $P(X,"^",2)=2 S DFN=$P(X,"^",3) D PT^LRX S PNM=$E("|"_$E(PNM,1,20)_" "_$P(SSN,"-",3)_$J(" ",26),1,26)

 +2       ;IHS/ANMC/CLS 11/1/95

           SET PNM=""

           IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

               QUIT 

           SET X=^(0)

           SET LRACC=^(.2)

           SET X=^LR(+X,0)

           SET LRDFN=$PIECE(X,"^")

           IF $PIECE(X,"^",2)=2

               SET DFN=$PIECE(X,"^",3)

               DO PT^LRX

               SET PNM=$EXTRACT("|"_$EXTRACT(PNM,1,20)_" "_HRCN_$JUSTIFY(" ",26),1,26)

 +3        QUIT