- 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 ---[H[J[2J[HLRBLJPA 1546 printed Feb 18, 2025@23:37:13 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
