Routine: LRBLDCU

LRBLDCU ; IHS/DIR/AAB - CUMULATIVE DONATION CALCULATIONS 6/28/96 08:47 ;

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 S IOP="HOME" D ^%ZIS,END W @IOF,?15,"Cumulative donations and new awards"

 D S^LRU S LRC=0 D FIELD^DID(65.54,1,"","POINTER","X") S X=X("POINTER") F A=1:1 S B=$P(X,";",A),C=$P(B,":") Q:B=""  S LRB(C)=$P(B,":",2)

 S X=0 F A=0:0 S X=$O(LRB(X)) Q:X=""  D Z G:E["^"!(E="") END

 S I="" W !!,"Print all donors to receive new awards " S %=2 D YN^LRU G:%<1 END I %=1 G DEV

ASK W ! S LRG(1)=0,DIC="^LRE(",DIC(0)="AEQM" D ^DIC K DIC G:Y<1 END

 S I=+Y,N=$P(Y,U,2),K=0 D C S:$D(^LRE(I,3)) K=$P(^(3),"^") W:LRG(1)'>LRG!(LRG<1) !,N,!,$S(K:"New award; Not given",1:"No new award"),?33,"Total donations: ",$J(T,3),"  Total awards: ",LRG G ASK

DEV S ZTRTN="QUE^LRBLDCU" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO D L^LRU S X="T",%DT="" D ^%DT S LRF=10009999-Y

 D:IOST?1"C".E WAIT^LRU D H S LR("F")=1,N=0 F A=0:0 S N=$O(^LRE("B",N)) Q:N=""!(LR("Q"))  F I=0:0 S I=$O(^LRE("B",N,I)) Q:'I!(LR("Q"))  D E

 W:'LRC !,"No donors found to receive new awards." W:IOST'?1"C".E @IOF D END,END^LRUTL Q

E Q:$O(^LRE(I,5,0))>LRF

C S T=0,X=^LRE(I,0),LRG=$P(X,"^",8),Y=$P(X,"^",3) D DT^LRU S N(1)=Y D D

D F V=0:0 S V=$O(^LRE(I,5,V)) Q:'V!(LR("Q"))  S C=$P(^(V,0),"^",2) I C]"" S T=T+E(C)

 Q:LR("Q")  I T S LRG(1)=T\8 I LRG(1)>LRG S ^LRE(I,3)=1 D:$Y>(IOSL-6) H Q:LR("Q")  W !,N,?31,N(1),?45,$J(LRG,2),?60,$J(T,3) S LRC=LRC+1

 S $P(^LRE(I,0),"^",7)=T Q

Z W !,"Enter donation value for ",LRB(X),": " R E:60 Q:E=""!(E[U)  I E'?1N.N!(E<0)!(E>99) W !,$C(7),"Enter a whole number from 0 to 99" G Z

 S E(X)=E Q

H I $D(^LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")

 D F^LRU W !?20,"BLOOD DONORS TO RECEIVE NEW AWARDS"

 W !,"Donor",?33,"DOB",?41,"Total Awards",?55,"Cumulative donations",!,LR("%") Q

END D V^LRU Q

 ; Line E stops processing any donor not donating in past year

LRBLDCU   ; IHS/DIR/AAB - CUMULATIVE DONATION CALCULATIONS 6/28/96 08:47 ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3        SET IOP="HOME"

           DO ^%ZIS

           DO END

           WRITE @IOF,?15,"Cumulative donations and new awards"

 +4        DO S^LRU

           SET LRC=0

           DO FIELD^DID(65.54,1,"","POINTER","X")

           SET X=X("POINTER")

           FOR A=1:1

               SET B=$PIECE(X,";",A)

               SET C=$PIECE(B,":")

               IF B=""

                   QUIT

               SET LRB(C)=$PIECE(B,":",2)

 +5        SET X=0

           FOR A=0:0

               SET X=$ORDER(LRB(X))

               IF X=""

                   QUIT

               DO Z

               IF E["^"!(E="")

                   GOTO END

 +6        SET I=""

           WRITE !!,"Print all donors to receive new awards "

           SET %=2

           DO YN^LRU

           IF %<1

               GOTO END

           IF %=1

               GOTO DEV

ASK        WRITE !

           SET LRG(1)=0

           SET DIC="^LRE("

           SET DIC(0)="AEQM"

           DO ^DIC

           KILL DIC

           IF Y<1

               GOTO END

 +1        SET I=+Y

           SET N=$PIECE(Y,U,2)

           SET K=0

           DO C

           IF $DATA(^LRE(I,3))

               SET K=$PIECE(^(3),"^")

           IF LRG(1)'>LRG!(LRG<1)

               WRITE !,N,!,$SELECT(K:"New award; Not given",1:"No new award"),?33,"Total donations: ",$JUSTIFY(T,3),"  Total awards: ",LRG

           GOTO ASK

DEV        SET ZTRTN="QUE^LRBLDCU"

           DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           DO L^LRU

           SET X="T"

           SET %DT=""

           DO ^%DT

           SET LRF=10009999-Y

 +1        IF IOST?1"C".E

               DO WAIT^LRU

           DO H

           SET LR("F")=1

           SET N=0

           FOR A=0:0

               SET N=$ORDER(^LRE("B",N))

               IF N=""!(LR("Q"))

                   QUIT

               FOR I=0:0

                   SET I=$ORDER(^LRE("B",N,I))

                   IF 'I!(LR("Q"))

                       QUIT

                   DO E

 +2        IF 'LRC

               WRITE !,"No donors found to receive new awards."

           IF IOST'?1"C".E

               WRITE @IOF

           DO END

           DO END^LRUTL

           QUIT

E          IF $ORDER(^LRE(I,5,0))>LRF

               QUIT

C          SET T=0

           SET X=^LRE(I,0)

           SET LRG=$PIECE(X,"^",8)

           SET Y=$PIECE(X,"^",3)

           DO DT^LRU

           SET N(1)=Y

           DO D

 +1        QUIT

D          FOR V=0:0

               SET V=$ORDER(^LRE(I,5,V))

               IF 'V!(LR("Q"))

                   QUIT

               SET C=$PIECE(^(V,0),"^",2)

               IF C]""

                   SET T=T+E(C)

 +1        IF LR("Q")

               QUIT

           IF T

               SET LRG(1)=T\8

               IF LRG(1)>LRG

                   SET ^LRE(I,3)=1

                   IF $Y>(IOSL-6)

                       DO H

                   IF LR("Q")

                       QUIT

                   WRITE !,N,?31,N(1),?45,$JUSTIFY(LRG,2),?60,$JUSTIFY(T,3)

                   SET LRC=LRC+1

 +2        SET $PIECE(^LRE(I,0),"^",7)=T

           QUIT

Z          WRITE !,"Enter donation value for ",LRB(X),": "

           READ E:60

           IF E=""!(E[U)

               QUIT

           IF E'?1N.N!(E<0)!(E>99)

               WRITE !,$CHAR(7),"Enter a whole number from 0 to 99"

               GOTO Z

 +1        SET E(X)=E

           QUIT

H          IF $DATA(^LR("F"))

               IF IOST?1"C".E

                   DO M^LRU

                   IF LR("Q")

                       QUIT

 +1        DO F^LRU

           WRITE !?20,"BLOOD DONORS TO RECEIVE NEW AWARDS"

 +2        WRITE !,"Donor",?33,"DOB",?41,"Total Awards",?55,"Cumulative donations",!,LR("%")

           QUIT

END        DO V^LRU

           QUIT

 +1       ; Line E stops processing any donor not donating in past year

LRBLDCU.m