DGPREP4 ;ALB/SCK - Delete/Purge Utilities for Pre-registration ; 1/1/97
;;5.3;Registration;**109**;Aug 13, 1993
Q
;
PURGE42 ; Interactive call for purging call list
N DGPX
I '$D(^XUSEC("DGPRE SUPV",DUZ)) D Q
. W !!,"You do not have the DGPRE Supervisor key"
. W !,"Please contact your supervisor."
W !
D PRGLST(1,.DGPX)
W !,DGPX," Entries purged from the Pre-Registration Call List."
Q
;
PRGLST(DGPFLG,DGPCNT) ; Purges all called entries from the PRE-REGISTRATION CALL LIST File, #41.42
;
N DGPN1
S (DGPN1,DGPCNT)=0
F S DGPN1=$O(^DGS(41.42,DGPN1)) Q:DGPN1']"" D
. I $P($G(^DGS(41.42,DGPN1,0)),U,6)="Y" D
.. S DIK="^DGS(41.42,",DA=DGPN1
.. D ^DIK K DIK
.. S DGPCNT=+$G(DGPCNT)+1
. W:$G(DGPFLG) "."
;
PRGQ Q
;
CLEAR42 ; Interactive call for clearing the call list
N DGPX
I '$D(^XUSEC("DGPRE SUPV",DUZ)) D Q
. W !!,"You do not have the DGPRE Supervisor key,"
. W !,"Please contact your supervisor."
W !
D CLRLST(1,.DGPX)
W !!,DGPX," Entries deleted from the Pre-Registration Call List."
Q
;
CLRLST(DGPFLG,DGPCNT) ; Deletes all entries from the PRE-REGISTRATION CALL LIST File, #41.42
N DGPN1
S (DGPN1,DGPCNT)=0
F S DGPN1=$O(^DGS(41.42,DGPN1)) Q:DGPN1']"" D
. S DIK="^DGS(41.42,",DA=DGPN1
. D ^DIK K DIK
. W:$G(DGPFLG) "."
. S DGPCNT=$G(DGPCNT)+1
;
Q
;
PURGE43 ; Interactive call to purge the Pre-registration call log file
;
N X1,X2,DGPCNT,DGPDT,DGPN2,XD
K DIRUT,DUOUT
;
S DGPCNT=0
I '$D(^XUSEC("DGPRE SUPV",DUZ)) D Q
. W !!,"You do not have the DGPRE Supervisor key,"
. W !,"Please contact your supervisor."
;
S DIR(0)="DA^::EX"
S XD=+$P($G(^DG(43,1,"DGPRE")),U,4)
S X1=$P($$NOW^XLFDT,"."),X2=$$FMADD^XLFDT(X1,$S(XD>0:-XD,1:-60))
S DIR("B")=$$FMTE^XLFDT(X2)
S DIR("A")="Enter purge date for Call Log : "
S DIR("?",1)="All log entries prior to this date will be purged."
S DIR("?")="Enter date in a valid VA Format."
D ^DIR K DIR
Q:$D(DIRUT)
S DGPDT=Y
S DIR(0)="YA"
S DIR("A")="Do you really want to purge all entries prior to "_$$FMTE^XLFDT(DGPDT)_"? "
D ^DIR K DIR
Q:'Y
D WAIT^DICD
S X1=0
;
F S X1=$O(^DGS(41.43,"B",X1)) Q:X1']""!(X1>DGPDT) D
. S DGPN2="" F S DGPN2=$O(^DGS(41.43,"B",X1,DGPN2)) Q:'DGPN2 D
.. S DIK="^DGS(41.43,",DA=DGPN2
.. D ^DIK K DIK,DA
.. S DGPCNT=+$G(DGPCNT)+1
;
W !!,+$G(DGPCNT)," Entries were purged from the PRE-REGISTRATION CALL LOG File."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPREP4 2444 printed Apr 09, 2024@22:04:43 Page 2
DGPREP4 ;ALB/SCK - Delete/Purge Utilities for Pre-registration ; 1/1/97
+1 ;;5.3;Registration;**109**;Aug 13, 1993
+2 QUIT
+3 ;
PURGE42 ; Interactive call for purging call list
+1 NEW DGPX
+2 IF '$DATA(^XUSEC("DGPRE SUPV",DUZ))
Begin DoDot:1
+3 WRITE !!,"You do not have the DGPRE Supervisor key"
+4 WRITE !,"Please contact your supervisor."
End DoDot:1
QUIT
+5 WRITE !
+6 DO PRGLST(1,.DGPX)
+7 WRITE !,DGPX," Entries purged from the Pre-Registration Call List."
+8 QUIT
+9 ;
PRGLST(DGPFLG,DGPCNT) ; Purges all called entries from the PRE-REGISTRATION CALL LIST File, #41.42
+1 ;
+2 NEW DGPN1
+3 SET (DGPN1,DGPCNT)=0
+4 FOR
SET DGPN1=$ORDER(^DGS(41.42,DGPN1))
if DGPN1']""
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^DGS(41.42,DGPN1,0)),U,6)="Y"
Begin DoDot:2
+6 SET DIK="^DGS(41.42,"
SET DA=DGPN1
+7 DO ^DIK
KILL DIK
+8 SET DGPCNT=+$GET(DGPCNT)+1
End DoDot:2
+9 if $GET(DGPFLG)
WRITE "."
End DoDot:1
+10 ;
PRGQ QUIT
+1 ;
CLEAR42 ; Interactive call for clearing the call list
+1 NEW DGPX
+2 IF '$DATA(^XUSEC("DGPRE SUPV",DUZ))
Begin DoDot:1
+3 WRITE !!,"You do not have the DGPRE Supervisor key,"
+4 WRITE !,"Please contact your supervisor."
End DoDot:1
QUIT
+5 WRITE !
+6 DO CLRLST(1,.DGPX)
+7 WRITE !!,DGPX," Entries deleted from the Pre-Registration Call List."
+8 QUIT
+9 ;
CLRLST(DGPFLG,DGPCNT) ; Deletes all entries from the PRE-REGISTRATION CALL LIST File, #41.42
+1 NEW DGPN1
+2 SET (DGPN1,DGPCNT)=0
+3 FOR
SET DGPN1=$ORDER(^DGS(41.42,DGPN1))
if DGPN1']""
QUIT
Begin DoDot:1
+4 SET DIK="^DGS(41.42,"
SET DA=DGPN1
+5 DO ^DIK
KILL DIK
+6 if $GET(DGPFLG)
WRITE "."
+7 SET DGPCNT=$GET(DGPCNT)+1
End DoDot:1
+8 ;
+9 QUIT
+10 ;
PURGE43 ; Interactive call to purge the Pre-registration call log file
+1 ;
+2 NEW X1,X2,DGPCNT,DGPDT,DGPN2,XD
+3 KILL DIRUT,DUOUT
+4 ;
+5 SET DGPCNT=0
+6 IF '$DATA(^XUSEC("DGPRE SUPV",DUZ))
Begin DoDot:1
+7 WRITE !!,"You do not have the DGPRE Supervisor key,"
+8 WRITE !,"Please contact your supervisor."
End DoDot:1
QUIT
+9 ;
+10 SET DIR(0)="DA^::EX"
+11 SET XD=+$PIECE($GET(^DG(43,1,"DGPRE")),U,4)
+12 SET X1=$PIECE($$NOW^XLFDT,".")
SET X2=$$FMADD^XLFDT(X1,$SELECT(XD>0:-XD,1:-60))
+13 SET DIR("B")=$$FMTE^XLFDT(X2)
+14 SET DIR("A")="Enter purge date for Call Log : "
+15 SET DIR("?",1)="All log entries prior to this date will be purged."
+16 SET DIR("?")="Enter date in a valid VA Format."
+17 DO ^DIR
KILL DIR
+18 if $DATA(DIRUT)
QUIT
+19 SET DGPDT=Y
+20 SET DIR(0)="YA"
+21 SET DIR("A")="Do you really want to purge all entries prior to "_$$FMTE^XLFDT(DGPDT)_"? "
+22 DO ^DIR
KILL DIR
+23 if 'Y
QUIT
+24 DO WAIT^DICD
+25 SET X1=0
+26 ;
+27 FOR
SET X1=$ORDER(^DGS(41.43,"B",X1))
if X1']""!(X1>DGPDT)
QUIT
Begin DoDot:1
+28 SET DGPN2=""
FOR
SET DGPN2=$ORDER(^DGS(41.43,"B",X1,DGPN2))
if 'DGPN2
QUIT
Begin DoDot:2
+29 SET DIK="^DGS(41.43,"
SET DA=DGPN2
+30 DO ^DIK
KILL DIK,DA
+31 SET DGPCNT=+$GET(DGPCNT)+1
End DoDot:2
End DoDot:1
+32 ;
+33 WRITE !!,+$GET(DGPCNT)," Entries were purged from the PRE-REGISTRATION CALL LOG File."
+34 QUIT
