LRBLJPA.m

LRBLJPA ; IHS/DIR/AAB - BB INVENTORY FINAL DISPOSITION 6/20/96 09:22 ;

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END

 I '$D(^LRO(69.2,LRAA,8,0)) S ^(0)="^69.31A^^"

 I '$D(^LRO(69.2,LRAA,8,65,0)) S ^(0)=65,X=^LRO(69.2,LRAA,8,0),^(0)="^69.31A^65^"_($P(X,"^",4)+1)

 W @IOF,?18,"INVENTORY- UNITS WITH FINAL DISPOSITION",!?21,"FROM ONE DATE RECEIVED TO ANOTHER",!

 S (%Y,%)="" I $O(^LRO(69.2,LRAA,8,65,1,0)) S X=$P(^LRO(69.2,LRAA,8,65,0),"^",4) W $C(7),!,"There is a list of units printed by ",$P(^VA(200,X,0),"^"),!,"They should be deleted before printing another list. OK " S %=1 D YN^LRU

 G:%Y["^" END I %=1 W !!,"Use supervisor option RU- Remove units with final disposition to delete list.",! G END

 D B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001

 S ZTRTN="QUE^LRBLJPA" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO D L^LRU,S^LRU K ^LRO(69.2,LRAA,8,65) S LR=0,^LRO(69.2,LRAA,8,65,0)=65_U_LRSTR_U_LRLST_U_DUZ,^(1,0)="^69.32A^^"

 F B=0:0 S LRSDT=$O(^LRD(65,"A",LRSDT)) Q:'LRSDT!(LRSDT>LRLDT)  F LRI=0:0 S LRI=$O(^LRD(65,"A",LRSDT,LRI)) Q:'LRI  I $D(^LRD(65,LRI,4)),$P(^(4),"^")]"",$D(^(0)) S LRND=^(0) D:$P(LRND,"^",5)=LRSDT SET

 S A=$O(^LRO(69.2,LRAA,8,65,1,0)) S:'A A=0 S ^LRO(69.2,LRAA,8,65,1,0)="^69.32A^"_A_"^"_LR

 D ^LRBLJPA1

 D END^LRUTL,END Q

SET S LR=LR+1,^LRO(69.2,LRAA,8,65,1,LRI,0)=$P(LRND,"^"),^LRO(69.2,LRAA,8,65,1,"B",$P(LRND,"^"),LRI)="" Q

END D V^LRU K LRTABO,LRTRH,LRTINS Q

LRBLJPA   ; IHS/DIR/AAB - BB INVENTORY FINAL DISPOSITION 6/20/96 09:22 ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3        DO END

           SET X="BLOOD BANK"

           DO ^LRUTL

           IF Y=-1

               GOTO END

 +4        IF '$DATA(^LRO(69.2,LRAA,8,0))

               SET ^(0)="^69.31A^^"

 +5        IF '$DATA(^LRO(69.2,LRAA,8,65,0))

               SET ^(0)=65

               SET X=^LRO(69.2,LRAA,8,0)

               SET ^(0)="^69.31A^65^"_($PIECE(X,"^",4)+1)

 +6        WRITE @IOF,?18,"INVENTORY- UNITS WITH FINAL DISPOSITION",!?21,"FROM ONE DATE RECEIVED TO ANOTHER",!

 +7        SET (%Y,%)=""

           IF $ORDER(^LRO(69.2,LRAA,8,65,1,0))

               SET X=$PIECE(^LRO(69.2,LRAA,8,65,0),"^",4)

               WRITE $CHAR(7),!,"There is a list of units printed by ",$PIECE(^VA(200,X,0),"^"),!,"They should be deleted before printing another list. OK "

               SET %=1

               DO YN^LRU

 +8        IF %Y["^"

               GOTO END

           IF %=1

               WRITE !!,"Use supervisor option RU- Remove units with final disposition to delete list.",!

               GOTO END

 +9        DO B^LRU

           IF Y<0

               GOTO END

           SET LRLDT=LRLDT+.99

           SET LRSDT=LRSDT-.0001

 +10       SET ZTRTN="QUE^LRBLJPA"

           DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           DO L^LRU

           DO S^LRU

           KILL ^LRO(69.2,LRAA,8,65)

           SET LR=0

           SET ^LRO(69.2,LRAA,8,65,0)=65_U_LRSTR_U_LRLST_U_DUZ

           SET ^(1,0)="^69.32A^^"

 +1        FOR B=0:0

               SET LRSDT=$ORDER(^LRD(65,"A",LRSDT))

               IF 'LRSDT!(LRSDT>LRLDT)

                   QUIT 

               FOR LRI=0:0

                   SET LRI=$ORDER(^LRD(65,"A",LRSDT,LRI))

                   IF 'LRI

                       QUIT 

                   IF $DATA(^LRD(65,LRI,4))

                       IF $PIECE(^(4),"^")]""

                           IF $DATA(^(0))

                               SET LRND=^(0)

                               IF $PIECE(LRND,"^",5)=LRSDT

                                   DO SET

 +2        SET A=$ORDER(^LRO(69.2,LRAA,8,65,1,0))

           IF 'A

               SET A=0

           SET ^LRO(69.2,LRAA,8,65,1,0)="^69.32A^"_A_"^"_LR

 +3        DO ^LRBLJPA1

 +4        DO END^LRUTL

           DO END

           QUIT 

SET        SET LR=LR+1

           SET ^LRO(69.2,LRAA,8,65,1,LRI,0)=$PIECE(LRND,"^")

           SET ^LRO(69.2,LRAA,8,65,1,"B",$PIECE(LRND,"^"),LRI)=""

           QUIT 

END        DO V^LRU

           KILL LRTABO,LRTRH,LRTINS

           QUIT