LRBLDPA.m

LRBLDPA ; IHS/DIR/AAB - BLOOD DONOR PRINT 6/26/96 08:57 ;

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

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

 D END S (LRN,LR("Q"))=0,DIC="^LRE(",DIC(0)="AEQMZ",DIC("A")="Select DONOR: " D ^DIC K DIC G:X=""!(X[U) END S LR=+Y

 I $O(^LRE(LR,5,0)) W !!,"Select a single donation date " S %=2 D YN^LRU G:%<1 END I %=1 K ^TMP($J) S (A,C)=0 D L G:'$D(LRI) END W !!,"Include workload information " S %=2 D YN^LRU Q:%<1  S:%=1 LRN=1

 K DIC,DIE,DR S ZTRTN="QUE^LRBLDPA" W ! D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE N NAME U IO D L^LRU,S^LRU F X=6.1,6.2,6.3,6.4 D FIELD^DID(65.5,X,"","LABEL","NAME") S Y=NAME("LABEL")

 S DIWL=5,DIWR=IOM-5,DIWF="W"

 D ^LRBLDPA1,END^LRUTL,END Q

L F B=1:1 S A=$O(^LRE(LR,5,A)) Q:'A!(LR("Q"))  S W=^(A,0) D:B#21=0 M^LRU Q:LR("Q")  S Y=+W,W(2)=$P(W,"^",2),C=C+1,^TMP($J,C)=A D D^LRU D W

ASK Q:'$D(^TMP($J))  W !!,"CHOOSE FROM 1-",C," : " R X:DTIME Q:X=""!(X[U)  I X'=+X!(X<1)!(X>C) W $C(7)," Numbers only from 1 to ",C G ASK

 S LRI=^TMP($J,X),Y=+^LRE(LR,5,LRI,0) D D^LRU W " ",Y K ^TMP($J) Q

W W:B=1 !!?5,"Donation Date",?30,"Unit ID" W !,$J(C,2),?5,Y,?30,$P(W,"^",4) W:W(2)="N" "NO DONATION"

 Q

END D V^LRU Q

LRBLDPA   ; IHS/DIR/AAB - BLOOD DONOR PRINT 6/26/96 08:57 ;

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

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

 +3        DO END

           SET (LRN,LR("Q"))=0

           SET DIC="^LRE("

           SET DIC(0)="AEQMZ"

           SET DIC("A")="Select DONOR: "

           DO ^DIC

           KILL DIC

           IF X=""!(X[U)

               GOTO END

           SET LR=+Y

 +4        IF $ORDER(^LRE(LR,5,0))

               WRITE !!,"Select a single donation date "

               SET %=2

               DO YN^LRU

               IF %<1

                   GOTO END

               IF %=1

                   KILL ^TMP($JOB)

                   SET (A,C)=0

                   DO L

                   IF '$DATA(LRI)

                       GOTO END

                   WRITE !!,"Include workload information "

                   SET %=2

                   DO YN^LRU

                   IF %<1

                       QUIT 

                   IF %=1

                       SET LRN=1

 +5        KILL DIC,DIE,DR

           SET ZTRTN="QUE^LRBLDPA"

           WRITE !

           DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               GOTO END

QUE        NEW NAME

           USE IO

           DO L^LRU

           DO S^LRU

           FOR X=6.1,6.2,6.3,6.4

               DO FIELD^DID(65.5,X,"","LABEL","NAME")

               SET Y=NAME("LABEL")

 +1        SET DIWL=5

           SET DIWR=IOM-5

           SET DIWF="W"

 +2        DO ^LRBLDPA1

           DO END^LRUTL

           DO END

           QUIT 

L          FOR B=1:1

               SET A=$ORDER(^LRE(LR,5,A))

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

                   QUIT 

               SET W=^(A,0)

               IF B#21=0

                   DO M^LRU

               IF LR("Q")

                   QUIT 

               SET Y=+W

               SET W(2)=$PIECE(W,"^",2)

               SET C=C+1

               SET ^TMP($JOB,C)=A

               DO D^LRU

               DO W

ASK        IF '$DATA(^TMP($JOB))

               QUIT 

           WRITE !!,"CHOOSE FROM 1-",C," : "

           READ X:DTIME

           IF X=""!(X[U)

               QUIT 

           IF X'=+X!(X<1)!(X>C)

               WRITE $CHAR(7)," Numbers only from 1 to ",C

               GOTO ASK

 +1        SET LRI=^TMP($JOB,X)

           SET Y=+^LRE(LR,5,LRI,0)

           DO D^LRU

           WRITE " ",Y

           KILL ^TMP($JOB)

           QUIT 

W          IF B=1

               WRITE !!?5,"Donation Date",?30,"Unit ID"

           WRITE !,$JUSTIFY(C,2),?5,Y,?30,$PIECE(W,"^",4)

           IF W(2)="N"

               WRITE "NO DONATION"

 +1        QUIT 

END        DO V^LRU

           QUIT