- LRBLJUT ; IHS/DIR/FJE - BB INVENTORY FINAL DISPOSITION 3/9/94 14:02 ;
- ;;5.2;LR;;NOV 01, 1997
- ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- 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
- 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),DFN=$P(^(0),U,3) D SSN^LRU D A ;IHS/ANMC/CLS 11/1/95
- 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
- S LRX=^TMP($J,LRDFN),LRY=LRY+LRX D:$Y>(IOSL-6) H W !,LRP,?31,HRCN,?50,$J(LRX,4) Q ;IHS/ANMC/CLS 11/1/95
- 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
- W !,"Treating ",$S(LRT[",":"Specialties",1:"Specialty"),": ",LRT,!,"Units RBC transfused from ",LRSTR," to ",LRLST,!,"Patient",?31,"HRCN",?50,"# Units",!,LR("%") Q ;IHS/ANMC/CLS 11/1/95
- END D V^LRU Q
- LRBLJUT ; IHS/DIR/FJE - BB INVENTORY FINAL DISPOSITION 3/9/94 14:02 ;
- +1 ;;5.2;LR;;NOV 01, 1997
- +2 ;
- +3 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +4 DO END
- SET X="BLOOD BANK"
- DO ^LRUTL
- IF Y=-1
- GOTO END
- +5 WRITE !!,"Units of RED BLOOD CELLS transfused for a treating specialty"
- +6 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)
- +7 DO B^LRU
- IF Y<0
- GOTO END
- SET LRLDT=LRLDT+.99
- SET LRSDT=LRSDT-.0001
- +8 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 ;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
- +4 ;IHS/ANMC/CLS 11/1/95
- 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)
- SET DFN=$PIECE(^(0),U,3)
- DO SSN^LRU
- DO A
- +5 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 ;S LRX=^TMP($J,LRDFN),LRY=LRY+LRX D:$Y>(IOSL-6) H W !,LRP,?31,SSN,?50,$J(LRX,4) Q
- +1 ;IHS/ANMC/CLS 11/1/95
- SET LRX=^TMP($JOB,LRDFN)
- SET LRY=LRY+LRX
- IF $Y>(IOSL-6)
- DO H
- WRITE !,LRP,?31,HRCN,?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 ;W !,"Treating ",$S(LRT[",":"Specialties",1:"Specialty"),": ",LRT,!,"Units RBC transfused from ",LRSTR," to ",LRLST,!,"Patient",?31,"SSN",?50,"# Units",!,LR("%") Q
- +2 ;IHS/ANMC/CLS 11/1/95
- WRITE !,"Treating ",$SELECT(LRT[",":"Specialties",1:"Specialty"),": ",LRT,!,"Units RBC transfused from ",LRSTR," to ",LRLST,!,"Patient",?31,"HRCN",?50,"# Units",!,LR("%")
- QUIT
- END DO V^LRU
- QUIT
