LRBLJTS2 ;AVAMC/REG - TRANSFUSION STATISTICS ;9/14/89 08:54 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
S LRT=0 D H S C(1)=0 F A=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,"D",C)) D H1 Q:LR("Q") D L
Q:LR("Q") W !,"Total cost of all components: ",$J(LRT,9,2) D H2 Q:LR("Q")
S A=0 F S A=$O(^TMP($J,"Z",A)) Q:A="" D A
F A=1:1:6 S S(A)=0
S A=0 F A(3)=0:1 S A=$O(^TMP($J,"Z",A)) Q:A="" S A(1)=^(A),A(2)=LRF(A) D:$Y>(IOSL-6) H2 Q:LR("Q") W ! W:A(3) LR("%") W !,A(2),?20,$J($P(A(1),"^",2),5),?50,$J($P(A(1),"^"),8,2) D B Q:LR("Q")
W !,LR("%"),!,"Totals",?20,$J(S(1),5),?30,$J(S(2),5),?40,$J(S(3),5),?50,$J(S(4),8,2),?60,$J(S(5),8,2),?70,$J(S(6),8,2) Q
B S S(1)=S(1)+$P(A(1),"^",2),S(4)=S(4)+$P(A(1),"^"),T=0 F S T=$O(^TMP($J,"Z",A,T)) Q:T=""!(LR("Q")) S T(1)=^(T) D:$Y>(IOSL-6) H3 Q:LR("Q") W !!?3,T,?30,$J($P(T(1),"^",2),5),?60,$J($P(T(1),"^"),8,2) D C Q:LR("Q")
Q
C S S(2)=S(2)+$P(T(1),"^",2),S(5)=S(5)+$P(T(1),"^"),P=0
F S P=$O(^TMP($J,"Z",A,T,P)) Q:P=""!(LR("Q")) S P(1)=^(P),S(3)=S(3)+$P(P(1),"^",2),S(6)=S(6)+$P(P(1),"^") D:$Y>(IOSL-6) H4 Q:LR("Q") W !?6,P,?40,$J($P(P(1),"^",2),5),?70,$J($P(P(1),"^"),8,2)
Q
A S (A(1),A(2),T)=0 F S T=$O(^TMP($J,"Z",A,T)) Q:T="" D T
S ^TMP($J,"Z",A)=A(1)_"^"_A(2) Q
T S (T(1),T(2),P)=0 F S P=$O(^TMP($J,"Z",A,T,P)) Q:P="" S X=^(P),X(1)=$P(X,"^"),X(2)=$P(X,"^",2),T(1)=T(1)+X(1),T(2)=T(2)+X(2)
S ^TMP($J,"Z",A,T)=T(1)_"^"_T(2),A(1)=A(1)+T(1),A(2)=A(2)+T(2) Q
L S X=^TMP($J,"D",C,0),K=+X,Z=$P(X,"^",2),T=0
F B=0:0 S T=$O(^TMP($J,"D",C,T)) Q:T=""!(LR("Q")) S X=^(T),Z(1)=$P(X,"^",2),K(1)=$P(X,"^") D:$Y>(IOSL-6) H1 Q:LR("Q") W !,T,?31,$J(Z(1),6),?43,$J(Z(1)/Z*100,4,1),?55,$J(K(1),9,2)
Q:LR("Q") W !?31,"------",?55,"---------",!?31,$J(Z,6),?55,$J(K,9,2),!,LR("%") S LRT=LRT+K Q
H D H^LRBLJTS1 Q:LR("Q") W !,"Treating specialty",?31,"# units",?40,"% total units",?58,"Cost",!,LR("%") Q
H1 D:$Y>(IOSL-6) H Q:LR("Q") W !!,C(1),":",! F X=1:1:$L(C(1)) W "-"
Q
H2 D H^LRBLJTS1 Q:LR("Q")
W !,"Administrative",?20,"Component",?30,"Specialty",?40,"Physician",?50,"Component",?60,"Specialty",?70,"Physician",!,"Category",?23,"Units",?33,"Units",?43,"Units",?53,"Cost",?63,"Cost",?73,"Cost",!,LR("%") S A(3)=0 Q
H3 D H2 Q:LR("Q") W !,A(2)," (continued from ",LRQ-1,")" Q
H4 D H3 Q:LR("Q") W !?6,T Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJTS2 2418 printed Sep 23, 2025@19:47:11 Page 2
LRBLJTS2 ;AVAMC/REG - TRANSFUSION STATISTICS ;9/14/89 08:54 ;
+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 SET LRT=0
DO H
SET C(1)=0
FOR A=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,"D",C))
DO H1
if LR("Q")
QUIT
DO L
+4 if LR("Q")
QUIT
WRITE !,"Total cost of all components: ",$JUSTIFY(LRT,9,2)
DO H2
if LR("Q")
QUIT
+5 SET A=0
FOR
SET A=$ORDER(^TMP($JOB,"Z",A))
if A=""
QUIT
DO A
+6 FOR A=1:1:6
SET S(A)=0
+7 SET A=0
FOR A(3)=0:1
SET A=$ORDER(^TMP($JOB,"Z",A))
if A=""
QUIT
SET A(1)=^(A)
SET A(2)=LRF(A)
if $Y>(IOSL-6)
DO H2
if LR("Q")
QUIT
WRITE !
if A(3)
WRITE LR("%")
WRITE !,A(2),?20,$JUSTIFY($PIECE(A(1),"^",2),5),?50,$JUSTIFY($PIECE(A(1),"^"),8,2)
DO B
if LR("Q")
QUIT
+8 WRITE !,LR("%"),!,"Totals",?20,$JUSTIFY(S(1),5),?30,$JUSTIFY(S(2),5),?40,$JUSTIFY(S(3),5),?50,$JUSTIFY(S(4),8,2),?60,$JUSTIFY(S(5),8,2),?70,$JUSTIFY(S(6),8,2)
QUIT
B SET S(1)=S(1)+$PIECE(A(1),"^",2)
SET S(4)=S(4)+$PIECE(A(1),"^")
SET T=0
FOR
SET T=$ORDER(^TMP($JOB,"Z",A,T))
if T=""!(LR("Q"))
QUIT
SET T(1)=^(T)
if $Y>(IOSL-6)
DO H3
if LR("Q")
QUIT
WRITE !!?3,T,?30,$JUSTIFY($PIECE(T(1),"^",2),5),?60,$JUSTIFY($PIECE(T(1),"^"),8,2)
DO C
if LR("Q")
QUIT
+1 QUIT
C SET S(2)=S(2)+$PIECE(T(1),"^",2)
SET S(5)=S(5)+$PIECE(T(1),"^")
SET P=0
+1 FOR
SET P=$ORDER(^TMP($JOB,"Z",A,T,P))
if P=""!(LR("Q"))
QUIT
SET P(1)=^(P)
SET S(3)=S(3)+$PIECE(P(1),"^",2)
SET S(6)=S(6)+$PIECE(P(1),"^")
if $Y>(IOSL-6)
DO H4
if LR("Q")
QUIT
WRITE !?6,P,?40,$JUSTIFY($PIECE(P(1),"^",2),5),?70,$JUSTIFY($PIECE(P(1),"^"),8,2)
+2 QUIT
A SET (A(1),A(2),T)=0
FOR
SET T=$ORDER(^TMP($JOB,"Z",A,T))
if T=""
QUIT
DO T
+1 SET ^TMP($JOB,"Z",A)=A(1)_"^"_A(2)
QUIT
T SET (T(1),T(2),P)=0
FOR
SET P=$ORDER(^TMP($JOB,"Z",A,T,P))
if P=""
QUIT
SET X=^(P)
SET X(1)=$PIECE(X,"^")
SET X(2)=$PIECE(X,"^",2)
SET T(1)=T(1)+X(1)
SET T(2)=T(2)+X(2)
+1 SET ^TMP($JOB,"Z",A,T)=T(1)_"^"_T(2)
SET A(1)=A(1)+T(1)
SET A(2)=A(2)+T(2)
QUIT
L SET X=^TMP($JOB,"D",C,0)
SET K=+X
SET Z=$PIECE(X,"^",2)
SET T=0
+1 FOR B=0:0
SET T=$ORDER(^TMP($JOB,"D",C,T))
if T=""!(LR("Q"))
QUIT
SET X=^(T)
SET Z(1)=$PIECE(X,"^",2)
SET K(1)=$PIECE(X,"^")
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
WRITE !,T,?31,$JUSTIFY(Z(1),6),?43,$JUSTIFY(Z(1)/Z*100,4,1),?55,$JUSTIFY(K(1),9,2)
+2 if LR("Q")
QUIT
WRITE !?31,"------",?55,"---------",!?31,$JUSTIFY(Z,6),?55,$JUSTIFY(K,9,2),!,LR("%")
SET LRT=LRT+K
QUIT
H DO H^LRBLJTS1
if LR("Q")
QUIT
WRITE !,"Treating specialty",?31,"# units",?40,"% total units",?58,"Cost",!,LR("%")
QUIT
H1 if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !!,C(1),":",!
FOR X=1:1:$LENGTH(C(1))
WRITE "-"
+1 QUIT
H2 DO H^LRBLJTS1
if LR("Q")
QUIT
+1 WRITE !,"Administrative",?20,"Component",?30,"Specialty",?40,"Physician",?50,"Component",?60,"Specialty",?70,"Physician",!,"Category",?23,"Units",?33,"Units",?43,"Units",?53,"Cost",?63,"Cost",?73,"Cost",!,LR("%")
SET A(3)=0
QUIT
H3 DO H2
if LR("Q")
QUIT
WRITE !,A(2)," (continued from ",LRQ-1,")"
QUIT
H4 DO H3
if LR("Q")
QUIT
WRITE !?6,T
QUIT
