LRWLST2.m

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 ---LRWLST2   1266     printed  Apr 09, 2024@21:25:26                                                                                                                                                                                                     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