LRAPDAC.m

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 ---LRAPDAC   836     printed  Apr 09, 2024@21:25:21                                                                                                                                                                                                      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