source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBLAA.m@ 738

Last change on this file since 738 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1LRBLAA ;AVAMC/REG - XM:TX BY TREATING SPECIALTY REPORT ;9/11/95 14:02 ;
2 ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 D END,CK^LRBLPUS G:Y=-1 END
5 W !!?5,"Crossmatch:Transfusion Report by Treating Specialty and Physician",!
6 D B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001
7 W !!,"Print only summary of crossmatches and transfusions " S %=1 D YN^LRU G:%<1 END S LRF=$S(%=1:0,1:1)
8 S ZTRTN="QUE^LRBLAA" W ! D BEG^LRUTL G:POP!($D(ZTSK)) END
9QUE 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
10 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")
11 S LRQ(2)=0 D:LRF H Q:LR("Q") D A,^LRBLAA1
12 W ! W:IOST'?1"C".E @IOF D END^LRUTL,END Q
13C 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
14 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
15 Q
16M 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
17 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")
18 Q
19P 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
20 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")
21 Q
22W 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
23 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
24 Q
25U 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
26 Q
27V 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)
28 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
29 Q
30SET 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")
31 S ^TMP($J,T,M,P,+X,I)=$P(X,"^",10)_"^"_$S(Y]"":Y,1:"?")_"^"_Z_"^"_$S(V="A":"*",1:"")
32 Q
33 ;
34H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
35 D F^LRU W !,LRO(68)," CROSSMATCH:TRANSFUSIONS (from: ",LRSTR," to ",LRLST,")"
36 W:LRQ(2) !,"PATIENT",?19,"* = AUTOLOGOUS",?35,"SSN",!,"BLOOD SAMPLE DATE",?20,"UNIT ID",?35,"XM"
37 W !,LR("%") Q
38H1 D H Q:LR("Q") W !?20,"TREATING SPECIALTY: ",A Q
39H2 D H1 Q:LR("Q") W !?29,"PHYSICIAN: ",B Q
40H3 D H2 Q:LR("Q") W !,LRP,?32,SSN,?45,"(Cont'd from pg ",LRQ-1,")" Q
41A W !,"This report includes the following administrative categories:",!,"WHOLE BLOOD, RBC, FROZEN RBC, DEGLYC RBC, LEUCODEPLETED RBC, and WASHED RBC." Q
42 ;
43B 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"
44 W !,"IG=INCOMPATIBLE, GIVE WITH BLOOD BANK DIRECTOR APPROVAL",!,"CD, CF, and I are not included in crossmatch-transfusion calculations.",!,LR("%") Q
45END D V^LRU Q
46 ;^TMP($J,Rx Specialty,MD,Patient,Date,Unit)=Tx
Note: See TracBrowser for help on using the repository browser.