ACDPURG.m

ACDPURG ;IHS/ADC/EDE/KML - PURGE DAT OVER 3 YEARS OLD;

 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

EN ;EP

 ;//[ACD SUPER5]

 W @IOF,"Signon Program is            : ",$P(^DIC(4,DUZ(2),0),U)

 ;

 ;

 ;Stop user if HQ

 I $E(ACD6DIG)=9 W !!,*7,"Headquarters may not purge data." D K Q

 I $E(ACD6DIG,3,4)="00" W !!,*7,"Area's may not purge data." D K Q

 ;

 K ACDPGM

 F ACDDA=0:0 S ACDDA=$O(^ACDVIS("C",ACDDA)) Q:'ACDDA  S ACDPGM(ACDDA)=""

 F ACDDA=0:0 S ACDDA=$O(^ACDPD("C",ACDDA)) Q:'ACDDA  S ACDPGM(ACDDA)=""

 F ACDDA=0:0 S ACDDA=$O(^ACDINTV("C",ACDDA)) Q:'ACDDA  S ACDPGM(ACDDA)=""

 I '$O(ACDPGM(0)) G K

 ;

 ;Force dates back 3 years

 D NOW^%DTC S DT=X,X1=DT,X2=-1095 D C^%DTC S ACDTO=X W !!,"I will purge data older than ",$$DD^ACDFUNC(ACDTO)

 ;

 ;verify user wants to continue

 W !!!,"Purging for all CDMIS visit/prevention/intervention data",!!,"Older than: ",!,$$DD^ACDFUNC(ACDTO),!!,"for Program(s): " F DA=0:0 S DA=$O(ACDPGM(DA)) Q:'DA  W !,$P(^DIC(4,DA,0),U)

 ;

 F  W !!,"OK to continue" S %=2 D YN^DICN W:%=0 "  Answer Yes or No" G:%'=1&(%'=0) K Q:%=1

 W !!,"First let me break the Visit Links....."

 F ACDAT=0:0 S ACDAT=$O(^ACDVIS("B",ACDAT)) Q:'ACDAT!(ACDAT>ACDTO)  F DA=0:0 S DA=$O(^ACDVIS("B",ACDAT,DA)) Q:'DA  I $D(^ACDVIS(DA,0)),$D(^ACDVIS(DA,"BWP")),$D(ACDPGM(^("BWP"))) S DIK="^ACDVIS(" D ^DIK

 D EN1^ACDCLN

 W !!,"Now purging old prevention data"

 F ACDAT=0:0 S ACDAT=$O(^ACDPD("B",ACDAT)) Q:'ACDAT!(ACDAT>ACDTO)  F DA=0:0 S DA=$O(^ACDPD("B",ACDAT,DA)) Q:'DA  I $D(^ACDPD(DA,0)),$D(ACDPGM($P(^(0),U,4))) S DIK="^ACDPD(" D ^DIK W "."

 W !!,"Now purging old intervention data"

 F ACDAT=0:0 S ACDAT=$O(^ACDINTV("B",ACDAT)) Q:'ACDAT!(ACDAT>ACDTO)  F DA=0:0 S DA=$O(^ACDINTV("B",ACDAT,DA)) Q:'DA  I $D(^ACDINTV(DA,0)),$D(ACDPGM($P(^(0),U,17))) S DIK="^ACDINTV(" D ^DIK W "."

K ;

 K DIC,DIK,DA,ACDPGM,Y,ACDTO,ACDFR

 K ACDAT

 Q

ACDPURG   ;IHS/ADC/EDE/KML - PURGE DAT OVER 3 YEARS OLD;

 +1       ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998

EN        ;EP

 +1       ;//[ACD SUPER5]

 +2        WRITE @IOF,"Signon Program is            : ",$PIECE(^DIC(4,DUZ(2),0),U)

 +3       ;

 +4       ;

 +5       ;Stop user if HQ

 +6        IF $EXTRACT(ACD6DIG)=9

               WRITE !!,*7,"Headquarters may not purge data."

               DO K

               QUIT 

 +7        IF $EXTRACT(ACD6DIG,3,4)="00"

               WRITE !!,*7,"Area's may not purge data."

               DO K

               QUIT 

 +8       ;

 +9        KILL ACDPGM

 +10       FOR ACDDA=0:0

               SET ACDDA=$ORDER(^ACDVIS("C",ACDDA))

               IF 'ACDDA

                   QUIT 

               SET ACDPGM(ACDDA)=""

 +11       FOR ACDDA=0:0

               SET ACDDA=$ORDER(^ACDPD("C",ACDDA))

               IF 'ACDDA

                   QUIT 

               SET ACDPGM(ACDDA)=""

 +12       FOR ACDDA=0:0

               SET ACDDA=$ORDER(^ACDINTV("C",ACDDA))

               IF 'ACDDA

                   QUIT 

               SET ACDPGM(ACDDA)=""

 +13       IF '$ORDER(ACDPGM(0))

               GOTO K

 +14      ;

 +15      ;Force dates back 3 years

 +16       DO NOW^%DTC

           SET DT=X

           SET X1=DT

           SET X2=-1095

           DO C^%DTC

           SET ACDTO=X

           WRITE !!,"I will purge data older than ",$$DD^ACDFUNC(ACDTO)

 +17      ;

 +18      ;verify user wants to continue

 +19       WRITE !!!,"Purging for all CDMIS visit/prevention/intervention data",!!,"Older than: ",!,$$DD^ACDFUNC(ACDTO),!!,"for Program(s): "

           FOR DA=0:0

               SET DA=$ORDER(ACDPGM(DA))

               IF 'DA

                   QUIT 

               WRITE !,$PIECE(^DIC(4,DA,0),U)

 +20      ;

 +21       FOR 

               WRITE !!,"OK to continue"

               SET %=2

               DO YN^DICN

               IF %=0

                   WRITE "  Answer Yes or No"

               IF %'=1&(%'=0)

                   GOTO K

               IF %=1

                   QUIT 

 +22       WRITE !!,"First let me break the Visit Links....."

 +23       FOR ACDAT=0:0

               SET ACDAT=$ORDER(^ACDVIS("B",ACDAT))

               IF 'ACDAT!(ACDAT>ACDTO)

                   QUIT 

               FOR DA=0:0

                   SET DA=$ORDER(^ACDVIS("B",ACDAT,DA))

                   IF 'DA

                       QUIT 

                   IF $DATA(^ACDVIS(DA,0))

                       IF $DATA(^ACDVIS(DA,"BWP"))

                           IF $DATA(ACDPGM(^("BWP")))

                               SET DIK="^ACDVIS("

                               DO ^DIK

 +24       DO EN1^ACDCLN

 +25       WRITE !!,"Now purging old prevention data"

 +26       FOR ACDAT=0:0

               SET ACDAT=$ORDER(^ACDPD("B",ACDAT))

               IF 'ACDAT!(ACDAT>ACDTO)

                   QUIT 

               FOR DA=0:0

                   SET DA=$ORDER(^ACDPD("B",ACDAT,DA))

                   IF 'DA

                       QUIT 

                   IF $DATA(^ACDPD(DA,0))

                       IF $DATA(ACDPGM($PIECE(^(0),U,4)))

                           SET DIK="^ACDPD("

                           DO ^DIK

                           WRITE "."

 +27       WRITE !!,"Now purging old intervention data"

 +28       FOR ACDAT=0:0

               SET ACDAT=$ORDER(^ACDINTV("B",ACDAT))

               IF 'ACDAT!(ACDAT>ACDTO)

                   QUIT 

               FOR DA=0:0

                   SET DA=$ORDER(^ACDINTV("B",ACDAT,DA))

                   IF 'DA

                       QUIT 

                   IF $DATA(^ACDINTV(DA,0))

                       IF $DATA(ACDPGM($PIECE(^(0),U,17)))

                           SET DIK="^ACDINTV("

                           DO ^DIK

                           WRITE "."

K         ;

 +1        KILL DIC,DIK,DA,ACDPGM,Y,ACDTO,ACDFR

 +2        KILL ACDAT

 +3        QUIT