17 lines
1.2 KiB
Mathematica
17 lines
1.2 KiB
Mathematica
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
|