LRBLPQA ;AVAMC/REG - TRANSFUSION REQUEST DATA ;2/18/93 09:45 ;
;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
W !!?20 D END,I,Z G:Y=-1 END
A R !!?3,"(A)ll components or (S)ingle component: ",X:DTIME Q:X["^"!(X="") I $A(X)'=65,$A(X)'=83 W $C(7),!,"Enter 'A' for all blood components or 'S' for a single component" G A
G:$A(X)=65 D
B S DIC=66,DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)=""BB""" D ^DIC K DIC G:Y<1 END S LRC=+Y,LRC(1)=$P(Y,"^",2) I '$D(^LRO(69.2,LRAA,8,66,1,LRC)) W $C(7),!,"There are no entries to print",!! G B
D D B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001
S ZTRTN="QUE^LRBLPQA" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D L^LRU,S^LRU,H S LR("F")=1 I $D(LRC) D W G OUT
S LRC(1)=0 F LRA=0:0 S LRC(1)=$O(^LRO(69.2,LRAA,8,66,1,"B",LRC(1))) Q:LRC(1)=""!(LR("Q")) F LRC=0:0 S LRC=$O(^LRO(69.2,LRAA,8,66,1,"B",LRC(1),LRC)) Q:'LRC!(LR("Q")) D W
OUT W:IOST'?1"C".E @IOF D END,END^LRUTL Q
W D:$Y>(IOSL-10) H Q:LR("Q") W !!?20,LRC(1)
F LRD=0:0 S LRD=$O(^LRO(69.2,LRAA,8,66,1,LRC,1,LRD)) Q:'LRD!(LR("Q")) S LRB=^(LRD,0) I +LRB<LRLDT&(+LRB>LRSDT) S $P(^(0),"^",4)=1,SSN=$P(LRB,"^",3) D:$Y>(IOSL-10) H1 Q:LR("Q") S Y=+LRB D D^LRU D W1
Q
W1 W !!,Y," ",$P(LRB,"^",2)," SSN:",SSN
F A=0:0 S A=$O(^LRO(69.2,LRAA,8,66,1,LRC,1,LRD,1,A)) Q:'A!(LR("Q")) S LR=^(A,0) D:$Y>(IOSL-10) H2 Q:LR("Q") W !,LR
Q
EN ;
Q D Z G:Y=-1 END W !!,"This option deletes inappropriate transfusion requests",!,"that have been previously printed. OK " S %=2 D YN^LRU G:%'=1 END
W ! F A=0:0 S A=$O(^LRO(69.2,LRAA,8,66,1,A)) Q:'A S C=0 D K
W !,"DONE",! G END
K F B=0:0 S B=$O(^LRO(69.2,LRAA,8,66,1,A,1,B)) Q:'B I $P(^(B,0),"^",4) K ^LRO(69.2,LRAA,8,66,1,A,1,B) S C=C+1 W "."
Q:'C
S X=^LRO(69.2,LRAA,8,66,1,A,1,0),Y=$P(X,"^",4)-C
I Y<1 S V=^LRO(69.2,LRAA,8,66,1,A,0) K ^LRO(69.2,LRAA,8,66,1,A),^LRO(69.2,LRAA,8,66,1,"B",V,A) S Y=$O(^LRO(69.2,LRAA,8,66,1,0)) S:'Y Y=0 S X=^LRO(69.2,LRAA,8,66,1,0),^(0)=$P(X,"^",1,2)_"^"_Y_"^"_($P(X,"^",4)-1) Q
S X(1)=$O(^LRO(69.2,LRAA,8,66,1,A,1,0)) S:'X(1) X(1)=0 S ^LRO(69.2,LRAA,8,66,1,A,1,0)=$P(X,"^",1,2)_"^"_X(1)_"^"_Y Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"BLOOD BANK",!?20 D I W !,LR("%") Q
H1 D H Q:LR("Q") W !!?20,LRC(1) Q
H2 D H1 Q:LR("Q") W ! S Y=+LRB D D^LRU W Y," ",$P(LRB,"^",2)," ",SSN Q
I W "Inappropriate transfusion requests report" Q
Z S X="BLOOD BANK" D ^LRUTL Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLPQA 2493 printed Dec 13, 2024@02:11:57 Page 2
LRBLPQA ;AVAMC/REG - TRANSFUSION REQUEST DATA ;2/18/93 09:45 ;
+1 ;;5.2;LAB SERVICE;**247,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 WRITE !!?20
DO END
DO I
DO Z
if Y=-1
GOTO END
A READ !!?3,"(A)ll components or (S)ingle component: ",X:DTIME
if X["^"!(X="")
QUIT
IF $ASCII(X)'=65
IF $ASCII(X)'=83
WRITE $CHAR(7),!,"Enter 'A' for all blood components or 'S' for a single component"
GOTO A
+1 if $ASCII(X)=65
GOTO D
B SET DIC=66
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,4)=""BB"""
DO ^DIC
KILL DIC
if Y<1
GOTO END
SET LRC=+Y
SET LRC(1)=$PIECE(Y,"^",2)
IF '$DATA(^LRO(69.2,LRAA,8,66,1,LRC))
WRITE $CHAR(7),!,"There are no entries to print",!!
GOTO B
D DO B^LRU
if Y<0
GOTO END
SET LRLDT=LRLDT+.99
SET LRSDT=LRSDT-.0001
+1 SET ZTRTN="QUE^LRBLPQA"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
IF $DATA(LRC)
DO W
GOTO OUT
+1 SET LRC(1)=0
FOR LRA=0:0
SET LRC(1)=$ORDER(^LRO(69.2,LRAA,8,66,1,"B",LRC(1)))
if LRC(1)=""!(LR("Q"))
QUIT
FOR LRC=0:0
SET LRC=$ORDER(^LRO(69.2,LRAA,8,66,1,"B",LRC(1),LRC))
if 'LRC!(LR("Q"))
QUIT
DO W
OUT if IOST'?1"C".E
WRITE @IOF
DO END
DO END^LRUTL
QUIT
W if $Y>(IOSL-10)
DO H
if LR("Q")
QUIT
WRITE !!?20,LRC(1)
+1 FOR LRD=0:0
SET LRD=$ORDER(^LRO(69.2,LRAA,8,66,1,LRC,1,LRD))
if 'LRD!(LR("Q"))
QUIT
SET LRB=^(LRD,0)
IF +LRB<LRLDT&(+LRB>LRSDT)
SET $PIECE(^(0),"^",4)=1
SET SSN=$PIECE(LRB,"^",3)
if $Y>(IOSL-10)
DO H1
if LR("Q")
QUIT
SET Y=+LRB
DO D^LRU
DO W1
+2 QUIT
W1 WRITE !!,Y," ",$PIECE(LRB,"^",2)," SSN:",SSN
+1 FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,8,66,1,LRC,1,LRD,1,A))
if 'A!(LR("Q"))
QUIT
SET LR=^(A,0)
if $Y>(IOSL-10)
DO H2
if LR("Q")
QUIT
WRITE !,LR
+2 QUIT
EN ;
+1 QUIT
DO Z
if Y=-1
GOTO END
WRITE !!,"This option deletes inappropriate transfusion requests",!,"that have been previously printed. OK "
SET %=2
DO YN^LRU
if %'=1
GOTO END
+2 WRITE !
FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,8,66,1,A))
if 'A
QUIT
SET C=0
DO K
+3 WRITE !,"DONE",!
GOTO END
K FOR B=0:0
SET B=$ORDER(^LRO(69.2,LRAA,8,66,1,A,1,B))
if 'B
QUIT
IF $PIECE(^(B,0),"^",4)
KILL ^LRO(69.2,LRAA,8,66,1,A,1,B)
SET C=C+1
WRITE "."
+1 if 'C
QUIT
+2 SET X=^LRO(69.2,LRAA,8,66,1,A,1,0)
SET Y=$PIECE(X,"^",4)-C
+3 IF Y<1
SET V=^LRO(69.2,LRAA,8,66,1,A,0)
KILL ^LRO(69.2,LRAA,8,66,1,A),^LRO(69.2,LRAA,8,66,1,"B",V,A)
SET Y=$ORDER(^LRO(69.2,LRAA,8,66,1,0))
if 'Y
SET Y=0
SET X=^LRO(69.2,LRAA,8,66,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_Y_"^"_($PIECE(X,"^",4)-1)
QUIT
+4 SET X(1)=$ORDER(^LRO(69.2,LRAA,8,66,1,A,1,0))
if 'X(1)
SET X(1)=0
SET ^LRO(69.2,LRAA,8,66,1,A,1,0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_Y
QUIT
+5 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"BLOOD BANK",!?20
DO I
WRITE !,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !!?20,LRC(1)
QUIT
H2 DO H1
if LR("Q")
QUIT
WRITE !
SET Y=+LRB
DO D^LRU
WRITE Y," ",$PIECE(LRB,"^",2)," ",SSN
QUIT
I WRITE "Inappropriate transfusion requests report"
QUIT
Z SET X="BLOOD BANK"
DO ^LRUTL
QUIT
END DO V^LRU
QUIT
