- LRBLAA ;AVAMC/REG - XM:TX BY TREATING SPECIALTY REPORT ;9/11/95 14:02 ;
- ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
- ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- D END,CK^LRBLPUS G:Y=-1 END
- W !!?5,"Crossmatch:Transfusion Report by Treating Specialty and Physician",!
- D B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001
- W !!,"Print only summary of crossmatches and transfusions " S %=1 D YN^LRU G:%<1 END S LRF=$S(%=1:0,1:1)
- S ZTRTN="QUE^LRBLAA" W ! D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO S LR("M")=$P($G(^LAB(69.9,1,8.1,+DUZ(2),0)),U,6),LRQ(2)=$S(LRF:1,1:0) K ^TMP($J) D L^LRU,S^LRU,H S (LRL,LRM)=0 I LRF D B S LR("F")=1
- D C Q:LR("Q") I LRF W !!,"ALL TREATING SPECIALTIES",?32,"Total Xm'd:",?43,$J(LRL,4),?52,"Tx'd:",?55,$J(LRM,4),?65,"C/T: " W $S(LRM:$J(LRL/LRM,5,3),1:"NA")
- S LRQ(2)=0 D:LRF H Q:LR("Q") D A,^LRBLAA1
- 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
- S A=0 F A(1)=1:1 S A=$O(^TMP($J,A)) Q:A=""!(LR("Q")) S (LRJ,LRT)=0 D:A(1)>1&(LRF) H Q:LR("Q") W:LRF !?20,"TREATING SPECIALTY: ",A D M
- Q
- M S B=0 F B(1)=0:0 S B=$O(^TMP($J,A,B)) Q:B=""!(LR("Q")) D:$Y>(IOSL-6)&(LRF) H1 Q:LR("Q") S (LRK,LRD)=0 W:LRF !!?29,"PHYSICIAN: ",B D P
- Q:LR("Q") S ^TMP($J,A)=LRJ_"^"_LRT I LRF D:$Y>(IOSL-6) H Q:LR("Q") W !!!,A,?32,"Units Xm'd:",?43,$J(LRJ,4),?52,"Tx'd:",?55,$J(LRT,4),?65,"C/T: " W $S(LRT:$J(LRJ/LRT,5,3),1:"NA")
- Q
- P F LRDFN=0:0 S LRDFN=$O(^TMP($J,A,B,LRDFN)) Q:'LRDFN!(LR("Q")) D:$Y>(IOSL-6)&(LRF) H2 Q:LR("Q") D W
- Q:LR("Q") S ^TMP($J,A,B)=LRK_"^"_LRD I LRF W !!,B,?32,"Units Xm'd:",?43,$J(LRK,4),?52,"Tx'd:",?55,$J(LRD,4),?65,"C/T: " W $S(LRD:$J(LRK/LRD,5,3),1:"NA")
- Q
- W I LRF S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU W !,LRP,?32,SSN
- F F=0:0 S F=$O(^TMP($J,A,B,LRDFN,F)) Q:'F!(LR("Q")) S Y=F D DT^LRU S LRY=Y D U
- Q
- U F G=0:0 S G=$O(^TMP($J,A,B,LRDFN,F,G)) Q:'G!(LR("Q")) S LRE=^(G) D:$Y>(IOSL-6)&(LRF) H3 Q:LR("Q") S X=$P(LRE,"^"),Y=$P(LRE,"^",2) D V
- Q
- V W:LRF !,LRY,?19,$P(LRE,"^",4),?20,$P(LRE,"^",3),?35,$P(LRE,"^",2),?38,X I LR("M"),LRF W ?60,$E($P($G(^DIC(4,+$P($G(^LRD(65,G,0)),U,16),0)),U),1,19)
- I Y="C"!(Y="IG") S LRJ=LRJ+1,LRK=LRK+1,LRL=LRL+1 I X="TRANSFUSED" S LRT=LRT+1,LRD=LRD+1,LRM=LRM+1
- Q
- SET S X=^LRD(65,I,0),V=$S($D(^(8)):$P(^(8),"^",3),1:0),C=$P(X,"^",4),Z=$P(X,"^"),C=+$P(^LAB(66,C,0),"^",26),X=^LRD(65,I,2,P,1,B,0),Y=$P(X,"^",4),T=$S($P(X,"^",2)]"":$P(X,"^",2),1:"UNKNOWN"),M=$S($P(X,"^",3)]"":$P(X,"^",3),1:"UNKNOWN")
- S ^TMP($J,T,M,P,+X,I)=$P(X,"^",10)_"^"_$S(Y]"":Y,1:"?")_"^"_Z_"^"_$S(V="A":"*",1:"")
- Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,LRO(68)," CROSSMATCH:TRANSFUSIONS (from: ",LRSTR," to ",LRLST,")"
- W:LRQ(2) !,"PATIENT",?19,"* = AUTOLOGOUS",?35,"SSN",!,"BLOOD SAMPLE DATE",?20,"UNIT ID",?35,"XM"
- W !,LR("%") Q
- H1 D H Q:LR("Q") W !?20,"TREATING SPECIALTY: ",A Q
- H2 D H1 Q:LR("Q") W !?29,"PHYSICIAN: ",B Q
- H3 D H2 Q:LR("Q") W !,LRP,?32,SSN,?45,"(Cont'd from pg ",LRQ-1,")" Q
- A W !,"This report includes the following administrative categories:",!,"WHOLE BLOOD, RBC, FROZEN RBC, DEGLYC RBC, LEUCODEPLETED RBC, and WASHED RBC." Q
- ;
- B D A W !!,"The following abbreviations are used to indicate crossmatch results:",!,"C=COMPATIBLE",!,"CD=COMPATIBLE, DON'T TRANSFUSE",!,"CF=COMPATIBLE, FURTHER STUDY NEEDED",!,"I=INCOMPATIBLE, UNSAFE TO TRANSFUSE"
- W !,"IG=INCOMPATIBLE, GIVE WITH BLOOD BANK DIRECTOR APPROVAL",!,"CD, CF, and I are not included in crossmatch-transfusion calculations.",!,LR("%") Q
- END D V^LRU Q
- ;^TMP($J,Rx Specialty,MD,Patient,Date,Unit)=Tx
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLAA 3814 printed Jan 18, 2025@03:10:53 Page 2
- LRBLAA ;AVAMC/REG - XM:TX BY TREATING SPECIALTY REPORT ;9/11/95 14:02 ;
- +1 ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
- +2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
- +3 DO END
- DO CK^LRBLPUS
- if Y=-1
- GOTO END
- +4 WRITE !!?5,"Crossmatch:Transfusion Report by Treating Specialty and Physician",!
- +5 DO B^LRU
- if Y<0
- GOTO END
- SET LRLDT=LRLDT+.99
- SET LRSDT=LRSDT-.0001
- +6 WRITE !!,"Print only summary of crossmatches and transfusions "
- SET %=1
- DO YN^LRU
- if %<1
- GOTO END
- SET LRF=$SELECT(%=1:0,1:1)
- +7 SET ZTRTN="QUE^LRBLAA"
- WRITE !
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- SET LR("M")=$PIECE($GET(^LAB(69.9,1,8.1,+DUZ(2),0)),U,6)
- SET LRQ(2)=$SELECT(LRF:1,1:0)
- KILL ^TMP($JOB)
- DO L^LRU
- DO S^LRU
- DO H
- SET (LRL,LRM)=0
- IF LRF
- DO B
- SET LR("F")=1
- +1 DO C
- if LR("Q")
- QUIT
- IF LRF
- WRITE !!,"ALL TREATING SPECIALTIES",?32,"Total Xm'd:",?43,$JUSTIFY(LRL,4),?52,"Tx'd:",?55,$JUSTIFY(LRM,4),?65,"C/T: "
- WRITE $SELECT(LRM:$JUSTIFY(LRL/LRM,5,3),1:"NA")
- +2 SET LRQ(2)=0
- if LRF
- DO H
- if LR("Q")
- QUIT
- DO A
- DO ^LRBLAA1
- +3 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 SET A=0
- FOR A(1)=1:1
- SET A=$ORDER(^TMP($JOB,A))
- if A=""!(LR("Q"))
- QUIT
- SET (LRJ,LRT)=0
- if A(1)>1&(LRF)
- DO H
- if LR("Q")
- QUIT
- if LRF
- WRITE !?20,"TREATING SPECIALTY: ",A
- DO M
- +2 QUIT
- M SET B=0
- FOR B(1)=0:0
- SET B=$ORDER(^TMP($JOB,A,B))
- if B=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)&(LRF)
- DO H1
- if LR("Q")
- QUIT
- SET (LRK,LRD)=0
- if LRF
- WRITE !!?29,"PHYSICIAN: ",B
- DO P
- +1 if LR("Q")
- QUIT
- SET ^TMP($JOB,A)=LRJ_"^"_LRT
- IF LRF
- if $Y>(IOSL-6)
- DO H
- if LR("Q")
- QUIT
- WRITE !!!,A,?32,"Units Xm'd:",?43,$JUSTIFY(LRJ,4),?52,"Tx'd:",?55,$JUSTIFY(LRT,4),?65,"C/T: "
- WRITE $SELECT(LRT:$JUSTIFY(LRJ/LRT,5,3),1:"NA")
- +2 QUIT
- P FOR LRDFN=0:0
- SET LRDFN=$ORDER(^TMP($JOB,A,B,LRDFN))
- if 'LRDFN!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)&(LRF)
- DO H2
- if LR("Q")
- QUIT
- DO W
- +1 if LR("Q")
- QUIT
- SET ^TMP($JOB,A,B)=LRK_"^"_LRD
- IF LRF
- WRITE !!,B,?32,"Units Xm'd:",?43,$JUSTIFY(LRK,4),?52,"Tx'd:",?55,$JUSTIFY(LRD,4),?65,"C/T: "
- WRITE $SELECT(LRD:$JUSTIFY(LRK/LRD,5,3),1:"NA")
- +2 QUIT
- W IF LRF
- SET X=^LR(LRDFN,0)
- SET Y=$PIECE(X,"^",3)
- SET (LRDPF,X)=$PIECE(X,"^",2)
- SET X=^DIC(X,0,"GL")
- SET X=@(X_Y_",0)")
- SET LRP=$PIECE(X,"^")
- SET SSN=$PIECE(X,"^",9)
- DO SSN^LRU
- WRITE !,LRP,?32,SSN
- +1 FOR F=0:0
- SET F=$ORDER(^TMP($JOB,A,B,LRDFN,F))
- if 'F!(LR("Q"))
- QUIT
- SET Y=F
- DO DT^LRU
- SET LRY=Y
- DO U
- +2 QUIT
- U FOR G=0:0
- SET G=$ORDER(^TMP($JOB,A,B,LRDFN,F,G))
- if 'G!(LR("Q"))
- QUIT
- SET LRE=^(G)
- if $Y>(IOSL-6)&(LRF)
- DO H3
- if LR("Q")
- QUIT
- SET X=$PIECE(LRE,"^")
- SET Y=$PIECE(LRE,"^",2)
- DO V
- +1 QUIT
- V if LRF
- WRITE !,LRY,?19,$PIECE(LRE,"^",4),?20,$PIECE(LRE,"^",3),?35,$PIECE(LRE,"^",2),?38,X
- IF LR("M")
- IF LRF
- WRITE ?60,$EXTRACT($PIECE($GET(^DIC(4,+$PIECE($GET(^LRD(65,G,0)),U,16),0)),U),1,19)
- +1 IF Y="C"!(Y="IG")
- SET LRJ=LRJ+1
- SET LRK=LRK+1
- SET LRL=LRL+1
- IF X="TRANSFUSED"
- SET LRT=LRT+1
- SET LRD=LRD+1
- SET LRM=LRM+1
- +2 QUIT
- SET SET X=^LRD(65,I,0)
- SET V=$SELECT($DATA(^(8)):$PIECE(^(8),"^",3),1:0)
- SET C=$PIECE(X,"^",4)
- SET Z=$PIECE(X,"^")
- SET C=+$PIECE(^LAB(66,C,0),"^",26)
- SET X=^LRD(65,I,2,P,1,B,0)
- SET Y=$PIECE(X,"^",4)
- SET T=$SELECT($PIECE(X,"^",2)]"":$PIECE(X,"^",2),1:"UNKNOWN")
- SET M=$SELECT($PIECE(X,"^",3)]"":$PIECE(X,"^",3),1:"UNKNOWN")
- +1 SET ^TMP($JOB,T,M,P,+X,I)=$PIECE(X,"^",10)_"^"_$SELECT(Y]"":Y,1:"?")_"^"_Z_"^"_$SELECT(V="A":"*",1:"")
- +2 QUIT
- +3 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,LRO(68)," CROSSMATCH:TRANSFUSIONS (from: ",LRSTR," to ",LRLST,")"
- +2 if LRQ(2)
- WRITE !,"PATIENT",?19,"* = AUTOLOGOUS",?35,"SSN",!,"BLOOD SAMPLE DATE",?20,"UNIT ID",?35,"XM"
- +3 WRITE !,LR("%")
- QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !?20,"TREATING SPECIALTY: ",A
- QUIT
- H2 DO H1
- if LR("Q")
- QUIT
- WRITE !?29,"PHYSICIAN: ",B
- QUIT
- H3 DO H2
- if LR("Q")
- QUIT
- WRITE !,LRP,?32,SSN,?45,"(Cont'd from pg ",LRQ-1,")"
- QUIT
- A WRITE !,"This report includes the following administrative categories:",!,"WHOLE BLOOD, RBC, FROZEN RBC, DEGLYC RBC, LEUCODEPLETED RBC, and WASHED RBC."
- QUIT
- +1 ;
- B DO A
- WRITE !!,"The following abbreviations are used to indicate crossmatch results:",!,"C=COMPATIBLE",!,"CD=COMPATIBLE, DON'T TRANSFUSE",!,"CF=COMPATIBLE, FURTHER STUDY NEEDED",!,"I=INCOMPATIBLE, UNSAFE TO TRANSFUSE"
- +1 WRITE !,"IG=INCOMPATIBLE, GIVE WITH BLOOD BANK DIRECTOR APPROVAL",!,"CD, CF, and I are not included in crossmatch-transfusion calculations.",!,LR("%")
- QUIT
- END DO V^LRU
- QUIT
- +1 ;^TMP($J,Rx Specialty,MD,Patient,Date,Unit)=Tx