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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRWLST2 1266 printed Dec 13, 2024@02:23:07 Page 2
LRWLST2 ;SLC/CJS/RWF - ACCESSION SETUP ;2/7/91 13:37 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 SET LRXD=^LRO(68,LRAA,.3)
if '$LENGTH(LRXD)
QUIT
+3 if '($DATA(^LRO(68,LRAA,1,LRAD,2))#2)
SET ^LRO(68,LRAA,1,LRAD,2)="^^"
SET LRIDENT=1+$PIECE(^(2),U,3)
SET X=""
SET %=""
XECUTE LRXD
ID1A IF $DATA(^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT))
SET LRIDENT=LRIDENT+1
XECUTE LRXD
GOTO ID1A
+1 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
if $LENGTH($PIECE(^(0),U,6))
SET LRIDENT=$PIECE(^(0),U,6)
+2 IF '$DATA(LRGVP)
WRITE !,"IDENTITY ",LRIDENT," OK? Y//"
DO %
IF %["N"
READ !,"force to: ",X:DTIME
+3 IF (X'="")&(X'="@")
SET LRIDENT=X
+4 IF $TEST
IF LRIDENT'=""
IF $DATA(^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT))
SET LROWLE=$ORDER(^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT,0))
WRITE !,$CHAR(7),"WIPE OUT IDENTITY FOR LRAN ",LROWLE," ? N//"
DO %
if %'["Y"
QUIT
KILL ^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT,LROWLE)
DO ID3
+5 if X["^"!((X="")&(%["N"))
QUIT
IF X="@"
WRITE !,?5,"DELETE, ARE YOU SURE? N//"
DO %
IF %["Y"
KILL ^LRO(68,LRAA,1,LRAD,1,"C",LRIDENT,LRAN)
SET LRIDENT=""
GOTO ID2
+6 SET ^LRO(68,LRAA,1,LRAD,1,"C",$EXTRACT(LRIDENT,1,30),LRAN)=""
ID2 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
SET ^(0)=$PIECE(^(0),U,1,5)_U_LRIDENT_U_$PIECE(^(0),U,7,99)
SET ^(2)=$PIECE(^LRO(68,LRAA,1,LRAD,2),U,1,2)_U_LRIDENT_U_$PIECE(^(2),U,4,99)
+1 QUIT
ID3 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LROWLE,0))
QUIT
SET ^(0)=$PIECE(^(0),U,1,5)_"^^"_$PIECE(^(0),U,7,99)
QUIT
% READ %:DTIME
if %=""!(%["N")!(%["Y")
QUIT
WRITE !,"Answer 'Y' or 'N': "
GOTO %
+1 QUIT
