- 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 Mar 13, 2025@21:11:36 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
