- LRBLJTS1 ; IHS/DIR/FJE - TRANSFUSION STATS 3/3/93 22:49 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- 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,19),?50,$J(V(1),9,2),?61,$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",?61,"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
- LRBLJTS1 ; IHS/DIR/FJE - TRANSFUSION STATS 3/3/93 22:49 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 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
- +5 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,19),?50,$JUSTIFY(V(1),9,2),?61,$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",?61,"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
