| [613] | 1 | LRWLST2 ;SLC/CJS/RWF - ACCESSION SETUP ;2/7/91 13:37 ;
|
|---|
| 2 | ;;5.2;LAB SERVICE;;Sep 27, 1994
|
|---|
| 3 | S LRXD=^LRO(68,LRAA,.3) Q:'$L(LRXD)
|
|---|
| 4 | 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
|
|---|
| 5 | ID1A I $D(^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT)) S LRIDENT=LRIDENT+1 X LRXD G ID1A
|
|---|
| 6 | I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S:$L($P(^(0),U,6)) LRIDENT=$P(^(0),U,6)
|
|---|
| 7 | I '$D(LRGVP) W !,"IDENTITY ",LRIDENT," OK? Y//" D % I %["N" R !,"force to: ",X:DTIME
|
|---|
| 8 | I (X'="")&(X'="@") S LRIDENT=X
|
|---|
| 9 | 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
|
|---|
| 10 | 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
|
|---|
| 11 | S ^LRO(68,LRAA,1,LRAD,1,"C",$E(LRIDENT,1,30),LRAN)=""
|
|---|
| 12 | 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)
|
|---|
| 13 | Q
|
|---|
| 14 | ID3 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LROWLE,0)) S ^(0)=$P(^(0),U,1,5)_"^^"_$P(^(0),U,7,99) Q
|
|---|
| 15 | % R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
|
|---|
| 16 | Q
|
|---|
