- LRAPQACD ; IHS/DIR/AAB - ENTER TC/QA CODES 06:37 ; [ 2/5/97 ]
- ;;5.2;LR;**1006**;SEP 01, 1998
- ;
- ;;5.2;LAB SERVICE;**72,85,155**;Sep 27, 1994
- D ^LRAP G:'$D(Y) END
- S DR=$S(LRSS="AU":"99",1:".99;.14;9") D ^LRAPDA Q
- ;
- EN D ^LRAP G:'$D(Y) END
- W !!?10,"Delete Tissue committee/QA codes from ",LRO(68),!! D B^LRU G:Y<0 END
- S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
- W !!?16,"OK to DELETE TC/QA codes",!?21,"from one date thru another " S %=2 D YN^LRU I %'=1 W !!?32,"OK, forget it !" G END
- D XR^LRU
- 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 ^(9) S $P(^(0),"^",14)=""
- Q
- A K:$P($P($G(^LR(LRDFN,"AU")),U,6)," ")=LRABV ^(99) Q
- ;
- END D V^LRU Q
- LRAPQACD ; IHS/DIR/AAB - ENTER TC/QA CODES 06:37 ; [ 2/5/97 ]
- +1 ;;5.2;LR;**1006**;SEP 01, 1998
- +2 ;
- +3 ;;5.2;LAB SERVICE;**72,85,155**;Sep 27, 1994
- +4 DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- +5 SET DR=$SELECT(LRSS="AU":"99",1:".99;.14;9")
- DO ^LRAPDA
- QUIT
- +6 ;
- EN DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- +1 WRITE !!?10,"Delete Tissue committee/QA codes from ",LRO(68),!!
- DO B^LRU
- IF Y<0
- GOTO END
- +2 SET LRSDT=LRSDT-.01
- SET LRLDT=LRLDT+.99
- +3 WRITE !!?16,"OK to DELETE TC/QA codes",!?21,"from one date thru another "
- SET %=2
- DO YN^LRU
- IF %'=1
- WRITE !!?32,"OK, forget it !"
- GOTO END
- +4 DO XR^LRU
- +5 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 ^(9)
- SET $PIECE(^(0),"^",14)=""
- +1 QUIT
- A IF $PIECE($PIECE($GET(^LR(LRDFN,"AU")),U,6)," ")=LRABV
- KILL ^(99)
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
