- 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
