LRAPQACD ;AVAMC/REG/CYM - ENTER TC/QA CODES ;2/5/97 06:37
;;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPQACD 890 printed Oct 16, 2024@18:08:41 Page 2
LRAPQACD ;AVAMC/REG/CYM - ENTER TC/QA CODES ;2/5/97 06:37
+1 ;;5.2;LAB SERVICE;**72,85,155**;Sep 27, 1994
+2 DO ^LRAP
if '$DATA(Y)
GOTO END
+3 SET DR=$SELECT(LRSS="AU":"99",1:".99;.14;9")
DO ^LRAPDA
QUIT
+4 ;
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
