| [613] | 1 | LRBLJUT ;AVAMC/REG - BB INVENTORY FINAL DISPOSITION ;3/9/94 14:02 ;
|
|---|
| 2 | ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
|
|---|
| 3 | ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
|
|---|
| 4 | D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
|
|---|
| 5 | W !!,"Units of RED BLOOD CELLS transfused for a treating specialty"
|
|---|
| 6 | S DIC=45.7,DIC(0)="AEQM" D ^DIC G:Y<1 END S LRT=$P(Y,U,2) D ^DIC K DIC S:Y>0 LRT=LRT_", "_$P(Y,U,2)
|
|---|
| 7 | D B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001
|
|---|
| 8 | S ZTRTN="QUE^LRBLJUT" D BEG^LRUTL G:POP!($D(ZTSK)) END
|
|---|
| 9 | QUE U IO D L^LRU,S^LRU K ^TMP($J) S (LRY,LRP)=0 D H
|
|---|
| 10 | F B=0:0 S LRSDT=$O(^LRD(65,"A",LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) F LRI=0:0 S LRI=$O(^LRD(65,"A",LRSDT,LRI)) Q:'LRI I $D(^LRD(65,LRI,6)),$P(^(6),"^",3)]"",LRT[$P(^(6),"^",3),$D(^(0)) S X=$P(^(0),"^",4) D:$P(^LAB(66,X,0),"^",19) SET
|
|---|
| 11 | S Z=0 F LRC=0:1 S Z=$O(^TMP($J,Z)) Q:'Z S X=^LR(Z,0),Y=$P(X,"^",3),X=^DIC($P(X,"^",2),0,"GL"),X=@(X_Y_",0)"),^TMP($J,"B",$P(X,"^"),Z)=$P(X,"^",9)
|
|---|
| 12 | F LRA=0:0 S LRP=$O(^TMP($J,"B",LRP)) Q:LRP="" F LRDFN=0:0 S LRDFN=$O(^TMP($J,"B",LRP,LRDFN)) Q:'LRDFN S SSN=^(LRDFN),LRDPF=$P(^LR(LRDFN,0),U,2) D SSN^LRU D A
|
|---|
| 13 | W !!,"TOTAL PATIENTS: ",LRC,?31,"TOTAL UNITS: ",LRY,!,"AVERAGE UNITS/PATIENT: ",$S(LRC:$J(LRY/LRC,5,2),1:"") D END^LRUTL,END Q
|
|---|
| 14 | A S LRX=^TMP($J,LRDFN),LRY=LRY+LRX D:$Y>(IOSL-6) H W !,LRP,?31,SSN,?50,$J(LRX,4) Q
|
|---|
| 15 | SET S X=+^LRD(65,LRI,6) I X S:'$D(^TMP($J,X)) ^(X)=0 S ^(X)=^(X)+1
|
|---|
| 16 | Q
|
|---|
| 17 | H S LRQ=LRQ+1,X="N",%DT="T" D ^%DT,D^LRU W @IOF,!,Y,?23,"BLOOD BANK ",LRQ(1),?(IOM-10),"Pg:",LRQ
|
|---|
| 18 | W !,"Treating ",$S(LRT[",":"Specialties",1:"Specialty"),": ",LRT,!,"Units RBC transfused from ",LRSTR," to ",LRLST,!,"Patient",?31,"SSN",?50,"# Units",!,LR("%") Q
|
|---|
| 19 | END D V^LRU Q
|
|---|
