LRBLDSC ;AVAMC/REG - DONOR SCHEDULING REPORT ;2/18/93 09:01
;;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 @IOF,!?10,"DONOR SCHEDULING REPORT BY DONATION OR DEFERRAL DATE"
D B^LRU G:Y<0 END
S ZTRTN="QUE^LRBLDSC" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) S LRT=$P(^DD(65.54,1.1,0),U,3),LRD=$P(^DD(65.54,1,0),U,3),LRA=LRSDT-1 D L^LRU,S^LRU,H S LR("F")=1
F LRA=LRA:0 S LRA=$O(^LRE("AD",LRA)) Q:'LRA!(LRA>LRLDT) S Y=LRA,LRIDT=9999999-LRA D I
S (LR("N","S"),LR("W","S"),LR("W","S","A"),LR("W","S","H"),LR("W","S","T"),LR("W","S","D"),LR("P","S"),LR("C","S"))=0
F LRA=0:0 S LRA=$O(^TMP($J,LRA)) Q:'LRA!(LR("Q")) D:$Y>(IOSL-6) H Q:LR("Q") S Y=LRA,LRIDT=9999999-LRSDT D DT^LRU W !!?2,"DONATION OR DEFERRAL DATE: ",Y S LRW=Y D W
I 'LR("Q") W !!?5,"Total" S LRF=0 F A="N","W","P","C" Q:LR("Q") I LR(A,"S") W:LRF ! W ?11,$P($P(LRD,A_":",2),";"),?25,":",$J(LR(A,"S"),8) S LRF=1 D:$Y>(IOSL-6) H2 D:A="W" T
D END^LRUTL,END Q
W S (LR("N"),LR("W"),LR("W","A"),LR("W","H"),LR("W","T"),LR("W","D"),LR("P"),LR("C"))=0
F LRB=-1:0 S LRB=$O(^TMP($J,LRA,LRB)) Q:LRB=""!(LR("Q")) F LRI=0:0 S LRI=$O(^TMP($J,LRA,LRB,LRI)) Q:'LRI!(LR("Q")) S LRE=^(LRI) D:$Y>(IOSL-6) H1 Q:LR("Q") D Y
Q:LR("Q") D:$Y>(IOSL-6) H1
W !?2,"Subtotal" S LRF=0 F A="N","W","P","C" Q:LR("Q") I LR(A) W:LRF ! W ?11,$P($P(LRD,A_":",2),";"),?25,":",$J(LR(A),8) S LRF=1 D:$Y>(IOSL-6) H1 D:A="W" B
Q
B F B="A","H","T","D" Q:LR("Q") I LR(A,B) W !?13,$P($P(LRT,B_":",2),";"),?24,":",$J(LR(A,B),3) D:$Y>(IOSL-6) H1
Q
Y S A=$P(LRE,"^",2),B=$P(LRE,"^",3) S LR(A)=LR(A)+1,LR(A,"S")=LR(A,"S")+1 I B]"",$D(LR(A,B)) S LR(A,B)=LR(A,B)+1,LR(A,"S",B)=LR(A,"S",B)+1
S A=$P($P(LRD,A_":",2),";"),B=$P($P(LRT,B_":",2),";"),Y=$S(LRB:LRB,1:LRA) D DT^LRU W !,$S(Y[":":Y,1:Y_"??:??"),?15,$P(LRE,"^"),?28,A,?43,B,?54,$P(LRE,"^",4) Q
I F LRI=0:0 S LRI=$O(^LRE("AD",LRA,LRI)) Q:'LRI!(LR("Q")) I $D(^LRE(LRI,5,LRIDT,0)) S X=^(0),A=+X,B=+$P(X,"^",13),^TMP($J,A,B,LRI)=$P(X,"^",4)_"^"_$P(X,"^",2)_"^"_$P(X,"^",11)_"^"_$P(X,"^",5)
Q
T F B="A","H","T","D" Q:LR("Q") I LR(A,"S",B) W !?13,$P($P(LRT,B_":",2),";"),?24,":",$J(LR(A,"S",B),4) D:$Y>(IOSL-6) H2
Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"DONOR SCHEDULING REPORT FROM ",LRSTR," TO ",LRLST
W !,"ARRIVAL/APPT",?15,"UNIT ID",?28,"DON/DEF",?43,"DON. TYPE",?54,"PATIENT CREDIT",!,LR("%") Q
H1 D H Q:LR("Q") W !!?2,"DONATION OR DEFERRAL DATE: ",LRW Q
H2 D H Q:LR("Q") W !?2,"Total Count: " Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDSC 2605 printed Oct 16, 2024@18:11:39 Page 2
LRBLDSC ;AVAMC/REG - DONOR SCHEDULING REPORT ;2/18/93 09:01
+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 @IOF,!?10,"DONOR SCHEDULING REPORT BY DONATION OR DEFERRAL DATE"
+5 DO B^LRU
if Y<0
GOTO END
+6 SET ZTRTN="QUE^LRBLDSC"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
SET LRT=$PIECE(^DD(65.54,1.1,0),U,3)
SET LRD=$PIECE(^DD(65.54,1,0),U,3)
SET LRA=LRSDT-1
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
+1 FOR LRA=LRA:0
SET LRA=$ORDER(^LRE("AD",LRA))
if 'LRA!(LRA>LRLDT)
QUIT
SET Y=LRA
SET LRIDT=9999999-LRA
DO I
+2 SET (LR("N","S"),LR("W","S"),LR("W","S","A"),LR("W","S","H"),LR("W","S","T"),LR("W","S","D"),LR("P","S"),LR("C","S"))=0
+3 FOR LRA=0:0
SET LRA=$ORDER(^TMP($JOB,LRA))
if 'LRA!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
SET Y=LRA
SET LRIDT=9999999-LRSDT
DO DT^LRU
WRITE !!?2,"DONATION OR DEFERRAL DATE: ",Y
SET LRW=Y
DO W
+4 IF 'LR("Q")
WRITE !!?5,"Total"
SET LRF=0
FOR A="N","W","P","C"
if LR("Q")
QUIT
IF LR(A,"S")
if LRF
WRITE !
WRITE ?11,$PIECE($PIECE(LRD,A_":",2),";"),?25,":",$JUSTIFY(LR(A,"S"),8)
SET LRF=1
if $Y>(IOSL-6)
DO H2
if A="W"
DO T
+5 DO END^LRUTL
DO END
QUIT
W SET (LR("N"),LR("W"),LR("W","A"),LR("W","H"),LR("W","T"),LR("W","D"),LR("P"),LR("C"))=0
+1 FOR LRB=-1:0
SET LRB=$ORDER(^TMP($JOB,LRA,LRB))
if LRB=""!(LR("Q"))
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^TMP($JOB,LRA,LRB,LRI))
if 'LRI!(LR("Q"))
QUIT
SET LRE=^(LRI)
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
DO Y
+2 if LR("Q")
QUIT
if $Y>(IOSL-6)
DO H1
+3 WRITE !?2,"Subtotal"
SET LRF=0
FOR A="N","W","P","C"
if LR("Q")
QUIT
IF LR(A)
if LRF
WRITE !
WRITE ?11,$PIECE($PIECE(LRD,A_":",2),";"),?25,":",$JUSTIFY(LR(A),8)
SET LRF=1
if $Y>(IOSL-6)
DO H1
if A="W"
DO B
+4 QUIT
B FOR B="A","H","T","D"
if LR("Q")
QUIT
IF LR(A,B)
WRITE !?13,$PIECE($PIECE(LRT,B_":",2),";"),?24,":",$JUSTIFY(LR(A,B),3)
if $Y>(IOSL-6)
DO H1
+1 QUIT
Y SET A=$PIECE(LRE,"^",2)
SET B=$PIECE(LRE,"^",3)
SET LR(A)=LR(A)+1
SET LR(A,"S")=LR(A,"S")+1
IF B]""
IF $DATA(LR(A,B))
SET LR(A,B)=LR(A,B)+1
SET LR(A,"S",B)=LR(A,"S",B)+1
+1 SET A=$PIECE($PIECE(LRD,A_":",2),";")
SET B=$PIECE($PIECE(LRT,B_":",2),";")
SET Y=$SELECT(LRB:LRB,1:LRA)
DO DT^LRU
WRITE !,$SELECT(Y[":":Y,1:Y_"??:??"),?15,$PIECE(LRE,"^"),?28,A,?43,B,?54,$PIECE(LRE,"^",4)
QUIT
I FOR LRI=0:0
SET LRI=$ORDER(^LRE("AD",LRA,LRI))
if 'LRI!(LR("Q"))
QUIT
IF $DATA(^LRE(LRI,5,LRIDT,0))
SET X=^(0)
SET A=+X
SET B=+$PIECE(X,"^",13)
SET ^TMP($JOB,A,B,LRI)=$PIECE(X,"^",4)_"^"_$PIECE(X,"^",2)_"^"_$PIECE(X,"^",11)_"^"_$PIECE(X,"^",5)
+1 QUIT
T FOR B="A","H","T","D"
if LR("Q")
QUIT
IF LR(A,"S",B)
WRITE !?13,$PIECE($PIECE(LRT,B_":",2),";"),?24,":",$JUSTIFY(LR(A,"S",B),4)
if $Y>(IOSL-6)
DO H2
+1 QUIT
+2 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"DONOR SCHEDULING REPORT FROM ",LRSTR," TO ",LRLST
+2 WRITE !,"ARRIVAL/APPT",?15,"UNIT ID",?28,"DON/DEF",?43,"DON. TYPE",?54,"PATIENT CREDIT",!,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !!?2,"DONATION OR DEFERRAL DATE: ",LRW
QUIT
H2 DO H
if LR("Q")
QUIT
WRITE !?2,"Total Count: "
QUIT
+1 ;
END DO V^LRU
QUIT
