LRBLDEX.m

LRBLDEX ; IHS/DIR/AAB - EX-BLOOD DONORS 6/27/96 08:54 ;

 ;;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

 I '$D(^LRO(69.2,LRAA,8,0)) S ^(0)="^69.31A^0^0"

 I '$D(^LRO(69.2,LRAA,8,65.5,0)) S ^(0)=65.5,X=^LRO(69.2,LRAA,8,0),^(0)="^69.31A^65.5^"_($P(X,"^",4)+1)

 W @IOF,!?10,"BLOOD DONORS WHO HAVE NOT DONATED SINCE A SPECIFIED TIME"

 S LR=0,%DT="AEX",%DT(0)="-N",%DT("A")="Date since last donation: " D ^%DT K %DT G:Y<1 END S LRSDT=9999998-Y D D^LRU S LRSTR=Y

 S ZTRTN="QUE^LRBLDEX" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO K ^TMP("LRBL",$J),^LRO(69.2,LRAA,8,65.5) S ^LRO(69.2,LRAA,8,65.5,0)=65.5_U_LRSTR,^(1,0)="^69.32A^0^0" D L^LRU

 F I=0:0 S I=$O(^LRE(I)) Q:'I  I $O(^LRE(I,5,0))>LRSDT D SET

 S ^LRO(69.2,LRAA,8,65.5,1,0)="^69.32A^0^0"_LR D S^LRU

 F X=10:1:20 D

 . D FIELD^DID(65.54,X,"","LABEL","LR") S LR(X)=LR("LABEL")

 G ^LRBLDEX1

 ;

SET S X=$P(^LRE(I,0),"^"),LR=LR+1,^LRO(69.2,LRAA,8,65.5,1,I,0)=X,^LRO(69.2,LRAA,8,65.5,1,"B",X,I)="" Q

 ;

END D V^LRU Q

LRBLDEX   ; IHS/DIR/AAB - EX-BLOOD DONORS 6/27/96 08:54 ;

 +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        IF '$DATA(^LRO(69.2,LRAA,8,0))

               SET ^(0)="^69.31A^0^0"

 +5        IF '$DATA(^LRO(69.2,LRAA,8,65.5,0))

               SET ^(0)=65.5

               SET X=^LRO(69.2,LRAA,8,0)

               SET ^(0)="^69.31A^65.5^"_($PIECE(X,"^",4)+1)

 +6        WRITE @IOF,!?10,"BLOOD DONORS WHO HAVE NOT DONATED SINCE A SPECIFIED TIME"

 +7        SET LR=0

           SET %DT="AEX"

           SET %DT(0)="-N"

           SET %DT("A")="Date since last donation: "

           DO ^%DT

           KILL %DT

           IF Y<1

               GOTO END

           SET LRSDT=9999998-Y

           DO D^LRU

           SET LRSTR=Y

 +8        SET ZTRTN="QUE^LRBLDEX"

           DO BEG^LRUTL

           IF POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           KILL ^TMP("LRBL",$JOB),^LRO(69.2,LRAA,8,65.5)

           SET ^LRO(69.2,LRAA,8,65.5,0)=65.5_U_LRSTR

           SET ^(1,0)="^69.32A^0^0"

           DO L^LRU

 +1        FOR I=0:0

               SET I=$ORDER(^LRE(I))

               IF 'I

                   QUIT 

               IF $ORDER(^LRE(I,5,0))>LRSDT

                   DO SET

 +2        SET ^LRO(69.2,LRAA,8,65.5,1,0)="^69.32A^0^0"_LR

           DO S^LRU

 +3        FOR X=10:1:20

               Begin DoDot:1

 +4                DO FIELD^DID(65.54,X,"","LABEL","LR")

                   SET LR(X)=LR("LABEL")

               End DoDot:1

 +5        GOTO ^LRBLDEX1

 +6       ;

SET        SET X=$PIECE(^LRE(I,0),"^")

           SET LR=LR+1

           SET ^LRO(69.2,LRAA,8,65.5,1,I,0)=X

           SET ^LRO(69.2,LRAA,8,65.5,1,"B",X,I)=""

           QUIT 

 +1       ;

END        DO V^LRU

           QUIT