LRBLDCU ;AVAMC/REG/CYM - CUMULATIVE DONATION CALCULATIONS ;6/28/96 08:47 ;
;;5.2;LAB SERVICE;**72,247,408**;Sep 27, 1994;Build 8
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
Q 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
Q
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDCU 1979 printed Nov 22, 2024@17:20:33 Page 2
LRBLDCU ;AVAMC/REG/CYM - CUMULATIVE DONATION CALCULATIONS ;6/28/96 08:47 ;
+1 ;;5.2;LAB SERVICE;**72,247,408**;Sep 27, 1994;Build 8
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 QUIT
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
