- 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 Feb 18, 2025@23:48:58 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
