LRBLDTA ;AVAMC/REG/CYM - ABNORMAL DONOR TESTS ;6/28/96 09:04 ;
;;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 X="BLOOD BANK" D ^LRUTL G:Y=-1 END
W !!?20,"Blood donor- Abnormal Test List"
A R !!,"Start with DONOR UNIT ID: ",X:DTIME G:X=""!(X[U) END D C G:'$D(X) A
S A=$A(X,$L(X))-1,A=$C(A),LRA=$E(X,1,$L(X)-1)_A
B R !,"Go to DONOR UNIT ID: ",X:DTIME G:X=""!(X[U) END D C G:'$D(X) B
S LRB=X,ZTRTN="QUE^LRBLDTA" D BEG^LRUTL G:POP!($D(ZTSK)) END
;
QUE U IO F A=12:1:20 D FIELD^DID(65.54,A,"","LABEL","LRA") S LRA(A)=LRA("LABEL")
D L^LRU,S^LRU,H S A=LRA,LR("F")=1 F B=0:0 S A=$O(^LRE("C",A)) Q:A=""!(A]LRB)!(LR("Q")) D F
D END^LRUTL,END Q
F S I=$O(^LRE("C",A,0)),LRIDT=+$O(^(I,0)) Q:'$D(^LRE(I,5,LRIDT,0)) S Y=$P(+^(0),".",1) D D^LRU S LRT=Y
S F=0 F E=0:0 S E=$O(LRA(E)) Q:'E I $D(^LRE(I,5,LRIDT,E)),+^(E) S F=F+1,Z=^(E) D G
I F W !,LR("%")
Q
G D:$Y>(IOSL-5) H Q:LR("Q") W:F=1 !,LRT,?14,A,?26,I W:F>1 ! W ?36,LRA(E)," ",$P(Z,"^",3)
Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"LABORATORY SERVICE",?23,"ABNORMAL TEST RESULTS FOR DONORS"
W !,"Donation Date",?14,"Unit ID",?26,"DONOR",?36,"TEST",!,LR("%") Q
;
C I X'?.UN!($L(X)<6)!($L(X)>11) W $C(7)," Entry must be 6-11 digits &/or UPPER CASE letters" K X
Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDTA 1385 printed Apr 09, 2024@21:17:51 Page 2
LRBLDTA ;AVAMC/REG/CYM - ABNORMAL DONOR TESTS ;6/28/96 09:04 ;
+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 X="BLOOD BANK"
DO ^LRUTL
if Y=-1
GOTO END
+4 WRITE !!?20,"Blood donor- Abnormal Test List"
A READ !!,"Start with DONOR UNIT ID: ",X:DTIME
if X=""!(X[U)
GOTO END
DO C
if '$DATA(X)
GOTO A
+1 SET A=$ASCII(X,$LENGTH(X))-1
SET A=$CHAR(A)
SET LRA=$EXTRACT(X,1,$LENGTH(X)-1)_A
B READ !,"Go to DONOR UNIT ID: ",X:DTIME
if X=""!(X[U)
GOTO END
DO C
if '$DATA(X)
GOTO B
+1 SET LRB=X
SET ZTRTN="QUE^LRBLDTA"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
+2 ;
QUE USE IO
FOR A=12:1:20
DO FIELD^DID(65.54,A,"","LABEL","LRA")
SET LRA(A)=LRA("LABEL")
+1 DO L^LRU
DO S^LRU
DO H
SET A=LRA
SET LR("F")=1
FOR B=0:0
SET A=$ORDER(^LRE("C",A))
if A=""!(A]LRB)!(LR("Q"))
QUIT
DO F
+2 DO END^LRUTL
DO END
QUIT
F SET I=$ORDER(^LRE("C",A,0))
SET LRIDT=+$ORDER(^(I,0))
if '$DATA(^LRE(I,5,LRIDT,0))
QUIT
SET Y=$PIECE(+^(0),".",1)
DO D^LRU
SET LRT=Y
+1 SET F=0
FOR E=0:0
SET E=$ORDER(LRA(E))
if 'E
QUIT
IF $DATA(^LRE(I,5,LRIDT,E))
IF +^(E)
SET F=F+1
SET Z=^(E)
DO G
+2 IF F
WRITE !,LR("%")
+3 QUIT
G if $Y>(IOSL-5)
DO H
if LR("Q")
QUIT
if F=1
WRITE !,LRT,?14,A,?26,I
if F>1
WRITE !
WRITE ?36,LRA(E)," ",$PIECE(Z,"^",3)
+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 !,"LABORATORY SERVICE",?23,"ABNORMAL TEST RESULTS FOR DONORS"
+2 WRITE !,"Donation Date",?14,"Unit ID",?26,"DONOR",?36,"TEST",!,LR("%")
QUIT
+3 ;
C IF X'?.UN!($LENGTH(X)<6)!($LENGTH(X)>11)
WRITE $CHAR(7)," Entry must be 6-11 digits &/or UPPER CASE letters"
KILL X
+1 QUIT
+2 ;
END DO V^LRU
QUIT
