20 lines
1.1 KiB
Mathematica
20 lines
1.1 KiB
Mathematica
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
|