DGSCHAD1 ;ALB/MRL - PURGE SCHEDULED ADMISSIONS ; 06 May 87
;;5.3;Registration;;Aug 13, 1993
D:'$D(DT) DT^DICRW S U="^" S:'$D(DTIME) DTIME=999 S IOP="HOME" D ^%ZIS K IOP
F I=1:1 S J=$P($T(T+I),";;",2) Q:J']"" W !,J
1 W !! S X1=DT,X2=-90 D C^%DTC S X1=$E(X,1,5)_"01",X2=-1 D C^%DTC S DGPD=X_".2359",Y=X X ^DD("DD") S %DT("A")="Purge Scheduled Admissions Through What Date: ",%DT("B")=Y,%DT="EA" D ^%DT K %DT G Q:Y'>0 S Y=Y_".2359"
I Y>DGPD W !?4,"MUST RETAIN LAST 90 DAYS OF SCHEDULED ADMISSION DATA!",*7 G 1
I $O(^DGS(41.1,"C",0))>DGPD W !!,"NO ADMISSIONS SCHEDULED ON OR BEFORE " S Y=$P(DGPD,".",1) X ^DD("DD") W Y,".",*7 G Q
S ION="",DGPD=Y,DGVAR="DGPD",DGPGM="S^DGSCHAD1" D QUE^DGUTQ G Q:POP U IO
Q K %DT,X1,X2,X,DGPD,Y,J,I,DGPGM,DGVAR D CLOSE^DGUTQ Q
S F DGD=0:0 S DGD=$O(^DGS(41.1,"C",DGD)) Q:'DGD!(DGD>DGPD) F DGD1=0:0 S DGD1=$O(^DGS(41.1,"C",DGD,DGD1)) Q:DGD1'>0 I $D(^DGS(41.1,DGD1,0)) S DIK="^DGS(41.1,",DA=DGD1 D ^DIK K DIK
G Q
T ;
;;This routine is designed to purge your scheduled admissions file of old data.
;;You will be asked to select the data through which you wish to purge. This date
;;must be at least 90 days into the past. Once the date is selected you will be
;;asked to confirm that you indeed wish to purge all data through that date and
;;the process will then commence. This procedure is performed as a background job
;;therefore output device selection will not be necessary.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGSCHAD1 1441 printed Dec 13, 2024@02:58:48 Page 2
DGSCHAD1 ;ALB/MRL - PURGE SCHEDULED ADMISSIONS ; 06 May 87
+1 ;;5.3;Registration;;Aug 13, 1993
+2 if '$DATA(DT)
DO DT^DICRW
SET U="^"
if '$DATA(DTIME)
SET DTIME=999
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+3 FOR I=1:1
SET J=$PIECE($TEXT(T+I),";;",2)
if J']""
QUIT
WRITE !,J
1 WRITE !!
SET X1=DT
SET X2=-90
DO C^%DTC
SET X1=$EXTRACT(X,1,5)_"01"
SET X2=-1
DO C^%DTC
SET DGPD=X_".2359"
SET Y=X
XECUTE ^DD("DD")
SET %DT("A")="Purge Scheduled Admissions Through What Date: "
SET %DT("B")=Y
SET %DT="EA"
DO ^%DT
KILL %DT
if Y'>0
GOTO Q
SET Y=Y_".2359"
+1 IF Y>DGPD
WRITE !?4,"MUST RETAIN LAST 90 DAYS OF SCHEDULED ADMISSION DATA!",*7
GOTO 1
+2 IF $ORDER(^DGS(41.1,"C",0))>DGPD
WRITE !!,"NO ADMISSIONS SCHEDULED ON OR BEFORE "
SET Y=$PIECE(DGPD,".",1)
XECUTE ^DD("DD")
WRITE Y,".",*7
GOTO Q
+3 SET ION=""
SET DGPD=Y
SET DGVAR="DGPD"
SET DGPGM="S^DGSCHAD1"
DO QUE^DGUTQ
if POP
GOTO Q
USE IO
Q KILL %DT,X1,X2,X,DGPD,Y,J,I,DGPGM,DGVAR
DO CLOSE^DGUTQ
QUIT
S FOR DGD=0:0
SET DGD=$ORDER(^DGS(41.1,"C",DGD))
if 'DGD!(DGD>DGPD)
QUIT
FOR DGD1=0:0
SET DGD1=$ORDER(^DGS(41.1,"C",DGD,DGD1))
if DGD1'>0
QUIT
IF $DATA(^DGS(41.1,DGD1,0))
SET DIK="^DGS(41.1,"
SET DA=DGD1
DO ^DIK
KILL DIK
+1 GOTO Q
T ;
+1 ;;This routine is designed to purge your scheduled admissions file of old data.
+2 ;;You will be asked to select the data through which you wish to purge. This date
+3 ;;must be at least 90 days into the past. Once the date is selected you will be
+4 ;;asked to confirm that you indeed wish to purge all data through that date and
+5 ;;the process will then commence. This procedure is performed as a background job
+6 ;;therefore output device selection will not be necessary.
