LRBLJPA.m

LRBLJPA ;AVAMC/REG/CYM - BB INVENTORY FINAL DISPOSITION ;6/20/96  09:22 ;

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

 ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRBLJPA   1546     printed  Apr 09, 2024@21:13:52                                                                                                                                                                                                     Page 2

LRBLJPA   ;AVAMC/REG/CYM - BB INVENTORY FINAL DISPOSITION ;6/20/96  09:22 ;

 +1       ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994

 +2       ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021

 +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