source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRWLST2.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.2 KB
Line 
1LRWLST2 ;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
5ID1A 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)=""
12ID2 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
14ID3 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
Note: See TracBrowser for help on using the repository browser.