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 Oct 16, 2024@18:11:17 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
