LRAPDAC ;AVAMC/REG - DELETE AP YEARLY ACCESSIONS ;5/9/91 18:12 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
W !!,?20,"Delete anatomic pathology accession lists"
S %DT="",X="T" D ^%DT S LRA=$E(Y,1,3)-1_"0000"
AREA 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
;
ASK 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
W !!,"Ok to delete " S %=2 D YN^LRU G:%'=1 ASK
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)
W !,"Done." G ASK
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPDAC 836 printed Nov 22, 2024@17:17:20 Page 2
LRAPDAC ;AVAMC/REG - DELETE AP YEARLY ACCESSIONS ;5/9/91 18:12 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 WRITE !!,?20,"Delete anatomic pathology accession lists"
+3 SET %DT=""
SET X="T"
DO ^%DT
SET LRA=$EXTRACT(Y,1,3)-1_"0000"
AREA WRITE !
SET DIC=68
SET DIC(0)="AEQMZ"
SET DIC("A")="Select ANATOMIC PATHOLOGY SECTION: "
SET DIC("S")="I ""AUCYEMSP""[$P(^(0),U,2)&($P(^(0),U,2)]"""")"
DO ^DIC
KILL DIC
if Y<1
GOTO END
SET LRAA=+Y
DO ASK
GOTO AREA
+1 ;
ASK WRITE !
SET %DT="AEQ"
SET %DT("A")="Enter year to delete: "
DO ^%DT
if Y<1
QUIT
SET LR=$EXTRACT(Y,1,3)_"0000"
IF LR'<LRA
WRITE $CHAR(7)," Cannot be current or last year."
GOTO ASK
+1 WRITE !!,"Ok to delete "
SET %=2
DO YN^LRU
if %'=1
GOTO ASK
+2 LOCK +^LRO(68,LRAA,1)
KILL ^LRO(68,LRAA,1,LR),^LRO(68,LRAA,1,"B",LR,LR)
SET X=^LRO(68,LRAA,1,0)
SET X(1)=$ORDER(^LRO(68,LRAA,1,0))
SET ^(0)=$PIECE(X,"^",1,2)_"^"_X(1)_"^"_$SELECT(X(1)="":"",1:($PIECE(X,"^",4)-1))
LOCK -^LRO(68,LRAA,1)
+3 WRITE !,"Done."
GOTO ASK
+4 ;
END DO V^LRU
QUIT
