ECXPURG ;BIR/CML-Driver for Purge of DSS Data from Local Extract & Holding Files ; 10/8/08 4:25pm
;;3.0;DSS EXTRACTS;**9,24,33,35,49,102,112,144**;Dec 22, 1997;Build 9
ENDEL ;entry point from delete extract files option 144 CVW
W @IOF,!!,"This option will allow you to delete an"
W !,"individual or a range of DSS extracts files."
W !!,"Care must be taken for several reasons:"
W !!,"- You can delete ANY existing extract. This includes transmitted and non-"
W !," transmitted extracts as well as extracts that did not run to completion"
W !," due to errors or system problems."
W !,"- Choosing a range of extracts could mean an excessively large number "
W !," of records and be very CPU intensive. "
W !," Please be sure to queue this deletion for off-hours and"
W !," limit the number of extracts to be deleted per a single queued session."
;
K DIR W !
W !! K DIR S DIR(0)="Y",DIR("A")="Delete Extract Files?",DIR("B")="NO"
;S DIR(0)="SAM^E:Extract Files"
;S DIR("A")="Delete Extract files? E"
;D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y
D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y
I Y D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Deletion of Extract Files" D QUE
;I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Deletion of Extract Files" D QUE
;I ECY="I" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR2^ECXPURG",ZTDESC="DSS - Purge of IVP Holding File" D QUE
;I ECY="U" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR3^ECXPURG",ZTDESC="DSS - Purge of UDP Holding File" D QUE
;I ECY="V" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR4^ECXPURG",ZTDESC="DSS - Purge of VBECS Holding File" D QUE
Q
EN ;entry point from the purge option
W @IOF,!!,"This option will allow you to purge:"
W !,"1. data that resides in the ""holding files"" for the IVP and UDP extracts."
W !,"2. data that resides in the ""holding file"" for the VBECS extract"
W !!,"Care must be taken for several reasons:"
W !,"- The IVP, UDP and VBECS ""holding"" files are intermediate files that"
W !," are populated ""realtime"" by inpatient pharmacy and VBECS activity. "
W !," These files are then used to generate the IVP, UDP and VBECS extracts."
W !," NOTE: The VBECS files CANNOT be regenerated."
W !," Once it is purged for a date range, extracts can no longer be"
W !," generated for that time period."
;
K DIR W !
S DIR(0)="SAM^I:IVP Holding File;U:UDP Holding File;V:VBECS Holding File"
S DIR("A")="Purge (I)VP data, (U)DP data or (V)BECS data? "
D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y
;I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Purge of Extract Files" D QUE
I ECY="I" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR2^ECXPURG",ZTDESC="DSS - Purge of IVP Holding File" D QUE
I ECY="U" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR3^ECXPURG",ZTDESC="DSS - Purge of UDP Holding File" D QUE
I ECY="V" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR4^ECXPURG",ZTDESC="DSS - Purge of VBECS Holding File" D QUE
QUIT ;
K %X,%Y,EC,ECBDT,ECDATE,ECDT,ECEDT,ECEX,ECFR,ECLOC,ECRC,ECTO,ECTRN,ECTYP,ECY,HDT,HI,JJ,LN,LO,PG,QFLG,SS,X,Y,ZTSK
K ECXDIV
S:$D(ZTQUEUED) ZTREQ="@"
Q
QUE W $C(7),$C(7),!!?3,"<<This deletion should be queued to run during non-peak hours.>>",!
D ^%ZTLOAD
I $D(ZTSK) W !,"Request queued as Task #",ZTSK,".",!
Q
;
PUR1 ; entry point for queued purge job of extract files
S ECDA=0 F S ECDA=$O(ECLOC(ECDA)) Q:'ECDA D
.S ECFILE=^ECX(727,ECDA,"FILE"),ECJ=0
.I ECFILE=727.827 D
..S DA(1)=1
..S DA=$O(^ECX(728,DA(1),"CBOC","B",ECDA,0))
..S DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_","
..I DA'="" D ^DIK K DIK,DA
.F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D
..S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA
.I ECFILE=727.816 S ECFILE=727.818,ECJ=0 D
..F S ECJ=$O(^ECX(ECFILE,"AC",ECDA,ECJ)) Q:'ECJ D
...S DIK="^ECX("_ECFILE_",",DA=ECJ D ^DIK K DIK,DA
.S ^ECX(727,ECDA,"PURG")=DT
K XMY S XMY(DUZ)=""
D MAIL1,QUIT
Q
;
PUR2 ; entry point for queued purge job of IVP holding file (#728.113)
F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.113,"A",ECDT)) Q:'ECDT Q:ECDT>ECEDT S ECPT=0 F S ECPT=$O(^ECX(728.113,"A",ECDT,ECPT)) Q:'ECPT D
.S ECOR=0 F S ECOR=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR)) Q:'ECOR D
..S ECREC=0 F S ECREC=$O(^ECX(728.113,"A",ECDT,ECPT,ECOR,ECREC)) Q:'ECREC D
...S DIK="^ECX(728.113,",DA=ECREC D ^DIK K DIK,DA
K XMY S XMY("G.DSS-IV")=""
D MAIL,QUIT
Q
;
PUR3 ; entry point for queued purge job of UDP holding file (#728.904)
F ECDT=ECBDT-1:0 S ECDT=$O(^ECX(728.904,"A",ECDT)) Q:'ECDT Q:ECDT>(ECEDT+.99999999) D
.S ECREC=0 F S ECREC=$O(^ECX(728.904,"A",ECDT,ECREC)) Q:'ECREC D
..S DIK="^ECX(728.904,",DA=ECREC D ^DIK K DIK,DA
K XMY S XMY("G.DSS-UD")=""
D MAIL,QUIT
Q
MAIL ;send mail message
N XMSUB,XMDUZ,ECMSG,XMTEXT
S XMSUB=ZTDESC
S XMDUZ="DSS SYSTEM"
S ECMSG(1,0)="The information has been successfully DELETED"
S ECMSG(2,0)="from "_$$FMTE^XLFDT(ECBDT)_" to "_$$FMTE^XLFDT(ECEDT)
S ECMSG(3,0)=" "
S XMTEXT="ECMSG("
D ^XMD
Q
;
MAIL1 ;send mail message
N XMSUB,XMDUZ,ECMSG,XMTEXT
S XMSUB=ZTDESC
S XMDUZ="DSS SYSTEM"
S ECMSG(1,0)="The information has been successfully PURGED"
S ECMSG(2,0)=" "
S XMTEXT="ECMSG("
D ^XMD
Q
;
PUR4 ; entry point for queued purge job of VBECS holding file (#6002.03)
N ECDT,ECREC,DIK,DA
S ECDT=ECBDT-1,ECEDT=ECEDT+.9
F S ECDT=$O(^VBEC(6002.03,"C",ECDT)) Q:'ECDT!(ECDT>ECEDT) D
.S ECREC=0 F S ECREC=$O(^VBEC(6002.03,"C",ECDT,ECREC)) Q:'ECREC D
..S DIK="^VBEC(6002.03,",DA=ECREC D ^DIK K DIK,DA
K XMY S XMY(DUZ)=""
D MAIL1,QUIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXPURG 6064 printed Apr 09, 2024@20:58:22 Page 2
ECXPURG ;BIR/CML-Driver for Purge of DSS Data from Local Extract & Holding Files ; 10/8/08 4:25pm
+1 ;;3.0;DSS EXTRACTS;**9,24,33,35,49,102,112,144**;Dec 22, 1997;Build 9
ENDEL ;entry point from delete extract files option 144 CVW
+1 WRITE @IOF,!!,"This option will allow you to delete an"
+2 WRITE !,"individual or a range of DSS extracts files."
+3 WRITE !!,"Care must be taken for several reasons:"
+4 WRITE !!,"- You can delete ANY existing extract. This includes transmitted and non-"
+5 WRITE !," transmitted extracts as well as extracts that did not run to completion"
+6 WRITE !," due to errors or system problems."
+7 WRITE !,"- Choosing a range of extracts could mean an excessively large number "
+8 WRITE !," of records and be very CPU intensive. "
+9 WRITE !," Please be sure to queue this deletion for off-hours and"
+10 WRITE !," limit the number of extracts to be deleted per a single queued session."
+11 ;
+12 KILL DIR
WRITE !
+13 WRITE !!
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Delete Extract Files?"
SET DIR("B")="NO"
+14 ;S DIR(0)="SAM^E:Extract Files"
+15 ;S DIR("A")="Delete Extract files? E"
+16 ;D ^DIR K DIR G:$D(DIRUT) QUIT S ECY=Y
+17 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
SET ECY=Y
+18 IF Y
DO ^ECXPURG1
IF $DATA(ECLOC)
SET ZTSAVE("ECLOC(")=""
SET ZTIO=""
SET ZTRTN="PUR1^ECXPURG"
SET ZTDESC="DSS - Deletion of Extract Files"
DO QUE
+19 ;I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Deletion of Extract Files" D QUE
+20 ;I ECY="I" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR2^ECXPURG",ZTDESC="DSS - Purge of IVP Holding File" D QUE
+21 ;I ECY="U" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR3^ECXPURG",ZTDESC="DSS - Purge of UDP Holding File" D QUE
+22 ;I ECY="V" D DATES^ECXPURG1 I $D(ECBDT)&($D(ECEDT)) S (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))="",ZTIO="",ZTRTN="PUR4^ECXPURG",ZTDESC="DSS - Purge of VBECS Holding File" D QUE
+23 QUIT
EN ;entry point from the purge option
+1 WRITE @IOF,!!,"This option will allow you to purge:"
+2 WRITE !,"1. data that resides in the ""holding files"" for the IVP and UDP extracts."
+3 WRITE !,"2. data that resides in the ""holding file"" for the VBECS extract"
+4 WRITE !!,"Care must be taken for several reasons:"
+5 WRITE !,"- The IVP, UDP and VBECS ""holding"" files are intermediate files that"
+6 WRITE !," are populated ""realtime"" by inpatient pharmacy and VBECS activity. "
+7 WRITE !," These files are then used to generate the IVP, UDP and VBECS extracts."
+8 WRITE !," NOTE: The VBECS files CANNOT be regenerated."
+9 WRITE !," Once it is purged for a date range, extracts can no longer be"
+10 WRITE !," generated for that time period."
+11 ;
+12 KILL DIR
WRITE !
+13 SET DIR(0)="SAM^I:IVP Holding File;U:UDP Holding File;V:VBECS Holding File"
+14 SET DIR("A")="Purge (I)VP data, (U)DP data or (V)BECS data? "
+15 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
SET ECY=Y
+16 ;I ECY="E" D ^ECXPURG1 I $D(ECLOC) S ZTSAVE("ECLOC(")="",ZTIO="",ZTRTN="PUR1^ECXPURG",ZTDESC="DSS - Purge of Extract Files" D QUE
+17 IF ECY="I"
DO DATES^ECXPURG1
IF $DATA(ECBDT)&($DATA(ECEDT))
SET (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))=""
SET ZTIO=""
SET ZTRTN="PUR2^ECXPURG"
SET ZTDESC="DSS - Purge of IVP Holding File"
DO QUE
+18 IF ECY="U"
DO DATES^ECXPURG1
IF $DATA(ECBDT)&($DATA(ECEDT))
SET (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))=""
SET ZTIO=""
SET ZTRTN="PUR3^ECXPURG"
SET ZTDESC="DSS - Purge of UDP Holding File"
DO QUE
+19 IF ECY="V"
DO DATES^ECXPURG1
IF $DATA(ECBDT)&($DATA(ECEDT))
SET (ZTSAVE("ECBDT"),ZTSAVE("ECEDT"))=""
SET ZTIO=""
SET ZTRTN="PUR4^ECXPURG"
SET ZTDESC="DSS - Purge of VBECS Holding File"
DO QUE
QUIT ;
+1 KILL %X,%Y,EC,ECBDT,ECDATE,ECDT,ECEDT,ECEX,ECFR,ECLOC,ECRC,ECTO,ECTRN,ECTYP,ECY,HDT,HI,JJ,LN,LO,PG,QFLG,SS,X,Y,ZTSK
+2 KILL ECXDIV
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
QUE WRITE $CHAR(7),$CHAR(7),!!?3,"<<This deletion should be queued to run during non-peak hours.>>",!
+1 DO ^%ZTLOAD
+2 IF $DATA(ZTSK)
WRITE !,"Request queued as Task #",ZTSK,".",!
+3 QUIT
+4 ;
PUR1 ; entry point for queued purge job of extract files
+1 SET ECDA=0
FOR
SET ECDA=$ORDER(ECLOC(ECDA))
if 'ECDA
QUIT
Begin DoDot:1
+2 SET ECFILE=^ECX(727,ECDA,"FILE")
SET ECJ=0
+3 IF ECFILE=727.827
Begin DoDot:2
+4 SET DA(1)=1
+5 SET DA=$ORDER(^ECX(728,DA(1),"CBOC","B",ECDA,0))
+6 SET DIK="^ECX(728,"_DA(1)_","_"""CBOC"""_","
+7 IF DA'=""
DO ^DIK
KILL DIK,DA
End DoDot:2
+8 FOR
SET ECJ=$ORDER(^ECX(ECFILE,"AC",ECDA,ECJ))
if 'ECJ
QUIT
Begin DoDot:2
+9 SET DIK="^ECX("_ECFILE_","
SET DA=ECJ
DO ^DIK
KILL DIK,DA
End DoDot:2
+10 IF ECFILE=727.816
SET ECFILE=727.818
SET ECJ=0
Begin DoDot:2
+11 FOR
SET ECJ=$ORDER(^ECX(ECFILE,"AC",ECDA,ECJ))
if 'ECJ
QUIT
Begin DoDot:3
+12 SET DIK="^ECX("_ECFILE_","
SET DA=ECJ
DO ^DIK
KILL DIK,DA
End DoDot:3
End DoDot:2
+13 SET ^ECX(727,ECDA,"PURG")=DT
End DoDot:1
+14 KILL XMY
SET XMY(DUZ)=""
+15 DO MAIL1
DO QUIT
+16 QUIT
+17 ;
PUR2 ; entry point for queued purge job of IVP holding file (#728.113)
+1 FOR ECDT=ECBDT-1:0
SET ECDT=$ORDER(^ECX(728.113,"A",ECDT))
if 'ECDT
QUIT
if ECDT>ECEDT
QUIT
SET ECPT=0
FOR
SET ECPT=$ORDER(^ECX(728.113,"A",ECDT,ECPT))
if 'ECPT
QUIT
Begin DoDot:1
+2 SET ECOR=0
FOR
SET ECOR=$ORDER(^ECX(728.113,"A",ECDT,ECPT,ECOR))
if 'ECOR
QUIT
Begin DoDot:2
+3 SET ECREC=0
FOR
SET ECREC=$ORDER(^ECX(728.113,"A",ECDT,ECPT,ECOR,ECREC))
if 'ECREC
QUIT
Begin DoDot:3
+4 SET DIK="^ECX(728.113,"
SET DA=ECREC
DO ^DIK
KILL DIK,DA
End DoDot:3
End DoDot:2
End DoDot:1
+5 KILL XMY
SET XMY("G.DSS-IV")=""
+6 DO MAIL
DO QUIT
+7 QUIT
+8 ;
PUR3 ; entry point for queued purge job of UDP holding file (#728.904)
+1 FOR ECDT=ECBDT-1:0
SET ECDT=$ORDER(^ECX(728.904,"A",ECDT))
if 'ECDT
QUIT
if ECDT>(ECEDT+.99999999)
QUIT
Begin DoDot:1
+2 SET ECREC=0
FOR
SET ECREC=$ORDER(^ECX(728.904,"A",ECDT,ECREC))
if 'ECREC
QUIT
Begin DoDot:2
+3 SET DIK="^ECX(728.904,"
SET DA=ECREC
DO ^DIK
KILL DIK,DA
End DoDot:2
End DoDot:1
+4 KILL XMY
SET XMY("G.DSS-UD")=""
+5 DO MAIL
DO QUIT
+6 QUIT
MAIL ;send mail message
+1 NEW XMSUB,XMDUZ,ECMSG,XMTEXT
+2 SET XMSUB=ZTDESC
+3 SET XMDUZ="DSS SYSTEM"
+4 SET ECMSG(1,0)="The information has been successfully DELETED"
+5 SET ECMSG(2,0)="from "_$$FMTE^XLFDT(ECBDT)_" to "_$$FMTE^XLFDT(ECEDT)
+6 SET ECMSG(3,0)=" "
+7 SET XMTEXT="ECMSG("
+8 DO ^XMD
+9 QUIT
+10 ;
MAIL1 ;send mail message
+1 NEW XMSUB,XMDUZ,ECMSG,XMTEXT
+2 SET XMSUB=ZTDESC
+3 SET XMDUZ="DSS SYSTEM"
+4 SET ECMSG(1,0)="The information has been successfully PURGED"
+5 SET ECMSG(2,0)=" "
+6 SET XMTEXT="ECMSG("
+7 DO ^XMD
+8 QUIT
+9 ;
PUR4 ; entry point for queued purge job of VBECS holding file (#6002.03)
+1 NEW ECDT,ECREC,DIK,DA
+2 SET ECDT=ECBDT-1
SET ECEDT=ECEDT+.9
+3 FOR
SET ECDT=$ORDER(^VBEC(6002.03,"C",ECDT))
if 'ECDT!(ECDT>ECEDT)
QUIT
Begin DoDot:1
+4 SET ECREC=0
FOR
SET ECREC=$ORDER(^VBEC(6002.03,"C",ECDT,ECREC))
if 'ECREC
QUIT
Begin DoDot:2
+5 SET DIK="^VBEC(6002.03,"
SET DA=ECREC
DO ^DIK
KILL DIK,DA
End DoDot:2
End DoDot:1
+6 KILL XMY
SET XMY(DUZ)=""
+7 DO MAIL1
DO QUIT
+8 QUIT
