- 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
