LRBLJUT.m

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