- 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 Jan 18, 2025@03:51:47 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