LRBLJU1 ;AVAMC/REG - FIND UNITS NO DISPOSITION ;5/17/96 08:34
;;5.2;LAB SERVICE;**72,247,267**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
S (LRK,T(1),LRF)=0
F C=0:0 S C=$O(^TMP($J,C)) Q:'C!(LR("Q")) S LRF=LRF+1,C(1)=$S($D(^LAB(66,C,0)):$P(^(0),"^"),1:C) D H Q:LR("Q") S LR("F")=1 D A
I 'LRF D F^LRU W !,"Transfusion Service - Units ",$S(LROPT="EN1":"in & out date without final disposition",1:"available"),!,LR("%"),!,"There are no units ",$S(LROPT="":"available.",1:"without a final disposition.")
Q
A S A=0 F A(1)=0:0 S A=$O(^TMP($J,C,A)) Q:A=""!(LR("Q")) D B
Q:LR("Q") W !,C(1)," Total units: ",T(1) S T(1)=0 Q
B S R=0 F A(2)=0:0 S R=$O(^TMP($J,C,A,R)) Q:R=""!(LR("Q")) W ! D C
Q
C S E=0,T(2)=0 F A(3)=0:0 S E=$O(^TMP($J,C,A,R,E)) Q:E=""!(LR("Q")) S Y=E D D^LRU S C(6)=Y D D
Q:LR("Q") W !?4,"Total ",A," ",R," units: ",T(2) Q
D S I=0 F A(4)=0:0 S I=$O(^TMP($J,C,A,R,E,I)) Q:I=""!(LR("Q")) S W=^(I),I(1)=+W D:$Y>(IOSL-6) H Q:LR("Q") W !,A,?3,R,?7,I,?23,C(6),?43,$E($P(W,"^",2),1,8) D E
Q
E S C(2)=0,T(1)=T(1)+1,T(2)=T(2)+1,X=$S($D(^LRD(65,I(1),8)):$P(^(8),"^",3),1:""),LRJ=$S(X="":0,X="A":1,X="D":1,1:0)
S P=0 F P(1)=0:1 S P=$O(^LRD(65,I(1),2,P)) Q:'P!(LR("Q")) D F
I 'P(1)&LRJ!(LRJ&LRK) S P=+^LRD(65,I(1),8) W ?52,"*" I P D P W $E($P(Y,"^"),1,14)
Q
F S LRK=0 I '$P(^LRD(65,I(1),2,P,0),"^",2) S LRK=1 Q
S C(2)=C(2)+1 W:C(2)>1 ! Q:'$D(^LR(P,0)) D P
W:LRJ ?52,"*" W ?53,$E($P(Y,"^"),1,14) S LRI=$O(^LRD(65,I(1),2,P,1,0)) Q:'LRI S I(2)=+^(LRI,0),I(3)=$P(I(2),".",2),I(3)=I(3)_"0000",I(3)=$E(I(3),1,4) W ?68,$E(I(2),4,5)_"/"_$E(I(2),6,7) W:I(3) ?74,$E(I(3),1,2)_":"_$E(I(3),3,4) Q
;
P S X=^LR(P,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),Y=@(X_Y_",0)") Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"Transfusion Service ",LRAA(4),!,"Units of ",C(1),$S(LROPT["EN1":" in & out date ",1:" available")," (no disposition)"
W !?49,"*Autologous/Directed",!,"ABO",?4,"Rh",?7,"ID",?23,"Expiration Date",?43,"Location",?52,"Patient Assigned",?69,"Spec Date",!,LR("%") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJU1 2095 printed Oct 16, 2024@18:12:18 Page 2
LRBLJU1 ;AVAMC/REG - FIND UNITS NO DISPOSITION ;5/17/96 08:34
+1 ;;5.2;LAB SERVICE;**72,247,267**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 SET (LRK,T(1),LRF)=0
+4 FOR C=0:0
SET C=$ORDER(^TMP($JOB,C))
if 'C!(LR("Q"))
QUIT
SET LRF=LRF+1
SET C(1)=$SELECT($DATA(^LAB(66,C,0)):$PIECE(^(0),"^"),1:C)
DO H
if LR("Q")
QUIT
SET LR("F")=1
DO A
+5 IF 'LRF
DO F^LRU
WRITE !,"Transfusion Service - Units ",$SELECT(LROPT="EN1":"in & out date without final disposition",1:"available"),!,LR("%"),!,"There are no units ",$SELECT(LROPT="":"available.",1:"without a final disposition.")
+6 QUIT
A SET A=0
FOR A(1)=0:0
SET A=$ORDER(^TMP($JOB,C,A))
if A=""!(LR("Q"))
QUIT
DO B
+1 if LR("Q")
QUIT
WRITE !,C(1)," Total units: ",T(1)
SET T(1)=0
QUIT
B SET R=0
FOR A(2)=0:0
SET R=$ORDER(^TMP($JOB,C,A,R))
if R=""!(LR("Q"))
QUIT
WRITE !
DO C
+1 QUIT
C SET E=0
SET T(2)=0
FOR A(3)=0:0
SET E=$ORDER(^TMP($JOB,C,A,R,E))
if E=""!(LR("Q"))
QUIT
SET Y=E
DO D^LRU
SET C(6)=Y
DO D
+1 if LR("Q")
QUIT
WRITE !?4,"Total ",A," ",R," units: ",T(2)
QUIT
D SET I=0
FOR A(4)=0:0
SET I=$ORDER(^TMP($JOB,C,A,R,E,I))
if I=""!(LR("Q"))
QUIT
SET W=^(I)
SET I(1)=+W
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !,A,?3,R,?7,I,?23,C(6),?43,$EXTRACT($PIECE(W,"^",2),1,8)
DO E
+1 QUIT
E SET C(2)=0
SET T(1)=T(1)+1
SET T(2)=T(2)+1
SET X=$SELECT($DATA(^LRD(65,I(1),8)):$PIECE(^(8),"^",3),1:"")
SET LRJ=$SELECT(X="":0,X="A":1,X="D":1,1:0)
+1 SET P=0
FOR P(1)=0:1
SET P=$ORDER(^LRD(65,I(1),2,P))
if 'P!(LR("Q"))
QUIT
DO F
+2 IF 'P(1)&LRJ!(LRJ&LRK)
SET P=+^LRD(65,I(1),8)
WRITE ?52,"*"
IF P
DO P
WRITE $EXTRACT($PIECE(Y,"^"),1,14)
+3 QUIT
F SET LRK=0
IF '$PIECE(^LRD(65,I(1),2,P,0),"^",2)
SET LRK=1
QUIT
+1 SET C(2)=C(2)+1
if C(2)>1
WRITE !
if '$DATA(^LR(P,0))
QUIT
DO P
+2 if LRJ
WRITE ?52,"*"
WRITE ?53,$EXTRACT($PIECE(Y,"^"),1,14)
SET LRI=$ORDER(^LRD(65,I(1),2,P,1,0))
if 'LRI
QUIT
SET I(2)=+^(LRI,0)
SET I(3)=$PIECE(I(2),".",2)
SET I(3)=I(3)_"0000"
SET I(3)=$EXTRACT(I(3),1,4)
WRITE ?68,$EXTRACT(I(2),4,5)_"/"_$EXTRACT(I(2),6,7)
if I(3)
WRITE ?74,$EXTRACT(I(3),1,2)_":"_$EXTRACT(I(3),3,4)
QUIT
+3 ;
P SET X=^LR(P,0)
SET Y=$PIECE(X,"^",3)
SET X=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET Y=@(X_Y_",0)")
QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"Transfusion Service ",LRAA(4),!,"Units of ",C(1),$SELECT(LROPT["EN1":" in & out date ",1:" available")," (no disposition)"
+2 WRITE !?49,"*Autologous/Directed",!,"ABO",?4,"Rh",?7,"ID",?23,"Expiration Date",?43,"Location",?52,"Patient Assigned",?69,"Spec Date",!,LR("%")
QUIT
