LRBLDCR ;AVAMC/REG - COMPONENT PREPARATION REPORT ;2/18/93 08:44 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
D END W !?20,"Blood donor component preparation report"
D B^LRU G:Y<0 END S LRSDT=LRSDT-.0001,LRLDT=LRLDT+.99
S ZTRTN="QUE^LRBLDCR" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D L^LRU,S^LRU S LRA=$P(^DD(65.54,4.11,0),U,3),LRD=$P(^DD(65.54,6.1,0),U,3),LRB=$P(^DD(65.54,1.1,0),U,3) D H S LR("F")=1
F A=LRSDT:0 S A=$O(^LRE("AD",A)) Q:'A!(A>LRLDT) S C=9999999-A F B=0:0 S B=$O(^LRE("AD",A,B)) Q:'B I $D(^LRE(B,5,C,0)),$P(^(0),"^",4)]"" S E=^(0),F=$S($D(^(2)):^(2),1:"") D SET
F A=0:0 S A=$O(^TMP($J,A)) Q:'A!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") S Y=A D D^LRU S LRD=Y W !!,"DONATION DATE: ",Y S B=0 D A
Q:LR("Q") W !,LR("%") S A=0 F B=0:0 S A=$O(LRT(A)) Q:A=""!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") S X=$P($P(LRB,A_":",2),";") W !,$S(X]"":X,1:"?")," DONATION TYPE",?40,"COUNT:",$J(LRT(A),5)
Q:LR("Q") W !,LR("%") F A=0:0 S A=$O(LRC(A)) Q:'A!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") W !,$S($D(^LAB(66,A,0)):$P(^(0),"^"),1:"??"),?40,"COUNT:",$J(LRC(A),5)
D END,END^LRUTL Q
A F C=1:1 S B=$O(^TMP($J,A,B)) Q:B=""!(LR("Q")) S E=^(B),M=$S($P(E,"^")]"":$P(E,"^"),1:"?") D:$Y>(IOSL-6) H1 Q:LR("Q") D W
Q
W W !,B,?15,M,?19,$P(E,"^",2),?22,$P(E,"^",3),?29,$J($P(E,"^",4),4),?34,$J($P(E,"^",5),4),?39,$P(E,"^",6),?44,$P(E,"^",7) S:'$D(LRT(M)) LRT(M)=0 S LRT(M)=LRT(M)+1
S F=0 F G=0:1 S F=$O(^TMP($J,A,B,F)) Q:'F!(LR("Q")) S H=^(F) D:$Y>(IOSL-6) H4 Q:LR("Q") W:G ! W ?49,$P(H,"^"),?66,$J($P(H,"^",2),4),?71,$J($P(H,"^",3),5) S:'$D(LRC(F)) LRC(F)=0 S LRC(F)=LRC(F)+1
Q
SET S G=$P(F,"^",9)_":",G=$P($P(LRA,G,2),";"),H=$P(E,"^",10)_":",H=$E($P($P(LRD,H,2),";"),1,4),I=$P(F,"^",8) I I,$D(^VA(200,I,0)) S I=$P(^(0),"^",2)
S Z=$P(F,"^",3) D H^LRUT S J(3)=%H,J(0)=Z(3),(J,Z)=$P(F,"^",2) I Z D H^LRUT S X=J(3)-%H*1440,Y=J(0)-Z(3),J=X+Y
S (K,Z)=$P(F,"^",4) I Z D H^LRUT S X=%H-J(3)*1440,Y=Z(3)-J(0),K=X+Y
S ^TMP($J,A,$P(E,"^",4))=$P(E,"^",11)_"^"_$P(F,"^")_"^"_G_"^"_J_"^"_K_"^"_H_"^"_I
F L=0:0 S L=$O(^LRE(B,5,C,66,L)) Q:'L S X=^(L,0) D C S ^TMP($J,A,$P(E,"^",4),L)=L(1)_"^"_L(2)_"^"_L(3)
Q
C S L(1)=$S($D(^LAB(66,L,0)):$E($P(^(0),"^"),1,16),1:"??"),L(2)=$P(X,"^",5),(Z,L(3))=$P(X,"^",3) I Z D H^LRUT S X=%H-J(3)*1440,Y=Z(3)-J(0),L(3)=X+Y
Q
;
H D H2 Q:LR("Q")
W !?22,"Anti",?29,"Coll",?34,"Proc",?39,"Coll",?66,"Vol",?71,"Storage"
W !,"Unit ID",?13,"Type",?18,"Bag",?22,"Coag",?30,"Min",?35,"Min",?39,"Disp",?44,"Tech",?49,"Blood component",?66,"(ml)",?71,"Minutes",!,LR("%") Q
H1 D H Q:LR("Q") W !!,"DONATION DATE: ",LRD Q
H2 I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"LABORATORY SERVICE",!?9,"BLOOD COMPONENT PREPARATION FROM ",LRSTR," TO ",LRLST Q
H3 D H2 W !,LR("%") Q
H4 D H1 W !,B,?15,M,?19,$P(E,"^",2),?22,$P(E,"^",3),?29,$J($P(E,"^",4),4),?34,$J($P(E,"^",5),4),?39,$P(E,"^",6),?44,$P(E,"^",7) Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDCR 2980 printed Dec 13, 2024@02:10:27 Page 2
LRBLDCR ;AVAMC/REG - COMPONENT PREPARATION REPORT ;2/18/93 08:44 ;
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 DO END
WRITE !?20,"Blood donor component preparation report"
+4 DO B^LRU
if Y<0
GOTO END
SET LRSDT=LRSDT-.0001
SET LRLDT=LRLDT+.99
+5 SET ZTRTN="QUE^LRBLDCR"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
DO L^LRU
DO S^LRU
SET LRA=$PIECE(^DD(65.54,4.11,0),U,3)
SET LRD=$PIECE(^DD(65.54,6.1,0),U,3)
SET LRB=$PIECE(^DD(65.54,1.1,0),U,3)
DO H
SET LR("F")=1
+1 FOR A=LRSDT:0
SET A=$ORDER(^LRE("AD",A))
if 'A!(A>LRLDT)
QUIT
SET C=9999999-A
FOR B=0:0
SET B=$ORDER(^LRE("AD",A,B))
if 'B
QUIT
IF $DATA(^LRE(B,5,C,0))
IF $PIECE(^(0),"^",4)]""
SET E=^(0)
SET F=$SELECT($DATA(^(2)):^(2),1:"")
DO SET
+2 FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
if 'A!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
SET Y=A
DO D^LRU
SET LRD=Y
WRITE !!,"DONATION DATE: ",Y
SET B=0
DO A
+3 if LR("Q")
QUIT
WRITE !,LR("%")
SET A=0
FOR B=0:0
SET A=$ORDER(LRT(A))
if A=""!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H3
if LR("Q")
QUIT
SET X=$PIECE($PIECE(LRB,A_":",2),";")
WRITE !,$SELECT(X]"":X,1:"?")," DONATION TYPE",?40,"COUNT:",$JUSTIFY(LRT(A),5)
+4 if LR("Q")
QUIT
WRITE !,LR("%")
FOR A=0:0
SET A=$ORDER(LRC(A))
if 'A!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H3
if LR("Q")
QUIT
WRITE !,$SELECT($DATA(^LAB(66,A,0)):$PIECE(^(0),"^"),1:"??"),?40,"COUNT:",$JUSTIFY(LRC(A),5)
+5 DO END
DO END^LRUTL
QUIT
A FOR C=1:1
SET B=$ORDER(^TMP($JOB,A,B))
if B=""!(LR("Q"))
QUIT
SET E=^(B)
SET M=$SELECT($PIECE(E,"^")]"":$PIECE(E,"^"),1:"?")
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
DO W
+1 QUIT
W WRITE !,B,?15,M,?19,$PIECE(E,"^",2),?22,$PIECE(E,"^",3),?29,$JUSTIFY($PIECE(E,"^",4),4),?34,$JUSTIFY($PIECE(E,"^",5),4),?39,$PIECE(E,"^",6),?44,$PIECE(E,"^",7)
if '$DATA(LRT(M))
SET LRT(M)=0
SET LRT(M)=LRT(M)+1
+1 SET F=0
FOR G=0:1
SET F=$ORDER(^TMP($JOB,A,B,F))
if 'F!(LR("Q"))
QUIT
SET H=^(F)
if $Y>(IOSL-6)
DO H4
if LR("Q")
QUIT
if G
WRITE !
WRITE ?49,$PIECE(H,"^"),?66,$JUSTIFY($PIECE(H,"^",2),4),?71,$JUSTIFY($PIECE(H,"^",3),5)
if '$DATA(LRC(F))
SET LRC(F)=0
SET LRC(F)=LRC(F)+1
+2 QUIT
SET SET G=$PIECE(F,"^",9)_":"
SET G=$PIECE($PIECE(LRA,G,2),";")
SET H=$PIECE(E,"^",10)_":"
SET H=$EXTRACT($PIECE($PIECE(LRD,H,2),";"),1,4)
SET I=$PIECE(F,"^",8)
IF I
IF $DATA(^VA(200,I,0))
SET I=$PIECE(^(0),"^",2)
+1 SET Z=$PIECE(F,"^",3)
DO H^LRUT
SET J(3)=%H
SET J(0)=Z(3)
SET (J,Z)=$PIECE(F,"^",2)
IF Z
DO H^LRUT
SET X=J(3)-%H*1440
SET Y=J(0)-Z(3)
SET J=X+Y
+2 SET (K,Z)=$PIECE(F,"^",4)
IF Z
DO H^LRUT
SET X=%H-J(3)*1440
SET Y=Z(3)-J(0)
SET K=X+Y
+3 SET ^TMP($JOB,A,$PIECE(E,"^",4))=$PIECE(E,"^",11)_"^"_$PIECE(F,"^")_"^"_G_"^"_J_"^"_K_"^"_H_"^"_I
+4 FOR L=0:0
SET L=$ORDER(^LRE(B,5,C,66,L))
if 'L
QUIT
SET X=^(L,0)
DO C
SET ^TMP($JOB,A,$PIECE(E,"^",4),L)=L(1)_"^"_L(2)_"^"_L(3)
+5 QUIT
C SET L(1)=$SELECT($DATA(^LAB(66,L,0)):$EXTRACT($PIECE(^(0),"^"),1,16),1:"??")
SET L(2)=$PIECE(X,"^",5)
SET (Z,L(3))=$PIECE(X,"^",3)
IF Z
DO H^LRUT
SET X=%H-J(3)*1440
SET Y=Z(3)-J(0)
SET L(3)=X+Y
+1 QUIT
+2 ;
H DO H2
if LR("Q")
QUIT
+1 WRITE !?22,"Anti",?29,"Coll",?34,"Proc",?39,"Coll",?66,"Vol",?71,"Storage"
+2 WRITE !,"Unit ID",?13,"Type",?18,"Bag",?22,"Coag",?30,"Min",?35,"Min",?39,"Disp",?44,"Tech",?49,"Blood component",?66,"(ml)",?71,"Minutes",!,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !!,"DONATION DATE: ",LRD
QUIT
H2 IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"LABORATORY SERVICE",!?9,"BLOOD COMPONENT PREPARATION FROM ",LRSTR," TO ",LRLST
QUIT
H3 DO H2
WRITE !,LR("%")
QUIT
H4 DO H1
WRITE !,B,?15,M,?19,$PIECE(E,"^",2),?22,$PIECE(E,"^",3),?29,$JUSTIFY($PIECE(E,"^",4),4),?34,$JUSTIFY($PIECE(E,"^",5),4),?39,$PIECE(E,"^",6),?44,$PIECE(E,"^",7)
QUIT
END DO V^LRU
QUIT
