LRWLST2 ;SLC/CJS/RWF - ACCESSION SETUP ;2/7/91  13:37 ;
 ;;5.2;LAB SERVICE;;Sep 27, 1994
 S LRXD=^LRO(68,LRAA,.3) Q:'$L(LRXD)
 S:'($D(^LRO(68,LRAA,1,LRAD,2))#2) ^LRO(68,LRAA,1,LRAD,2)="^^" S LRIDENT=1+$P(^(2),U,3),X="",%="" X LRXD
ID1A I $D(^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT)) S LRIDENT=LRIDENT+1 X LRXD G ID1A
 I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S:$L($P(^(0),U,6)) LRIDENT=$P(^(0),U,6)
 I '$D(LRGVP) W !,"IDENTITY ",LRIDENT," OK? Y//" D % I %["N" R !,"force to: ",X:DTIME
 I (X'="")&(X'="@") S LRIDENT=X
 I $T,LRIDENT'="",$D(^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT)) S LROWLE=$O(^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT,0)) W !,$C(7),"WIPE OUT IDENTITY FOR LRAN ",LROWLE," ? N//" D % Q:%'["Y"  K ^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT,LROWLE) D ID3
 Q:X["^"!((X="")&(%["N"))  I X="@" W !,?5,"DELETE, ARE YOU SURE? N//" D % I %["Y" K ^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT,LRAN) S LRIDENT="" G ID2
 S ^LRO(68,LRAA,1,LRAD,1,"C",$E(LRIDENT,1,30),LRAN)=""
ID2 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))  S ^(0)=$P(^(0),U,1,5)_U_LRIDENT_U_$P(^(0),U,7,99),^(2)=$P(^LRO(68,LRAA,1,LRAD,2),U,1,2)_U_LRIDENT_U_$P(^(2),U,4,99)
 Q
ID3 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LROWLE,0))  S ^(0)=$P(^(0),U,1,5)_"^^"_$P(^(0),U,7,99) Q
% R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %
 Q