- 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
