LRBLRCT ; IHS/DIR/AAB - CROSSMATCH:TRANSFUSION REPORT 6/19/96 09:50 ;
;;5.2;LR;**1002**;JUN 01, 1998
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
D END W !!?20,"Crossmatch:Transfusion Report",!
D B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001
S ZTRTN="QUE^LRBLRCT" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO S LRG("?")="UNKNOWN",LRF("?")=0,LRQ(2)=1
K ^TMP($J) D L^LRU,S^LRU,H S LR("F")=1 D C
W ! W:IOST'?1"C".E @IOF D END^LRUTL,END Q
C F A=LRSDT:0 S A=$O(^LRD(65,"AN",A)) Q:'A!(A>LRLDT) F I=0:0 S I=$O(^LRD(65,"AN",A,I)) Q:'I F P=0:0 S P=$O(^LRD(65,"AN",A,I,P)) Q:'P F B=0:0 S B=$O(^LRD(65,"AN",A,I,P,B)) Q:'B D SET
F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=^LR(A,0),Y=$P(X,"^",3),X=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),^TMP($J,"B",$P(X,"^"),A)=$P(X,"^",9)
D W Q:LR("Q") D STATS Q
SET S Z=$O(^LRD(65,I,3,0)) I Z S X=^(Z,0),Z=$P(X,"^",4)
S X=^LRD(65,I,2,P,1,B,0),Y=$P(X,"^",4),LRF(Y)=0,^TMP($J,P,+X,I)=$P(X,"^",10)_"^"_$S(Y]"":Y,1:"?")_"^"_Z Q
;
W ;S (LRP,LRX,LRX(1),LRT,LRZ)=0 F A=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S SSN=^(LRDFN),LRDPF=$P(^LR(LRDFN,0),U,2),LRZ=LRZ+1 W:LRZ>1 !,LR("%") D V
S (LRP,LRX,LRX(1),LRT,LRZ)=0 F A=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S HRCN=^(LRDFN),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRZ=LRZ+1 W:LRZ>1 !,LR("%") D V
;IHS/ANMC/CLS 11/1/95
Q
V ;D:$Y>(IOSL-6) H Q:LR("Q") D SSN^LRU W !,$J(LRZ,3),")",?6,LRP,?38,SSN F LRS=0:0 S LRS=$O(^TMP($J,LRDFN,LRS)) Q:'LRS!(LR("Q")) S Y=LRS D DT^LRU S LRD=Y D U
D:$Y>(IOSL-6) H Q:LR("Q") D SSN^LRU W !,$J(LRZ,3),")",?6,LRP,?38,HRCN F LRS=0:0 S LRS=$O(^TMP($J,LRDFN,LRS)) Q:'LRS!(LR("Q")) S Y=LRS D DT^LRU S LRD=Y D U ;IHS/ANMC/CLS 11/1/95
Q
U S LRI=0 F LRE=0:1 S LRI=$O(^TMP($J,LRDFN,LRS,LRI)) Q:'LRI S:'LRE LRX(1)=LRX(1)+1 S LRC=^(LRI),LRX=LRX+1,LRH=1 D:$P(LRC,"^")="TRANSFUSED" A D:$Y>(IOSL-6) H1 Q:LR("Q") D X
Q
X S Y=$P(LRC,"^",2),X=^LRD(65,LRI,0),C=$P(^LAB(66,$P(X,"^",4),0),"^",2) W !,LRD,?15,$P(X,"^"),?28,C,?33,Y,?38,$P(LRC,"^")
I $D(^LRD(65,"AP",LRDFN,LRI)) W " On x-match, not counted" W ?65,$E($P(LRC,U,3),1,14) S LRX=LRX-1 Q
S LRF(Y)=LRF(Y)+LRH Q
A S Y=$O(^LRD(65,LRI,9,0)) I 'Y S LRT=LRT+1 Q
S Y=^LRD(65,LRI,9,Y,0),Y(2)=$P(Y,"^",2),Y=+Y,Z=0
F X=0:0 S X=$O(^LRD(65,"B",Y(2),X)) Q:'X I $D(^LRD(65,X,0)),$P(^(0),"^",4)=Y S Z=$S($D(^LRD(65,X,9,0)):$P(^(0),"^",4),1:0) Q
I Z S LRH=$S(Z=1:0,1:+(1/Z)),LRT=LRT+$S(Z=1:1,1:LRH),LRX=LRX-1
Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"BLOOD BANK",!,"CROSSMATCH:TRANSFUSIONS (from: ",LRSTR," to ",LRLST,")"
W:LRQ(2) !,"Specimen date",?15,"Unit ID",?28,"Comp",?33,"XM",?38,"Release Reason",?65,"Location"
W !,LR("%") Q
H1 ;D H Q:LR("Q") W !,?6,LRP,?38,SSN Q
D H Q:LR("Q") W !,?6,LRP,?38,HRCN Q ;IHS/ANMC/CLS 11/1/95
H2 S LRQ(2)=0 D H Q
;
STATS D:$Y>(IOSL-11) H2 Q:LR("Q") I LRT["." S X=LRT D Z S LRT=X
W !,LR("%"),!,"Number of specimens crossmatched:",$J(LRX(1),6)
W !,"Total units crossmatched:",$J(LRX,6)
W !,"Total units transfused:",$J(LRT,6)
I LRT W !,"Crossmatch/transfusion ratio:",$J(LRX/LRT,9,2)
D:$Y>(IOSL-11) H2 Q:LR("Q") S A=0 F B=0:0 S A=$O(LRF(A)) Q:A=""!(LR("Q")) W:LRF(A) !,"Number of units ",$$EXTERNAL^DILFD(65.02,.04,"",A),"(",A,"):",$P(LRF(A),".")+$S($P(LRF(A),".",2)>5:1,1:0)
Q
;
Z S Z=$P(X,".",2),Y=$P(X,"."),X=Y+$S(Z>5:1,1:0) Q
END D V^LRU Q
LRBLRCT ; IHS/DIR/AAB - CROSSMATCH:TRANSFUSION REPORT 6/19/96 09:50 ;
+1 ;;5.2;LR;**1002**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+3 DO END
WRITE !!?20,"Crossmatch:Transfusion Report",!
+4 DO B^LRU
IF Y<0
GOTO END
SET LRLDT=LRLDT+.99
SET LRSDT=LRSDT-.0001
+5 SET ZTRTN="QUE^LRBLRCT"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
SET LRG("?")="UNKNOWN"
SET LRF("?")=0
SET LRQ(2)=1
+1 KILL ^TMP($JOB)
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
DO C
+2 WRITE !
IF IOST'?1"C".E
WRITE @IOF
DO END^LRUTL
DO END
QUIT
C FOR A=LRSDT:0
SET A=$ORDER(^LRD(65,"AN",A))
IF 'A!(A>LRLDT)
QUIT
FOR I=0:0
SET I=$ORDER(^LRD(65,"AN",A,I))
IF 'I
QUIT
FOR P=0:0
SET P=$ORDER(^LRD(65,"AN",A,I,P))
IF 'P
QUIT
FOR B=0:0
SET B=$ORDER(^LRD(65,"AN",A,I,P,B))
IF 'B
QUIT
DO SET
+1 FOR A=0:0
SET A=$ORDER(^TMP($JOB,A))
IF 'A
QUIT
SET X=^LR(A,0)
SET Y=$PIECE(X,"^",3)
SET X=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET X=@(X_Y_",0)")
SET ^TMP($JOB,"B",$PIECE(X,"^"),A)=$PIECE(X,"^",9)
+2 DO W
IF LR("Q")
QUIT
DO STATS
QUIT
SET SET Z=$ORDER(^LRD(65,I,3,0))
IF Z
SET X=^(Z,0)
SET Z=$PIECE(X,"^",4)
+1 SET X=^LRD(65,I,2,P,1,B,0)
SET Y=$PIECE(X,"^",4)
SET LRF(Y)=0
SET ^TMP($JOB,P,+X,I)=$PIECE(X,"^",10)_"^"_$SELECT(Y]"":Y,1:"?")_"^"_Z
QUIT
+2 ;
W ;S (LRP,LRX,LRX(1),LRT,LRZ)=0 F A=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP=""!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN!(LR("Q")) S SSN=^(LRDFN),LRDPF=$P(^LR(LRDFN,0),U,2),LRZ=LRZ+1 W:LRZ>1 !,LR("%") D V
+1 SET (LRP,LRX,LRX(1),LRT,LRZ)=0
FOR A=0:0
SET LRP=$ORDER(^TMP($JOB,"B",LRP))
IF LRP=""!(LR("Q"))
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP($JOB,"B",LRP,LRDFN))
IF 'LRDFN!(LR("Q"))
QUIT
SET HRCN=^(LRDFN)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
SET LRZ=LRZ+1
IF LRZ>1
WRITE !,LR("%")
DO V
+2 ;IHS/ANMC/CLS 11/1/95
+3 QUIT
V ;D:$Y>(IOSL-6) H Q:LR("Q") D SSN^LRU W !,$J(LRZ,3),")",?6,LRP,?38,SSN F LRS=0:0 S LRS=$O(^TMP($J,LRDFN,LRS)) Q:'LRS!(LR("Q")) S Y=LRS D DT^LRU S LRD=Y D U
+1 ;IHS/ANMC/CLS 11/1/95
IF $Y>(IOSL-6)
DO H
IF LR("Q")
QUIT
DO SSN^LRU
WRITE !,$JUSTIFY(LRZ,3),")",?6,LRP,?38,HRCN
FOR LRS=0:0
SET LRS=$ORDER(^TMP($JOB,LRDFN,LRS))
IF 'LRS!(LR("Q"))
QUIT
SET Y=LRS
DO DT^LRU
SET LRD=Y
DO U
+2 QUIT
U SET LRI=0
FOR LRE=0:1
SET LRI=$ORDER(^TMP($JOB,LRDFN,LRS,LRI))
IF 'LRI
QUIT
IF 'LRE
SET LRX(1)=LRX(1)+1
SET LRC=^(LRI)
SET LRX=LRX+1
SET LRH=1
IF $PIECE(LRC,"^")="TRANSFUSED"
DO A
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
DO X
+1 QUIT
X SET Y=$PIECE(LRC,"^",2)
SET X=^LRD(65,LRI,0)
SET C=$PIECE(^LAB(66,$PIECE(X,"^",4),0),"^",2)
WRITE !,LRD,?15,$PIECE(X,"^"),?28,C,?33,Y,?38,$PIECE(LRC,"^")
+1 IF $DATA(^LRD(65,"AP",LRDFN,LRI))
WRITE " On x-match, not counted"
WRITE ?65,$EXTRACT($PIECE(LRC,U,3),1,14)
SET LRX=LRX-1
QUIT
+2 SET LRF(Y)=LRF(Y)+LRH
QUIT
A SET Y=$ORDER(^LRD(65,LRI,9,0))
IF 'Y
SET LRT=LRT+1
QUIT
+1 SET Y=^LRD(65,LRI,9,Y,0)
SET Y(2)=$PIECE(Y,"^",2)
SET Y=+Y
SET Z=0
+2 FOR X=0:0
SET X=$ORDER(^LRD(65,"B",Y(2),X))
IF 'X
QUIT
IF $DATA(^LRD(65,X,0))
IF $PIECE(^(0),"^",4)=Y
SET Z=$SELECT($DATA(^LRD(65,X,9,0)):$PIECE(^(0),"^",4),1:0)
QUIT
+3 IF Z
SET LRH=$SELECT(Z=1:0,1:+(1/Z))
SET LRT=LRT+$SELECT(Z=1:1,1:LRH)
SET LRX=LRX-1
+4 QUIT
+5 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"BLOOD BANK",!,"CROSSMATCH:TRANSFUSIONS (from: ",LRSTR," to ",LRLST,")"
+2 IF LRQ(2)
WRITE !,"Specimen date",?15,"Unit ID",?28,"Comp",?33,"XM",?38,"Release Reason",?65,"Location"
+3 WRITE !,LR("%")
QUIT
H1 ;D H Q:LR("Q") W !,?6,LRP,?38,SSN Q
+1 ;IHS/ANMC/CLS 11/1/95
DO H
IF LR("Q")
QUIT
WRITE !,?6,LRP,?38,HRCN
QUIT
H2 SET LRQ(2)=0
DO H
QUIT
+1 ;
STATS IF $Y>(IOSL-11)
DO H2
IF LR("Q")
QUIT
IF LRT["."
SET X=LRT
DO Z
SET LRT=X
+1 WRITE !,LR("%"),!,"Number of specimens crossmatched:",$JUSTIFY(LRX(1),6)
+2 WRITE !,"Total units crossmatched:",$JUSTIFY(LRX,6)
+3 WRITE !,"Total units transfused:",$JUSTIFY(LRT,6)
+4 IF LRT
WRITE !,"Crossmatch/transfusion ratio:",$JUSTIFY(LRX/LRT,9,2)
+5 IF $Y>(IOSL-11)
DO H2
IF LR("Q")
QUIT
SET A=0
FOR B=0:0
SET A=$ORDER(LRF(A))
IF A=""!(LR("Q"))
QUIT
IF LRF(A)
WRITE !,"Number of units ",$$EXTERNAL^DILFD(65.02,.04,"",A),"(",A,"):",$PIECE(LRF(A),".")+$SELECT($PIECE(LRF(A),".",2)>5:1,1:0)
+6 QUIT
+7 ;
Z SET Z=$PIECE(X,".",2)
SET Y=$PIECE(X,".")
SET X=Y+$SELECT(Z>5:1,1:0)
QUIT
END DO V^LRU
QUIT
