LRAPDEL.m

LRAPDEL ; IHS/DIR/AAB - ANAT PATH DELETE DESCRIPTIONS 8/12/95 07:42 ;

 ;;5.2;LR;**1002**;JUN 01, 1998

 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 D ^LRAP Q:'$D(Y)

 W !!?20,"Remove descriptions from ",LRO(68),!! D B^LRU G:Y<0 END

 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99

 W !!?16,"OK to DELETE DESCRIPTIONS (clinical,pathological)",!?21,"from one date thru the other " S %=2 D YN^LRU I %'=1 W !!?32,"OK, forget it !" G END

 I LRSS'="AU" S (LRK,LRZ)=0,X=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,4),1:"Microscopic") W !!,"OK to delete ",X," entries " S %=2 D YN^LRU G:%<1 END S:%=1 LRK=1

 D XR^LRU I LRSS="SP" W !!,"OK to delete Frozen Section Description entries " S %=2 D YN^LRU G:%<1 END S:%=1 LRZ=1

 W ! F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT)  W "." D LRDFN

OUT W $C(7),!,"OK DONE !" G END

LRDFN F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN  D @($S("CYEMSP"[LRSS:"I",1:"A"))

 Q

I F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI  I $P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV K ^(.2),^(.3),^(.4),^(.5),^(1),^(1.2),^(4),^(5),^(6),^(7),^(97),^(99) K:LRK ^(1.1) K:LRZ ^(1.3)

 Q

A K ^LR(LRDFN,81),^(82) Q

 ;

EN ;delete free text specimen entries

 S LRDICS="SPCYEM" D ^LRAP Q:'$D(Y)

 W !!,"Remove free text specimen entries from ",LRO(68),!! D B^LRU G:Y<0 END

 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99 W !!?16,"OK to DELETE FREE TEXT ENTRIES from",!?16,LRSTR," to ",LRLST S %=2 D YN^LRU I %'=1 W !!?26,"OK, no deletions." G END

 D XR^LRU W ! F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT)  W "." F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN  F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI  D K

 W !,$C(7),"OK, DONE." Q

K I $P($P($G(^LR(LRDFN,LRSS,LRI,0)),"^",6)," ")=LRABV K ^(.1)

 Q

 ;

END D V^LRU Q

LRAPDEL   ; IHS/DIR/AAB - ANAT PATH DELETE DESCRIPTIONS 8/12/95 07:42 ;

 +1       ;;5.2;LR;**1002**;JUN 01, 1998

 +2       ;;5.2;LAB SERVICE;**72**;Sep 27, 1994

 +3        DO ^LRAP

           IF '$DATA(Y)

               QUIT 

 +4        WRITE !!?20,"Remove descriptions from ",LRO(68),!!

           DO B^LRU

           IF Y<0

               GOTO END

 +5        SET LRSDT=LRSDT-.01

           SET LRLDT=LRLDT+.99

 +6        WRITE !!?16,"OK to DELETE DESCRIPTIONS (clinical,pathological)",!?21,"from one date thru the other "

           SET %=2

           DO YN^LRU

           IF %'=1

               WRITE !!?32,"OK, forget it !"

               GOTO END

 +7        IF LRSS'="AU"

               SET (LRK,LRZ)=0

               SET X=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),U,4),1:"Microscopic")

               WRITE !!,"OK to delete ",X," entries "

               SET %=2

               DO YN^LRU

               IF %<1

                   GOTO END

               IF %=1

                   SET LRK=1

 +8        DO XR^LRU

           IF LRSS="SP"

               WRITE !!,"OK to delete Frozen Section Description entries "

               SET %=2

               DO YN^LRU

               IF %<1

                   GOTO END

               IF %=1

                   SET LRZ=1

 +9        WRITE !

           FOR X=0:0

               SET LRSDT=$ORDER(^LR(LRXR,LRSDT))

               IF 'LRSDT!(LRSDT>LRLDT)

                   QUIT 

               WRITE "."

               DO LRDFN

OUT        WRITE $CHAR(7),!,"OK DONE !"

           GOTO END

LRDFN      FOR LRDFN=0:0

               SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))

               IF 'LRDFN

                   QUIT 

               DO @($SELECT("CYEMSP"[LRSS:"I",1:"A"))

 +1        QUIT 

I          FOR LRI=0:0

               SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))

               IF 'LRI

                   QUIT 

               IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV

                   KILL ^(.2),^(.3),^(.4),^(.5),^(1),^(1.2),^(4),^(5),^(6),^(7),^(97),^(99)

                   IF LRK

                       KILL ^(1.1)

                   IF LRZ

                       KILL ^(1.3)

 +1        QUIT 

A          KILL ^LR(LRDFN,81),^(82)

           QUIT 

 +1       ;

EN        ;delete free text specimen entries

 +1        SET LRDICS="SPCYEM"

           DO ^LRAP

           IF '$DATA(Y)

               QUIT 

 +2        WRITE !!,"Remove free text specimen entries from ",LRO(68),!!

           DO B^LRU

           IF Y<0

               GOTO END

 +3        SET LRSDT=LRSDT-.01

           SET LRLDT=LRLDT+.99

           WRITE !!?16,"OK to DELETE FREE TEXT ENTRIES from",!?16,LRSTR," to ",LRLST

           SET %=2

           DO YN^LRU

           IF %'=1

               WRITE !!?26,"OK, no deletions."

               GOTO END

 +4        DO XR^LRU

           WRITE !

           FOR X=0:0

               SET LRSDT=$ORDER(^LR(LRXR,LRSDT))

               IF 'LRSDT!(LRSDT>LRLDT)

                   QUIT 

               WRITE "."

               FOR LRDFN=0:0

                   SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))

                   IF 'LRDFN

                       QUIT 

                   FOR LRI=0:0

                       SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))

                       IF 'LRI

                           QUIT 

                       DO K

 +5        WRITE !,$CHAR(7),"OK, DONE."

           QUIT 

K          IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),"^",6)," ")=LRABV

               KILL ^(.1)

 +1        QUIT 

 +2       ;

END        DO V^LRU

           QUIT