source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPQACD.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 871 bytes
Line 
1LRAPQACD ;AVAMC/REG/CYM - ENTER TC/QA CODES ;2/5/97 06:37
2 ;;5.2;LAB SERVICE;**72,85,155**;Sep 27, 1994
3 D ^LRAP G:'$D(Y) END
4 S DR=$S(LRSS="AU":"99",1:".99;.14;9") D ^LRAPDA Q
5 ;
6EN D ^LRAP G:'$D(Y) END
7 W !!?10,"Delete Tissue committee/QA codes from ",LRO(68),!! D B^LRU G:Y<0 END
8 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
9 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
10 D XR^LRU
11 W ! F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) W "." D LRDFN
12OUT W $C(7),!,"OK DONE !" G END
13LRDFN F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D @($S("CYEMSP"[LRSS:"I",1:"A"))
14 Q
15I 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)=""
16 Q
17A K:$P($P($G(^LR(LRDFN,"AU")),U,6)," ")=LRABV ^(99) Q
18 ;
19END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.