LRBLJTS1 ;AVAMC/REG - TRANSFUSION STATS ;3/3/93 22:49 ;
;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
S L=0,B=LRSDT F B(1)=0:0 S B=$O(^LRD(65,"AB",B)) Q:'B!(B>LRLDT) S A=0 F A(1)=0:0 S A=$O(^LRD(65,"AB",B,A)) Q:'A I $D(^LRD(65,A,4)),$P(^(4),"^")="T" S Y=$P(^(4),"^",2) D T
D K^LRU,P,^LRBLJTS2 Q
T Q:'$D(^LRD(65,A,6)) S X=$P(^(6),"^",3) Q:X']LRA!(X]LRB) S J=$P(^(0),"^",4),Z=^LAB(66,J,0),Z(1)=$P(Z,"^"),Z(26)=$P(Z,"^",26) Q:Z(1)']LRC!(Z(1)]LRE)
S W=^LRD(65,A,0),W(1)=$P(W,"^"),V=^(6),V(2)=$P(V,"^",2),V=+V,Z(9)=$P(Z,"^",19) I V'=L S L=V,G=^LR(L,0),H=$P(G,"^",3),G=$P(G,"^",2),G=^DIC(G,0,"GL"),G=@(G_H_",0)"),^TMP($J,"P",$P(G,"^"),L)=""
S ^TMP($J,"A",X,J,V,$P(Y,"."),A)=W(1)_"^"_V(2)_"^"_$P(W,"^",10)_"^"_Z(26),^TMP($J,"C",Z(1),J)=""
S W(4)=+$P($G(^LAB(66,+$P(W,"^",4),0)),"^",26)
I Z(9) S ^TMP($J,"B",X,1,V)=""
E S ^TMP($J,"B",X,2,V)=""
Q
P D HDR S LR("F")=1,T=0 F A=0:0 S T=$O(^TMP($J,"A",T)) Q:T=""!(LR("Q")) D H1,Q
Q
Q S C(1)=0 F B=0:0 S C(1)=$O(^TMP($J,"C",C(1))) Q:C(1)=""!(LR("Q")) S C=+$O(^(C(1),0)) I $D(^TMP($J,"A",T,C)) D H2 Q:LR("Q") D L
Q:LR("Q") S R=0 F R(1)=0:1 S R=$O(^TMP($J,"B",T,1,R)) Q:'R
I R(1) D:$Y>(IOSL-5) H1 Q:LR("Q") W !!,T," patients given RBC components: ",R(1) S ^TMP($J,"B",T,1,0)=R(1)
S R=0 F R(1)=0:1 S R=$O(^TMP($J,"B",T,2,R)) Q:'R
I R(1) D:$Y>(IOSL-5) H1 Q:LR("Q") W !,T," patients given non-RBC components: ",R(1) S ^TMP($J,"B",T,2,0)=R(1)
W !,T," cost of all components: ",$J(^TMP($J,"A",T,0),9,2)
Q
L S (K,Z,Z(1),L(1))=0 F F=0:0 S L(1)=$O(^TMP($J,"P",L(1))) Q:L(1)=""!(LR("Q")) F L=0:0 S L=$O(^TMP($J,"P",L(1),L)) Q:'L!(LR("Q")) I $D(^TMP($J,"A",T,C,L)) D R
Q:LR("Q") W:K !?50,"---------",!?50,$J(K,9,2) S ^TMP($J,"D",C,T)=K_"^"_Z
S:'$D(^TMP($J,"D",C,0)) ^(0)="0^0" S X=^(0),^(0)=($P(X,"^")+K)_"^"_($P(X,"^",2)+Z) S:'$D(^TMP($J,"A",T,0)) ^(0)=0 S X=^(0),^(0)=X+K Q
R F W=0:0 S W=$O(^TMP($J,"A",T,C,L,W)) Q:'W!(LR("Q")) S T(2)=$E(W,4,5)_"/"_$E(W,6,7)_"/"_$E(W,2,3) F I=0:0 S I=$O(^TMP($J,"A",T,C,L,W,I)) Q:'I!(LR("Q")) S V=^(I) D W
Q
W D:$Y>(IOSL-5) H3 Q:LR("Q") S V(1)=$P(V,"^",3),Y=$P(V,"^",2),K=K+V(1),Z=Z+1 W ! I L'=Z(1) S Z(1)=L W $E(L(1),1,20)
W ?21,T(2),?30,$E($P(V,"^",2),1,18),?49,$J(V(1),9,2),?60,$P(V,"^"),?75,$J(Z,4)
S X=$P(V,"^",4) S:X="" X="?" S:'$D(^TMP($J,"Z",X,T,Y)) ^(Y)="0^0" S X=^(Y),X(1)=$P(X,"^")+V(1),X(2)=$P(X,"^",2)+1,^(Y)=X(1)_"^"_X(2) Q
H ;from LRBLJTS2
I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"Transfusions by Treating Specialty/Physician (",LRSTR," - ",LRLST,")" Q
;
HDR D H Q:LR("Q") W !,"Patient transfused",?21,"Date",?30,"Physician",?53,"Cost",?60,"Unit ID",?74,"Count",!,LR("%") Q
H1 D:$Y>(IOSL-5) HDR Q:LR("Q") W !!?20,"TREATING SPECIALTY: ",T Q
H2 D:$Y>(IOSL-5) H1 Q:LR("Q") W !,"Component: ",C(1),":",!?11 F X=1:1:$L(C(1)) W "-"
Q
H3 D H2 S Z(1)=0 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJTS1 2909 printed Sep 23, 2025@19:47:10 Page 2
LRBLJTS1 ;AVAMC/REG - TRANSFUSION STATS ;3/3/93 22:49 ;
+1 ;;5.2;LAB SERVICE;**247,267**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 SET L=0
SET B=LRSDT
FOR B(1)=0:0
SET B=$ORDER(^LRD(65,"AB",B))
if 'B!(B>LRLDT)
QUIT
SET A=0
FOR A(1)=0:0
SET A=$ORDER(^LRD(65,"AB",B,A))
if 'A
QUIT
IF $DATA(^LRD(65,A,4))
IF $PIECE(^(4),"^")="T"
SET Y=$PIECE(^(4),"^",2)
DO T
+4 DO K^LRU
DO P
DO ^LRBLJTS2
QUIT
T if '$DATA(^LRD(65,A,6))
QUIT
SET X=$PIECE(^(6),"^",3)
if X']LRA!(X]LRB)
QUIT
SET J=$PIECE(^(0),"^",4)
SET Z=^LAB(66,J,0)
SET Z(1)=$PIECE(Z,"^")
SET Z(26)=$PIECE(Z,"^",26)
if Z(1)']LRC!(Z(1)]LRE)
QUIT
+1 SET W=^LRD(65,A,0)
SET W(1)=$PIECE(W,"^")
SET V=^(6)
SET V(2)=$PIECE(V,"^",2)
SET V=+V
SET Z(9)=$PIECE(Z,"^",19)
IF V'=L
SET L=V
SET G=^LR(L,0)
SET H=$PIECE(G,"^",3)
SET G=$PIECE(G,"^",2)
SET G=^DIC(G,0,"GL")
SET G=@(G_H_",0)")
SET ^TMP($JOB,"P",$PIECE(G,"^"),L)=""
+2 SET ^TMP($JOB,"A",X,J,V,$PIECE(Y,"."),A)=W(1)_"^"_V(2)_"^"_$PIECE(W,"^",10)_"^"_Z(26)
SET ^TMP($JOB,"C",Z(1),J)=""
+3 SET W(4)=+$PIECE($GET(^LAB(66,+$PIECE(W,"^",4),0)),"^",26)
+4 IF Z(9)
SET ^TMP($JOB,"B",X,1,V)=""
+5 IF '$TEST
SET ^TMP($JOB,"B",X,2,V)=""
+6 QUIT
P DO HDR
SET LR("F")=1
SET T=0
FOR A=0:0
SET T=$ORDER(^TMP($JOB,"A",T))
if T=""!(LR("Q"))
QUIT
DO H1
DO Q
+1 QUIT
Q SET C(1)=0
FOR B=0:0
SET C(1)=$ORDER(^TMP($JOB,"C",C(1)))
if C(1)=""!(LR("Q"))
QUIT
SET C=+$ORDER(^(C(1),0))
IF $DATA(^TMP($JOB,"A",T,C))
DO H2
if LR("Q")
QUIT
DO L
+1 if LR("Q")
QUIT
SET R=0
FOR R(1)=0:1
SET R=$ORDER(^TMP($JOB,"B",T,1,R))
if 'R
QUIT
+2 IF R(1)
if $Y>(IOSL-5)
DO H1
if LR("Q")
QUIT
WRITE !!,T," patients given RBC components: ",R(1)
SET ^TMP($JOB,"B",T,1,0)=R(1)
+3 SET R=0
FOR R(1)=0:1
SET R=$ORDER(^TMP($JOB,"B",T,2,R))
if 'R
QUIT
+4 IF R(1)
if $Y>(IOSL-5)
DO H1
if LR("Q")
QUIT
WRITE !,T," patients given non-RBC components: ",R(1)
SET ^TMP($JOB,"B",T,2,0)=R(1)
+5 WRITE !,T," cost of all components: ",$JUSTIFY(^TMP($JOB,"A",T,0),9,2)
+6 QUIT
L SET (K,Z,Z(1),L(1))=0
FOR F=0:0
SET L(1)=$ORDER(^TMP($JOB,"P",L(1)))
if L(1)=""!(LR("Q"))
QUIT
FOR L=0:0
SET L=$ORDER(^TMP($JOB,"P",L(1),L))
if 'L!(LR("Q"))
QUIT
IF $DATA(^TMP($JOB,"A",T,C,L))
DO R
+1 if LR("Q")
QUIT
if K
WRITE !?50,"---------",!?50,$JUSTIFY(K,9,2)
SET ^TMP($JOB,"D",C,T)=K_"^"_Z
+2 if '$DATA(^TMP($JOB,"D",C,0))
SET ^(0)="0^0"
SET X=^(0)
SET ^(0)=($PIECE(X,"^")+K)_"^"_($PIECE(X,"^",2)+Z)
if '$DATA(^TMP($JOB,"A",T,0))
SET ^(0)=0
SET X=^(0)
SET ^(0)=X+K
QUIT
R FOR W=0:0
SET W=$ORDER(^TMP($JOB,"A",T,C,L,W))
if 'W!(LR("Q"))
QUIT
SET T(2)=$EXTRACT(W,4,5)_"/"_$EXTRACT(W,6,7)_"/"_$EXTRACT(W,2,3)
FOR I=0:0
SET I=$ORDER(^TMP($JOB,"A",T,C,L,W,I))
if 'I!(LR("Q"))
QUIT
SET V=^(I)
DO W
+1 QUIT
W if $Y>(IOSL-5)
DO H3
if LR("Q")
QUIT
SET V(1)=$PIECE(V,"^",3)
SET Y=$PIECE(V,"^",2)
SET K=K+V(1)
SET Z=Z+1
WRITE !
IF L'=Z(1)
SET Z(1)=L
WRITE $EXTRACT(L(1),1,20)
+1 WRITE ?21,T(2),?30,$EXTRACT($PIECE(V,"^",2),1,18),?49,$JUSTIFY(V(1),9,2),?60,$PIECE(V,"^"),?75,$JUSTIFY(Z,4)
+2 SET X=$PIECE(V,"^",4)
if X=""
SET X="?"
if '$DATA(^TMP($JOB,"Z",X,T,Y))
SET ^(Y)="0^0"
SET X=^(Y)
SET X(1)=$PIECE(X,"^")+V(1)
SET X(2)=$PIECE(X,"^",2)+1
SET ^(Y)=X(1)_"^"_X(2)
QUIT
H ;from LRBLJTS2
+1 IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+2 DO F^LRU
WRITE !,"Transfusions by Treating Specialty/Physician (",LRSTR," - ",LRLST,")"
QUIT
+3 ;
HDR DO H
if LR("Q")
QUIT
WRITE !,"Patient transfused",?21,"Date",?30,"Physician",?53,"Cost",?60,"Unit ID",?74,"Count",!,LR("%")
QUIT
H1 if $Y>(IOSL-5)
DO HDR
if LR("Q")
QUIT
WRITE !!?20,"TREATING SPECIALTY: ",T
QUIT
H2 if $Y>(IOSL-5)
DO H1
if LR("Q")
QUIT
WRITE !,"Component: ",C(1),":",!?11
FOR X=1:1:$LENGTH(C(1))
WRITE "-"
+1 QUIT
H3 DO H2
SET Z(1)=0
QUIT
