LRBLJUT ;AVAMC/REG - BB INVENTORY FINAL DISPOSITION ;3/9/94 14:02 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
D END S X="BLOOD BANK" D ^LRUTL G:Y=-1 END
W !!,"Units of RED BLOOD CELLS transfused for a treating specialty"
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)
D B^LRU G:Y<0 END S LRLDT=LRLDT+.99,LRSDT=LRSDT-.0001
S ZTRTN="QUE^LRBLJUT" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D L^LRU,S^LRU K ^TMP($J) S (LRY,LRP)=0 D H
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
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)
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
W !!,"TOTAL PATIENTS: ",LRC,?31,"TOTAL UNITS: ",LRY,!,"AVERAGE UNITS/PATIENT: ",$S(LRC:$J(LRY/LRC,5,2),1:"") D END^LRUTL,END Q
A S LRX=^TMP($J,LRDFN),LRY=LRY+LRX D:$Y>(IOSL-6) H W !,LRP,?31,SSN,?50,$J(LRX,4) Q
SET S X=+^LRD(65,LRI,6) I X S:'$D(^TMP($J,X)) ^(X)=0 S ^(X)=^(X)+1
Q
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
W !,"Treating ",$S(LRT[",":"Specialties",1:"Specialty"),": ",LRT,!,"Units RBC transfused from ",LRSTR," to ",LRLST,!,"Patient",?31,"SSN",?50,"# Units",!,LR("%") Q
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLJUT 1692 printed Apr 09, 2024@21:06:52 Page 2
LRBLJUT ;AVAMC/REG - BB INVENTORY FINAL DISPOSITION ;3/9/94 14:02 ;
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 DO END
SET X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
+4 WRITE !!,"Units of RED BLOOD CELLS transfused for a treating specialty"
+5 SET DIC=45.7
SET DIC(0)="AEQM"
DO ^DIC
if Y<1
GOTO END
SET LRT=$PIECE(Y,U,2)
DO ^DIC
KILL DIC
if Y>0
SET LRT=LRT_", "_$PIECE(Y,U,2)
+6 DO B^LRU
if Y<0
GOTO END
SET LRLDT=LRLDT+.99
SET LRSDT=LRSDT-.0001
+7 SET ZTRTN="QUE^LRBLJUT"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO L^LRU
DO S^LRU
KILL ^TMP($JOB)
SET (LRY,LRP)=0
DO H
+1 FOR B=0:0
SET LRSDT=$ORDER(^LRD(65,"A",LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^LRD(65,"A",LRSDT,LRI))
if 'LRI
QUIT
IF $DATA(^LRD(65,LRI,6))
IF $PIECE(^(6),"^",3)]""
IF LRT[$PIECE(^(6),"^",3)
IF $DATA(^(0))
SET X=$PIECE(^(0),"^",4)
if $PIECE(^LAB(66,X,0),"^",19)
DO SET
+2 SET Z=0
FOR LRC=0:1
SET Z=$ORDER(^TMP($JOB,Z))
if 'Z
QUIT
SET X=^LR(Z,0)
SET Y=$PIECE(X,"^",3)
SET X=^DIC($PIECE(X,"^",2),0,"GL")
SET X=@(X_Y_",0)")
SET ^TMP($JOB,"B",$PIECE(X,"^"),Z)=$PIECE(X,"^",9)
+3 FOR LRA=0:0
SET LRP=$ORDER(^TMP($JOB,"B",LRP))
if LRP=""
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP($JOB,"B",LRP,LRDFN))
if 'LRDFN
QUIT
SET SSN=^(LRDFN)
SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
DO SSN^LRU
DO A
+4 WRITE !!,"TOTAL PATIENTS: ",LRC,?31,"TOTAL UNITS: ",LRY,!,"AVERAGE UNITS/PATIENT: ",$SELECT(LRC:$JUSTIFY(LRY/LRC,5,2),1:"")
DO END^LRUTL
DO END
QUIT
A SET LRX=^TMP($JOB,LRDFN)
SET LRY=LRY+LRX
if $Y>(IOSL-6)
DO H
WRITE !,LRP,?31,SSN,?50,$JUSTIFY(LRX,4)
QUIT
SET SET X=+^LRD(65,LRI,6)
IF X
if '$DATA(^TMP($JOB,X))
SET ^(X)=0
SET ^(X)=^(X)+1
+1 QUIT
H SET LRQ=LRQ+1
SET X="N"
SET %DT="T"
DO ^%DT
DO D^LRU
WRITE @IOF,!,Y,?23,"BLOOD BANK ",LRQ(1),?(IOM-10),"Pg:",LRQ
+1 WRITE !,"Treating ",$SELECT(LRT[",":"Specialties",1:"Specialty"),": ",LRT,!,"Units RBC transfused from ",LRSTR," to ",LRLST,!,"Patient",?31,"SSN",?50,"# Units",!,LR("%")
QUIT
END DO V^LRU
QUIT
