LRAPQACD.m

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