- 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 Jan 18, 2025@03:11:39 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