- LRBLDEX ;AVAMC/REG/CYM - EX-BLOOD DONORS ;6/27/96 08:54 ;
- ;;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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBLDEX 1110 printed Feb 18, 2025@23:36:25 Page 2
- LRBLDEX ;AVAMC/REG/CYM - EX-BLOOD DONORS ;6/27/96 08:54 ;
- +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 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