DGSCHAD1.m

DGSCHAD1 ;ALB/MRL - PURGE SCHEDULED ADMISSIONS ; 06 May 87

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 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.

DGSCHAD1  ;ALB/MRL - PURGE SCHEDULED ADMISSIONS ; 06 May 87

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 +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.