LROCM ;SLC/FHS - WARNING MESSAGE ORDER LIST CLEAN-UP ;8/8/89 07:48
;;5.2;LAB SERVICE;;Sep 27, 1994
EN ;
S LRPD=$S($P(^LAB(69.9,1,0),U,9):$P(^(0),U,9),1:7),%DT="",X="T-"_LRPD D ^%DT,ADD^LRX S LRPDATE=Y
;W !!?7,"This option will purge Orders OLDER than '",LRPDATE,"'",!," from the Accession File 68 #",!," There are ",LRPD," days set for 'GRACE PERIOD FOR ORDERS' in file #69.9 ",!
W !!?7,"This Option will not purge the last ",LRPD," days of ORDERS/ACCESSIONS",!
W "As defined by the 'GRACE PERIOD FOR ORDER' field in file #69.9 "
W !!?10,"Orders/Accession OLDER than ",LRPDATE," will be PURGED",!
K LRPD,LRPDATE,%DT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLROCM 636 printed Nov 22, 2024@17:28:33 Page 2
LROCM ;SLC/FHS - WARNING MESSAGE ORDER LIST CLEAN-UP ;8/8/89 07:48
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
EN ;
+1 SET LRPD=$SELECT($PIECE(^LAB(69.9,1,0),U,9):$PIECE(^(0),U,9),1:7)
SET %DT=""
SET X="T-"_LRPD
DO ^%DT
DO ADD^LRX
SET LRPDATE=Y
+2 ;W !!?7,"This option will purge Orders OLDER than '",LRPDATE,"'",!," from the Accession File 68 #",!," There are ",LRPD," days set for 'GRACE PERIOD FOR ORDERS' in file #69.9 ",!
+3 WRITE !!?7,"This Option will not purge the last ",LRPD," days of ORDERS/ACCESSIONS",!
+4 WRITE "As defined by the 'GRACE PERIOD FOR ORDER' field in file #69.9 "
+5 WRITE !!?10,"Orders/Accession OLDER than ",LRPDATE," will be PURGED",!
+6 KILL LRPD,LRPDATE,%DT
QUIT
