source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPDAC.m@ 1754

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

initial load of FOIAVistA 6/30/08 version

File size: 824 bytes
Line 
1LRAPDAC ;AVAMC/REG - DELETE AP YEARLY ACCESSIONS ;5/9/91 18:12 ;
2 ;;5.2;LAB SERVICE;;Sep 27, 1994
3 W !!,?20,"Delete anatomic pathology accession lists"
4 S %DT="",X="T" D ^%DT S LRA=$E(Y,1,3)-1_"0000"
5AREA W ! S DIC=68,DIC(0)="AEQMZ",DIC("A")="Select ANATOMIC PATHOLOGY SECTION: ",DIC("S")="I ""AUCYEMSP""[$P(^(0),U,2)&($P(^(0),U,2)]"""")" D ^DIC K DIC G:Y<1 END S LRAA=+Y D ASK G AREA
6 ;
7ASK W ! S %DT="AEQ",%DT("A")="Enter year to delete: " D ^%DT Q:Y<1 S LR=$E(Y,1,3)_"0000" I LR'<LRA W $C(7)," Cannot be current or last year." G ASK
8 W !!,"Ok to delete " S %=2 D YN^LRU G:%'=1 ASK
9 L +^LRO(68,LRAA,1) K ^LRO(68,LRAA,1,LR),^LRO(68,LRAA,1,"B",LR,LR) S X=^LRO(68,LRAA,1,0),X(1)=$O(^LRO(68,LRAA,1,0)),^(0)=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)="":"",1:($P(X,"^",4)-1)) L -^LRO(68,LRAA,1)
10 W !,"Done." G ASK
11 ;
12END D V^LRU Q
Note: See TracBrowser for help on using the repository browser.