- 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 Jan 18, 2025@03:59:29 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.