LRBLDTA.m

LRBLDTA ; IHS/DIR/AAB - ABNORMAL DONOR TESTS 6/28/96 09:04 ;

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

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

 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

LRBLDTA   ; IHS/DIR/AAB - ABNORMAL DONOR TESTS 6/28/96 09:04 ;

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

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

 +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