LRBLDPA ;AVAMC/REG/CYM - BLOOD DONOR PRINT ;6/26/96 08:57 ;
;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDPA 1226 printed Dec 13, 2024@02:10:40 Page 2
LRBLDPA ;AVAMC/REG/CYM - BLOOD DONOR PRINT ;6/26/96 08:57 ;
+1 ;;5.2;LAB SERVICE;**72,247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+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
