- LRBLA1 ; IHS/DIR/AAB - BB ADM DATA 07:45 ; [ 6/21/96 ]
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- K LRB D W S LRF=1 D H Q:LR("Q") D ^LRBLA2
- Q:$O(^TMP("LR",$J,"N","T",0))=""&($O(^TMP("LR",$J,"N","P",0))="") D H Q:LR("Q") W !!,"COUNT",?7,"TEMPORARY DEFERRAL REASON"
- F A=0:0 S A=$O(^TMP("LR",$J,"N","T",A)) Q:'A S Y=^(A),X=9999999-Y,^TMP("LR",$J,"Z",X,A)=Y
- F LRX=0:0 S LRX=$O(^TMP("LR",$J,"Z",LRX)) Q:'LRX!(LR("Q")) D A Q:LR("Q")
- Q:LR("Q") D:$Y>(IOSL-6) H Q:LR("Q") W !!,"PERMANENT DEFERRALS:",!,"--------------------" S LRP=0
- F LRA=0:0 S LRP=$O(^TMP("LR",$J,"N","P",LRP)) Q:LRP=""!(LR("Q")) F LRB=0:0 S LRB=$O(^TMP("LR",$J,"N","P",LRP,LRB)) Q:'LRB!(LR("Q")) F LRD=0:0 S LRD=$O(^TMP("LR",$J,"N","P",LRP,LRB,LRD)) Q:'LRD!(LR("Q")) D D
- Q
- D D:$Y>(IOSL-6) H3 Q:LR("Q") S Y=9999999-LRD D D^LRU S LRY=Y W !!,LRP,?32,"Deferral Date: ",Y K ^TMP($J)
- S LRE=0 F LRG=0:1 S LRE=$O(^LRE(LRB,99,LRE)) Q:'LRE!(LR("Q")) S LRX=^(LRE,0) D:$Y>(IOSL-6) H4 Q:LR("Q") S X=LRX D ^DIWP
- D:LRG ^DIWW Q
- ;
- A F LRA=0:0 S LRA=$O(^TMP("LR",$J,"Z",LRX,LRA)) Q:'LRA!(LR("Q")) S LRB=^(LRA),X=$S($D(^LAB(65.4,LRA,0)):^(0),1:""),LRD=$S($P(X,"^",3)]"":$P(X,"^",3),1:$P(X,"^")) D:$Y>(IOSL-6) H1 Q:LR("Q") W !,$J(LRB,4),?7,LRD
- Q
- ;
- S S X=" UNITS",LRF=0,LRB("S")="TOTAL"_X,LRB("H")="HOMOLOGOUS"_X,LRB("A")="AUTOLOGOUS"_X,LRB("T")="THERAPEUTIC"_X,LRB("D")="DIRECTED"_X D S^LRU
- S Y=$P(^DD(66,.26,0),"^",3) F T="T","H","A","D","S" F A=1:1 S X=$P(Y,";",A) Q:X="" S Z=$P(X,":"),LRA(Z)=$P(X,":",2) F B="A","B","C","D","E","F" S ^TMP("LR",$J,T,B,Z)=0
- F T=12:1:20 F E="WA","WD","WH","WT","PA","PD","PH","PT","CA","CD","CH","CT" S ^TMP("LR",$J,"Y",T,E)=0
- F E="WA","WD","WH","WT","PA","PD","PH","PT","CA","CD","CH","CT" S ^TMP("LR",$J,"Y",E)=0
- F T="WH","WA","WT","WD","PH","PA","PT","PD","CH","CA","CT","CD" S ^TMP("LR",$J,T)=0,^(T,"D")=0
- S ^TMP("LR",$J,"N")=0,^("N","P")=0,^("T")=0 Q
- W S X="WHOLE BLOOD",LRB("WH")=X_" HOMOLOGOUS",LRB("WA")=X_" AUTOLOGOUS",LRB("WD")=X_" DIRECTED",LRB("WT")=X_" THERAPEUTIC"
- S X="PLASMAPHERESIS",LRB("PH")=X_" HOMOLOGOUS",LRB("PA")=X_" AUTOLOGOUS",LRB("PT")=X_" THERAPEUTIC",LRB("PD")=X_" DIRECTED"
- S X="CYTAPHERESIS" S LRB("CH")=X_" HOMOLOGOUS",LRB("CA")=X_" AUTOLOGOUS",LRB("CT")=X_" THERAPEUTIC",LRB("CD")=X_" DIRECTED"
- S LRB("N")="NO DONATION" Q
- ;
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"Blood Bank Administrative Data from: ",LRSTR," to ",LRLST W:LRC !,"DIVISION: ",LRC(2) W !,LR("%") Q:LRF
- W !,"| ",LRB(LRB),?20,"|",?30,"SOURCE",?40,"|",?50,"INVENTORY DISPOSITION",?79,"|"
- W !,LR("%"),!,"|",?5,"COMPONENT",?20,"|Prepared",?30,"|Received",?40,"|Transfused",?51,"|Shipped",?59,"|Outdated",?69,"|Discarded",?79,"|",!,LR("%")
- Q
- H1 D H Q:LR("Q") W !,"COUNT",?7,"TEMPORARY DEFERRAL REASON" Q
- H3 D H Q:LR("Q") W !,"PERMANENT DEFERRALS:" Q
- H4 D H3 Q:LR("Q") W !,LRP,?31,"Deferral Date: ",LRY Q
- LRBLA1 ; IHS/DIR/AAB - BB ADM DATA 07:45 ; [ 6/21/96 ]
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 KILL LRB
- DO W
- SET LRF=1
- DO H
- IF LR("Q")
- QUIT
- DO ^LRBLA2
- +4 IF $ORDER(^TMP("LR",$JOB,"N","T",0))=""&($ORDER(^TMP("LR",$JOB,"N","P",0))="")
- QUIT
- DO H
- IF LR("Q")
- QUIT
- WRITE !!,"COUNT",?7,"TEMPORARY DEFERRAL REASON"
- +5 FOR A=0:0
- SET A=$ORDER(^TMP("LR",$JOB,"N","T",A))
- IF 'A
- QUIT
- SET Y=^(A)
- SET X=9999999-Y
- SET ^TMP("LR",$JOB,"Z",X,A)=Y
- +6 FOR LRX=0:0
- SET LRX=$ORDER(^TMP("LR",$JOB,"Z",LRX))
- IF 'LRX!(LR("Q"))
- QUIT
- DO A
- IF LR("Q")
- QUIT
- +7 IF LR("Q")
- QUIT
- IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- WRITE !!,"PERMANENT DEFERRALS:",!,"--------------------"
- SET LRP=0
- +8 FOR LRA=0:0
- SET LRP=$ORDER(^TMP("LR",$JOB,"N","P",LRP))
- IF LRP=""!(LR("Q"))
- QUIT
- FOR LRB=0:0
- SET LRB=$ORDER(^TMP("LR",$JOB,"N","P",LRP,LRB))
- IF 'LRB!(LR("Q"))
- QUIT
- FOR LRD=0:0
- SET LRD=$ORDER(^TMP("LR",$JOB,"N","P",LRP,LRB,LRD))
- IF 'LRD!(LR("Q"))
- QUIT
- DO D
- +9 QUIT
- D IF $Y>(IOSL-6)
- DO H3
- IF LR("Q")
- QUIT
- SET Y=9999999-LRD
- DO D^LRU
- SET LRY=Y
- WRITE !!,LRP,?32,"Deferral Date: ",Y
- KILL ^TMP($JOB)
- +1 SET LRE=0
- FOR LRG=0:1
- SET LRE=$ORDER(^LRE(LRB,99,LRE))
- IF 'LRE!(LR("Q"))
- QUIT
- SET LRX=^(LRE,0)
- IF $Y>(IOSL-6)
- DO H4
- IF LR("Q")
- QUIT
- SET X=LRX
- DO ^DIWP
- +2 IF LRG
- DO ^DIWW
- QUIT
- +3 ;
- A FOR LRA=0:0
- SET LRA=$ORDER(^TMP("LR",$JOB,"Z",LRX,LRA))
- IF 'LRA!(LR("Q"))
- QUIT
- SET LRB=^(LRA)
- SET X=$SELECT($DATA(^LAB(65.4,LRA,0)):^(0),1:"")
- SET LRD=$SELECT($PIECE(X,"^",3)]"":$PIECE(X,"^",3),1:$PIECE(X,"^"))
- IF $Y>(IOSL-6)
- DO H1
- IF LR("Q")
- QUIT
- WRITE !,$JUSTIFY(LRB,4),?7,LRD
- +1 QUIT
- +2 ;
- S SET X=" UNITS"
- SET LRF=0
- SET LRB("S")="TOTAL"_X
- SET LRB("H")="HOMOLOGOUS"_X
- SET LRB("A")="AUTOLOGOUS"_X
- SET LRB("T")="THERAPEUTIC"_X
- SET LRB("D")="DIRECTED"_X
- DO S^LRU
- +1 SET Y=$PIECE(^DD(66,.26,0),"^",3)
- FOR T="T","H","A","D","S"
- FOR A=1:1
- SET X=$PIECE(Y,";",A)
- IF X=""
- QUIT
- SET Z=$PIECE(X,":")
- SET LRA(Z)=$PIECE(X,":",2)
- FOR B="A","B","C","D","E","F"
- SET ^TMP("LR",$JOB,T,B,Z)=0
- +2 FOR T=12:1:20
- FOR E="WA","WD","WH","WT","PA","PD","PH","PT","CA","CD","CH","CT"
- SET ^TMP("LR",$JOB,"Y",T,E)=0
- +3 FOR E="WA","WD","WH","WT","PA","PD","PH","PT","CA","CD","CH","CT"
- SET ^TMP("LR",$JOB,"Y",E)=0
- +4 FOR T="WH","WA","WT","WD","PH","PA","PT","PD","CH","CA","CT","CD"
- SET ^TMP("LR",$JOB,T)=0
- SET ^(T,"D")=0
- +5 SET ^TMP("LR",$JOB,"N")=0
- SET ^("N","P")=0
- SET ^("T")=0
- QUIT
- W SET X="WHOLE BLOOD"
- SET LRB("WH")=X_" HOMOLOGOUS"
- SET LRB("WA")=X_" AUTOLOGOUS"
- SET LRB("WD")=X_" DIRECTED"
- SET LRB("WT")=X_" THERAPEUTIC"
- +1 SET X="PLASMAPHERESIS"
- SET LRB("PH")=X_" HOMOLOGOUS"
- SET LRB("PA")=X_" AUTOLOGOUS"
- SET LRB("PT")=X_" THERAPEUTIC"
- SET LRB("PD")=X_" DIRECTED"
- +2 SET X="CYTAPHERESIS"
- SET LRB("CH")=X_" HOMOLOGOUS"
- SET LRB("CA")=X_" AUTOLOGOUS"
- SET LRB("CT")=X_" THERAPEUTIC"
- SET LRB("CD")=X_" DIRECTED"
- +3 SET LRB("N")="NO DONATION"
- QUIT
- +4 ;
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"Blood Bank Administrative Data from: ",LRSTR," to ",LRLST
- IF LRC
- WRITE !,"DIVISION: ",LRC(2)
- WRITE !,LR("%")
- IF LRF
- QUIT
- +2 WRITE !,"| ",LRB(LRB),?20,"|",?30,"SOURCE",?40,"|",?50,"INVENTORY DISPOSITION",?79,"|"
- +3 WRITE !,LR("%"),!,"|",?5,"COMPONENT",?20,"|Prepared",?30,"|Received",?40,"|Transfused",?51,"|Shipped",?59,"|Outdated",?69,"|Discarded",?79,"|",!,LR("%")
- +4 QUIT
- H1 DO H
- IF LR("Q")
- QUIT
- WRITE !,"COUNT",?7,"TEMPORARY DEFERRAL REASON"
- QUIT
- H3 DO H
- IF LR("Q")
- QUIT
- WRITE !,"PERMANENT DEFERRALS:"
- QUIT
- H4 DO H3
- IF LR("Q")
- QUIT
- WRITE !,LRP,?31,"Deferral Date: ",LRY
- QUIT
