IBCNEKIT ;DAOU/ESG - PURGE eIV DATA FILES ;11-JUL-2002
;;2.0;INTEGRATED BILLING;**184,271,316,416,549,595,621,602,659**;21-MAR-94;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
; This routine handles the purging of the eIV data stored in the
; eIV Transmission Queue file (#365.1), the eIV Response file (#365) and
; the EIV EICD TRACKING file (#365.18) IB*2.0*621/DM
; User can pick a date range for the purge. Data created within 6 months
; cannot be purged. The actual global kills are done by a background
; task after hours (8:00pm).
;
EN ;
NEW STOP,BEGDT,ENDDT,STATLIST,IBVER
S IBVER=1
D INIT I STOP G EXIT ; initialize/calculate default dates
D DEFLT I STOP G EXIT ; allow user to change default end date if test system ;IB*2.0*621
D BEGDT I STOP G EXIT ; user interface for beginning date
D ENDDT I STOP G EXIT ; user interface for ending date
D CONFIRM I STOP G EXIT ; confirmation message/final check
D QUEUE ; queuing process
EXIT ;
Q
;
EN1 ; Automated Monthly Purge *IB*2*595
NEW STOP,BEGDT,ENDDT,STATLIST,IBVER
S IBVER=2
D INIT I STOP G EXIT1 ; initialize/calculate default dates
D QUEUE ; queuing process
EXIT1 ;
Q
PURGE ; This procedure is queued to run in the background and does the
; actual purging. Variables available from the TaskMan call are:
;
; STATLIST = list of statuses that are OK to purge
; BEGDT = beginning date for purging
; ENDDT = ending date for purging
;
; First loop through the eIV Transmission Queue file and delete all
; records in the date range whose status is in the list
;
N CNT,DA,DATE,DIK,HLIEN,PFLAG,TQIEN,TQS ;IB*2.0*549 added PFLAG
N IBWEXT,IBIORV
S DATE=$O(^IBCN(365.1,"AE",BEGDT),-1),CNT=0
F S DATE=$O(^IBCN(365.1,"AE",DATE)) Q:'DATE!($P(DATE,".",1)>ENDDT)!$G(ZTSTOP) S TQIEN=0 F S TQIEN=$O(^IBCN(365.1,"AE",DATE,TQIEN)) Q:'TQIEN D Q:$G(ZTSTOP)
. S CNT=CNT+1
. I $D(ZTQUEUED),CNT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
. S TQS=$P($G(^IBCN(365.1,TQIEN,0)),U,4) ; trans queue status
. S IBWEXT=$P($G(^IBCN(365.1,TQIEN,0)),U,10) ; IB*2.0*621/DM WHICH EXTRACT
. S IBIORV=$P($G(^IBCN(365.1,TQIEN,0)),U,11) ; IB*2.0*621/DM QUERY FLAG
. I IBWEXT=4,IBIORV="V" Q ; skip EICD Verification entries as they
. ; will be addressed with EICD Identifications
. I '$F(STATLIST,","_TQS_",") Q ; must be in the list
. I IBWEXT=4,IBIORV="I" D CHKTRK(TQIEN) Q ; check EIV EICD TRACKING for purge
. ; loop through the HL7 messages multiple and kill any response
. ; records that are found for this transmission queue entry
. ; IB*2.0*621/DM Preserve any TQ and response that has DO NOT PURGE set to 1 (YES)
. S PFLAG=0,HLIEN=0,DIK="^IBCN(365,"
. F S HLIEN=$O(^IBCN(365.1,TQIEN,2,HLIEN)) Q:'HLIEN D
.. S DA=$P($G(^IBCN(365.1,TQIEN,2,HLIEN,0)),U,3) Q:'DA
.. I +$$GET1^DIQ(365,DA_",",.11,"I") S PFLAG=1 Q ;"DO NOT PURGE"
.. D ^DIK
.. Q
. ;
. ; now we can kill the transmission queue entry itself
. ; as long as there was no DO NOT PURGE responses IB*2.0*621/DM
. I 'PFLAG S DA=TQIEN,DIK="^IBCN(365.1," D ^DIK K DA,DIK
. Q
;
; Check for a stop request
I $G(ZTSTOP) G PURGEX
;
; Now we must loop through the eIV Response file itself to purge any
; response records that do not have a corresponding transmission
; queue entry. These are the unsolicited responses. The status of
; these responses is always 'response received' so we don't need to
; check the status. For this loop, start from the very beginning of
; the file.
;
S DATE="",DIK="^IBCN(365,",CNT=0
F S DATE=$O(^IBCN(365,"AE",DATE)) Q:'DATE!($P(DATE,".",1)>ENDDT)!$G(ZTSTOP) S DA=0 F S DA=$O(^IBCN(365,"AE",DATE,DA)) Q:'DA D Q:$G(ZTSTOP)
. S CNT=CNT+1
. I $D(ZTQUEUED),CNT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
. ;
. ; IB*2.0*602/TAZ never drop a DO NOT PURGE response
. Q:+$$GET1^DIQ(365,DA_",",.11,"I")
. ; If there is a pointer to the transmission queue file,
. ; make sure the transmission queue record actually exists.
. ; If the TQ exists, quit this loop, if not, remove this response.
. ;
. S TQIEN=+$$GET1^DIQ(365,DA_",",.05,"I")
. D ^DIK
. Q
;
K DA,DIK
PURGEX ;
; Tell TaskManager to delete the task's record
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
INIT ; This procedure calculates the default beginning and ending dates
; and displays screen messages about this option to the user.
;
NEW DATE,FOUND,TQIEN,TQS,RPIEN,RPS,IBHL7,IBDNP
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
;
S STOP=0
;
; This is the list of statuses that are OK to purge
; 3=Response Received
; 5=Communication Failure
; 7=Cancelled
S STATLIST=","_$$FIND1^DIC(365.14,,"B","Response Received")
S STATLIST=STATLIST_","_$$FIND1^DIC(365.14,,"B","Communication Failure")
S STATLIST=STATLIST_","_$$FIND1^DIC(365.14,,"B","Cancelled")_","
;
; Try to find a beginning date in the eIV Transmission Queue file
S DATE="",FOUND=0,BEGDT=DT
F S DATE=$O(^IBCN(365.1,"AE",DATE)) Q:'DATE!FOUND S TQIEN=0 F S TQIEN=$O(^IBCN(365.1,"AE",DATE,TQIEN)) Q:'TQIEN D Q:FOUND
. S TQS=$P($G(^IBCN(365.1,TQIEN,0)),U,4) ; status
. I '$F(STATLIST,","_TQS_",") Q
. ;IB*2.0*602/DM make sure the default earliest date is not a DO NOT PURGE entry
. ;check the HL7 messages multiple to see if DO NOT PURGE is set on any response
. S (IBDNP,IBHL7)=0
. F S IBHL7=$O(^IBCN(365.1,TQIEN,2,IBHL7)) Q:'IBHL7!IBDNP D
.. S RPIEN=$P($G(^IBCN(365.1,TQIEN,2,IBHL7,0)),U,3) Q:'RPIEN
.. I +$$GET1^DIQ(365,RPIEN_",","DO NOT PURGE","I") S IBDNP=1
.. Q
. ;
. I IBDNP,IBVER=2 Q
. I IBDNP W !,"Please wait, checking for the earliest purge date ...",! Q
. ;
. S FOUND=1
. S BEGDT=$P(DATE,".",1)
. Q
;
; If not successful, try to find a beginning date in the eIV Response file.
I 'FOUND D
. S DATE=""
. F S DATE=$O(^IBCN(365,"AE",DATE)) Q:'DATE!FOUND S RPIEN=0 F S RPIEN=$O(^IBCN(365,"AE",DATE,RPIEN)) Q:'RPIEN D Q:FOUND
.. S RPS=$P($G(^IBCN(365,RPIEN,0)),U,6) ; status
.. I '$F(STATLIST,","_RPS_",") Q
.. ;IB*2.0*602/DM do not choose a DO NOT PURGE response
.. I +$$GET1^DIQ(365,RPIEN_",","DO NOT PURGE","I") Q
.. S FOUND=1
.. S BEGDT=$P(DATE,".",1)
.. Q
. Q
;
; default end date, Today minus 182 days (approx 6 months)
S ENDDT=$$FMADD^XLFDT(DT,-182)
;
;I IBVER=1,'FOUND!(BEGDT>ENDDT) D S STOP=1 G INITX ; IB*2.0*621
I IBVER=1,'FOUND,'$$PROD^XUPROD(1)!(BEGDT>ENDDT) D S STOP=1 G INITX
. W !!?5,"Purging of eIV data is not possible at this time."
. I 'FOUND W !?5,"There are no entries in the file that are eligible to be",!?5,"purged or there is no data in the file."
. E W !?5,"The oldest date in the file is ",$$FMTE^XLFDT(BEGDT,"5Z"),".",!?5,"Data cannot be purged unless it is at least 6 months old."
. W ! S DIR(0)="E" D ^DIR K DIR
. Q
I IBVER=2,'FOUND!(BEGDT>ENDDT) D S STOP=1 G INITX
.; Send a MailMan message with Eligible Purge counts ; IB*2.0*621 - Updated Message
.N MGRP,MSG,IBXMY
.S MSG(1)="Purge Electronic Insurance Verification (eIV) Data Files did not find records"
.S MSG(2)="for station "_+$$SITE^VASITE()_"."
.S MSG(3)=""
.S MSG(4)="The option runs automatically on a monthly basis and purges data from the"
.S MSG(5)="IIV RESPONSE file (#365), the IIV TRANSMISSION QUEUE file (#365.1), and the"
.S MSG(6)="EIV EICD TRACKING file (#365.18). The data must be at least six months old"
.S MSG(7)="before it can be purged. Only insurance transactions that have a transmission"
.S MSG(8)="status of ""Response Received"", ""Communication Failure"", or ""Cancelled"""
.S MSG(9)="may be purged."
.; Set to IB site parameter MAILGROUP - IBCNE EIV MESSAGE
.S MGRP=$$MGRP^IBCNEUT5()
.; IB*659/DW Added production check & changed eInsurance mail group to be more self documenting
.I $$PROD^XUPROD(1) S IBXMY("VHAeInsuranceRapidResponse@domain.ext")=""
.D MSG^IBCNEUT5(MGRP,"eIV Purge No Data Found for Station "_+$$SITE^VASITE(),"MSG(",,.IBXMY) ; emails postmaster if IBXMY is null
.Q
;
; At this point, we know that there are some entries eligible for
; purging. Display a message to the user about this option.
I IBVER=2 G INITX
W @IOF
W !?8,"Purge Electronic Insurance Verification (eIV) Data Files"
W !!!," This option will allow you to purge data from the eIV Response File (#365)"
W !," and the eIV Transmission Queue File (#365.1). The data must be at least six"
W !," months old before it can be purged. Only insurance transactions that have a"
W !," transmission status of ""Response Received"", ""Communication Failure"", or"
W !," ""Cancelled"" may be purged. You will be allowed to select a date range for"
W !," this purging. The default beginning date will be the date of the oldest"
W !," eligible record in the system. The default ending date will be six months"
W !," ago from today's date. You may modify this default date range. However, you"
W !," may not select an ending date that is more recent than six months ago."
W !!
INITX ;
Q
;
DEFLT ; IB*621/DW Added to assist with testing
I IBVER=1,('$$PROD^XUPROD(1)) D
. W ?5,"*** For Test Purposes Only:"
. W !!?5,"In test systems one may override the DEFAULT end date."
. W !!?5,"Current default end date is TODAY - 182 DAYS: "_$$FMTE^XLFDT(ENDDT,"5Z"),!!
. NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
. S DIR(0)="DOA^"_BEGDT_":"_DT_":AEX"
. S DIR("A")="Enter the purge default date: "
. S DIR("B")=$$FMTE^XLFDT(ENDDT,"5Z")
. S DIR("?")="This response must be a date between "_$$FMTE^XLFDT(BEGDT,"5Z")_" and "_$$FMTE^XLFDT(DT,"5Z")_"."
. D ^DIR K DIR
. I $D(DIRUT)!'Y S STOP=1 G DEFLTX
. S ENDDT=Y
W !!!
DEFLTX ;
Q
;
BEGDT ; This procedure captures the beginning date from the user.
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="DOA^"_BEGDT_":"_ENDDT_":AEX"
S DIR("A")="Enter the purge begin date: "
S DIR("B")=$$FMTE^XLFDT(BEGDT,"5Z")
S DIR("?")="This response must be a date between "_$$FMTE^XLFDT(BEGDT,"5Z")_" and "_$$FMTE^XLFDT(ENDDT,"5Z")_"."
D ^DIR K DIR
I $D(DIRUT)!'Y S STOP=1 G BEGDTX
S BEGDT=Y
BEGDTX ;
Q
;
ENDDT ; This procedure captures the ending date from the user.
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
W !
S DIR(0)="DOA^"_BEGDT_":"_ENDDT_":AEX"
S DIR("A")=" Enter the purge end date: "
S DIR("B")=$$FMTE^XLFDT(ENDDT,"5Z")
S DIR("?")="This response must be a date between "_$$FMTE^XLFDT(BEGDT,"5Z")_" and "_$$FMTE^XLFDT(ENDDT,"5Z")_"."
D ^DIR K DIR
I $D(DIRUT)!'Y S STOP=1 G ENDDTX
S ENDDT=Y
ENDDTX ;
Q
;
CONFIRM ; This procedure displays a confirmation message to the user and
; asks if it is OK to proceed with the purge.
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
W !!!," You want to purge all eIV data created between "
W $$FMTE^XLFDT(BEGDT,"5Z")," and ",$$FMTE^XLFDT(ENDDT,"5Z"),"."
W !
S DIR(0)="YO",DIR("A")=" OK to continue"
S DIR("B")="NO"
D ^DIR K DIR
I 'Y S STOP=1
CONFX ;
Q
;
QUEUE ; This procedure queues the purge process for later at night.
; The concept for queuing the purge came from the insurance buffer
; purge routine, IBCNBPG. That purge process is also hard-coded to
; be run at 8:00 PM just like this one is.
;
NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
;
; IB*621/DW Added loop below to assist with testing
I IBVER=1,('$$PROD^XUPROD(1)) D I Y D PURGE^IBCNEKIT G QUEUEX
. W !!!!,"*** TEST System only - you may run this immediately",!
. S DIR("A")="Do you want to run this now instead of tasking it for 8:00pm"
. S DIR(0)="Y",DIR("B")="YES"
. D ^DIR
. I Y="^" S STOP=1
;
I STOP G QUEUEX ; IB*2.0*621
S ZTRTN="PURGE^IBCNEKIT" ; TaskMan task entry point
S ZTDESC="Purge eIV Data" ; Task description
S ZTDTH=DT_".20" ; start it at 8:00 PM tonight
S ZTIO=""
S ZTSAVE("BEGDT")=""
S ZTSAVE("ENDDT")=""
S ZTSAVE("STATLIST")=""
D ^%ZTLOAD
I IBVER=2 G QUEUEX
I $G(ZTSK) W !!," Task# ",ZTSK," has been scheduled to purge the eIV data tonight at 8:00 PM."
E W !!," TaskManager could not schedule this task.",!," Contact IRM for technical assistance."
W ! S DIR(0)="E" D ^DIR K DIR
QUEUEX ;
Q
;
CHKTRK(IBTQ1) ; IB*621, Evaluate associated records for one EICD transaction
; IBTQ1 = EICD Identification TQ IEN
;
N FILE,HLIEN,IBTQIEN1,IBTQIEN2,IBFIELDS,IBPURGE,IBSKIP,IBTQIEN,IBTQS
N IBTRKIEN,PFLAG
;
S (IBSKIP,PFLAG)=0
K IBPURGE
S IBTQIEN1=+$$FIND1^DIC(365.18,,"QX",IBTQ1,"B")
Q:'IBTQIEN1 ; the passed TQ IEN is not in the tracking file
S IBPURGE("EICD",365.1,IBTQ1)="" ;EICD TQ for identifications
S IBTQIEN=+$$GET1^DIQ(365.18,IBTQIEN1,.06,"I") ;EICD RESPONSE for identifications
I IBTQIEN S IBPURGE("EICD",365,IBTQIEN)=""
;
; loop through the EICD verification entries looking for exclusions
S IBTRKIEN=0 F S IBTRKIEN=$O(^IBCN(365.18,IBTQIEN1,"INS-FND",IBTRKIEN)) Q:'IBTRKIEN D Q:IBSKIP
. ;
. ; check the 1 node data for associated TQs & their responses
. S IBTQIEN2=IBTRKIEN_","_IBTQIEN1_","
. K IBFIELDS D GETS^DIQ(365.185,IBTQIEN2,"1.01:1.04","I","IBFIELDS")
. ;
. I IBFIELDS(365.185,IBTQIEN2,1.02,"I")="" Q ; No TQ was created
. I IBFIELDS(365.185,IBTQIEN2,1.02,"I")>ENDDT S IBSKIP=1 Q ; TQ not old enough
. S IBTQIEN=+IBFIELDS(365.185,IBTQIEN2,1.01,"I") ; EICD VER INQ TQ
. S IBTQS=+$$GET1^DIQ(365.1,IBTQIEN_",",.04,"I") ; TQ Transmission Status
. I IBTQS,('$F(STATLIST,","_IBTQS_",")) S IBSKIP=1 Q ; must be in the list
. ;
. ; Loop thru all EICD Verifications if any are DO NOT PURGE then kill
. ; nothing associated with it
. S HLIEN=0
. F S HLIEN=$O(^IBCN(365.1,IBTQIEN,2,HLIEN)) Q:'HLIEN!PFLAG D
.. S DA=$P($G(^IBCN(365.1,IBTQIEN,2,HLIEN,0)),U,3) Q:'DA
.. I +$$GET1^DIQ(365,DA_",",.11,"I") S PFLAG=1 Q ;"DO NOT PURGE"
.. S IBPURGE("EICD",365,DA)="" ; array of Verifications to purge (responses)
. I PFLAG Q
. S IBPURGE("EICD",365.1,IBTQIEN)="" ; array of Verifications to purge (inquiries)
;
I PFLAG!IBSKIP K IBPURGE ; DO NOT PURGE is set or Not all records are old enough
;
I '$D(IBPURGE) Q ; No records associated with this entry to purge
S IBPURGE("EICD",365.18,IBTQ1)=""
S FILE="" F S FILE=$O(IBPURGE("EICD",FILE)) Q:'FILE D
. S DIK="^IBCN("_FILE_","
. S DA="" F S DA=$O(IBPURGE("EICD",FILE,DA)) Q:'DA D
.. D ^DIK
K IBPURGE,DA,DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEKIT 14589 printed Sep 23, 2025@19:51:04 Page 2
IBCNEKIT ;DAOU/ESG - PURGE eIV DATA FILES ;11-JUL-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,316,416,549,595,621,602,659**;21-MAR-94;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine handles the purging of the eIV data stored in the
+5 ; eIV Transmission Queue file (#365.1), the eIV Response file (#365) and
+6 ; the EIV EICD TRACKING file (#365.18) IB*2.0*621/DM
+7 ; User can pick a date range for the purge. Data created within 6 months
+8 ; cannot be purged. The actual global kills are done by a background
+9 ; task after hours (8:00pm).
+10 ;
EN ;
+1 NEW STOP,BEGDT,ENDDT,STATLIST,IBVER
+2 SET IBVER=1
+3 ; initialize/calculate default dates
DO INIT
IF STOP
GOTO EXIT
+4 ; allow user to change default end date if test system ;IB*2.0*621
DO DEFLT
IF STOP
GOTO EXIT
+5 ; user interface for beginning date
DO BEGDT
IF STOP
GOTO EXIT
+6 ; user interface for ending date
DO ENDDT
IF STOP
GOTO EXIT
+7 ; confirmation message/final check
DO CONFIRM
IF STOP
GOTO EXIT
+8 ; queuing process
DO QUEUE
EXIT ;
+1 QUIT
+2 ;
EN1 ; Automated Monthly Purge *IB*2*595
+1 NEW STOP,BEGDT,ENDDT,STATLIST,IBVER
+2 SET IBVER=2
+3 ; initialize/calculate default dates
DO INIT
IF STOP
GOTO EXIT1
+4 ; queuing process
DO QUEUE
EXIT1 ;
+1 QUIT
PURGE ; This procedure is queued to run in the background and does the
+1 ; actual purging. Variables available from the TaskMan call are:
+2 ;
+3 ; STATLIST = list of statuses that are OK to purge
+4 ; BEGDT = beginning date for purging
+5 ; ENDDT = ending date for purging
+6 ;
+7 ; First loop through the eIV Transmission Queue file and delete all
+8 ; records in the date range whose status is in the list
+9 ;
+10 ;IB*2.0*549 added PFLAG
NEW CNT,DA,DATE,DIK,HLIEN,PFLAG,TQIEN,TQS
+11 NEW IBWEXT,IBIORV
+12 SET DATE=$ORDER(^IBCN(365.1,"AE",BEGDT),-1)
SET CNT=0
+13 FOR
SET DATE=$ORDER(^IBCN(365.1,"AE",DATE))
if 'DATE!($PIECE(DATE,".",1)>ENDDT)!$GET(ZTSTOP)
QUIT
SET TQIEN=0
FOR
SET TQIEN=$ORDER(^IBCN(365.1,"AE",DATE,TQIEN))
if 'TQIEN
QUIT
Begin DoDot:1
+14 SET CNT=CNT+1
+15 IF $DATA(ZTQUEUED)
IF CNT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+16 ; trans queue status
SET TQS=$PIECE($GET(^IBCN(365.1,TQIEN,0)),U,4)
+17 ; IB*2.0*621/DM WHICH EXTRACT
SET IBWEXT=$PIECE($GET(^IBCN(365.1,TQIEN,0)),U,10)
+18 ; IB*2.0*621/DM QUERY FLAG
SET IBIORV=$PIECE($GET(^IBCN(365.1,TQIEN,0)),U,11)
+19 ; skip EICD Verification entries as they
IF IBWEXT=4
IF IBIORV="V"
QUIT
+20 ; will be addressed with EICD Identifications
+21 ; must be in the list
IF '$FIND(STATLIST,","_TQS_",")
QUIT
+22 ; check EIV EICD TRACKING for purge
IF IBWEXT=4
IF IBIORV="I"
DO CHKTRK(TQIEN)
QUIT
+23 ; loop through the HL7 messages multiple and kill any response
+24 ; records that are found for this transmission queue entry
+25 ; IB*2.0*621/DM Preserve any TQ and response that has DO NOT PURGE set to 1 (YES)
+26 SET PFLAG=0
SET HLIEN=0
SET DIK="^IBCN(365,"
+27 FOR
SET HLIEN=$ORDER(^IBCN(365.1,TQIEN,2,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:2
+28 SET DA=$PIECE($GET(^IBCN(365.1,TQIEN,2,HLIEN,0)),U,3)
if 'DA
QUIT
+29 ;"DO NOT PURGE"
IF +$$GET1^DIQ(365,DA_",",.11,"I")
SET PFLAG=1
QUIT
+30 DO ^DIK
+31 QUIT
End DoDot:2
+32 ;
+33 ; now we can kill the transmission queue entry itself
+34 ; as long as there was no DO NOT PURGE responses IB*2.0*621/DM
+35 IF 'PFLAG
SET DA=TQIEN
SET DIK="^IBCN(365.1,"
DO ^DIK
KILL DA,DIK
+36 QUIT
End DoDot:1
if $GET(ZTSTOP)
QUIT
+37 ;
+38 ; Check for a stop request
+39 IF $GET(ZTSTOP)
GOTO PURGEX
+40 ;
+41 ; Now we must loop through the eIV Response file itself to purge any
+42 ; response records that do not have a corresponding transmission
+43 ; queue entry. These are the unsolicited responses. The status of
+44 ; these responses is always 'response received' so we don't need to
+45 ; check the status. For this loop, start from the very beginning of
+46 ; the file.
+47 ;
+48 SET DATE=""
SET DIK="^IBCN(365,"
SET CNT=0
+49 FOR
SET DATE=$ORDER(^IBCN(365,"AE",DATE))
if 'DATE!($PIECE(DATE,".",1)>ENDDT)!$GET(ZTSTOP)
QUIT
SET DA=0
FOR
SET DA=$ORDER(^IBCN(365,"AE",DATE,DA))
if 'DA
QUIT
Begin DoDot:1
+50 SET CNT=CNT+1
+51 IF $DATA(ZTQUEUED)
IF CNT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+52 ;
+53 ; IB*2.0*602/TAZ never drop a DO NOT PURGE response
+54 if +$$GET1^DIQ(365,DA_",",.11,"I")
QUIT
+55 ; If there is a pointer to the transmission queue file,
+56 ; make sure the transmission queue record actually exists.
+57 ; If the TQ exists, quit this loop, if not, remove this response.
+58 ;
+59 SET TQIEN=+$$GET1^DIQ(365,DA_",",.05,"I")
+60 DO ^DIK
+61 QUIT
End DoDot:1
if $GET(ZTSTOP)
QUIT
+62 ;
+63 KILL DA,DIK
PURGEX ;
+1 ; Tell TaskManager to delete the task's record
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
INIT ; This procedure calculates the default beginning and ending dates
+1 ; and displays screen messages about this option to the user.
+2 ;
+3 NEW DATE,FOUND,TQIEN,TQS,RPIEN,RPS,IBHL7,IBDNP
+4 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+5 ;
+6 SET STOP=0
+7 ;
+8 ; This is the list of statuses that are OK to purge
+9 ; 3=Response Received
+10 ; 5=Communication Failure
+11 ; 7=Cancelled
+12 SET STATLIST=","_$$FIND1^DIC(365.14,,"B","Response Received")
+13 SET STATLIST=STATLIST_","_$$FIND1^DIC(365.14,,"B","Communication Failure")
+14 SET STATLIST=STATLIST_","_$$FIND1^DIC(365.14,,"B","Cancelled")_","
+15 ;
+16 ; Try to find a beginning date in the eIV Transmission Queue file
+17 SET DATE=""
SET FOUND=0
SET BEGDT=DT
+18 FOR
SET DATE=$ORDER(^IBCN(365.1,"AE",DATE))
if 'DATE!FOUND
QUIT
SET TQIEN=0
FOR
SET TQIEN=$ORDER(^IBCN(365.1,"AE",DATE,TQIEN))
if 'TQIEN
QUIT
Begin DoDot:1
+19 ; status
SET TQS=$PIECE($GET(^IBCN(365.1,TQIEN,0)),U,4)
+20 IF '$FIND(STATLIST,","_TQS_",")
QUIT
+21 ;IB*2.0*602/DM make sure the default earliest date is not a DO NOT PURGE entry
+22 ;check the HL7 messages multiple to see if DO NOT PURGE is set on any response
+23 SET (IBDNP,IBHL7)=0
+24 FOR
SET IBHL7=$ORDER(^IBCN(365.1,TQIEN,2,IBHL7))
if 'IBHL7!IBDNP
QUIT
Begin DoDot:2
+25 SET RPIEN=$PIECE($GET(^IBCN(365.1,TQIEN,2,IBHL7,0)),U,3)
if 'RPIEN
QUIT
+26 IF +$$GET1^DIQ(365,RPIEN_",","DO NOT PURGE","I")
SET IBDNP=1
+27 QUIT
End DoDot:2
+28 ;
+29 IF IBDNP
IF IBVER=2
QUIT
+30 IF IBDNP
WRITE !,"Please wait, checking for the earliest purge date ...",!
QUIT
+31 ;
+32 SET FOUND=1
+33 SET BEGDT=$PIECE(DATE,".",1)
+34 QUIT
End DoDot:1
if FOUND
QUIT
+35 ;
+36 ; If not successful, try to find a beginning date in the eIV Response file.
+37 IF 'FOUND
Begin DoDot:1
+38 SET DATE=""
+39 FOR
SET DATE=$ORDER(^IBCN(365,"AE",DATE))
if 'DATE!FOUND
QUIT
SET RPIEN=0
FOR
SET RPIEN=$ORDER(^IBCN(365,"AE",DATE,RPIEN))
if 'RPIEN
QUIT
Begin DoDot:2
+40 ; status
SET RPS=$PIECE($GET(^IBCN(365,RPIEN,0)),U,6)
+41 IF '$FIND(STATLIST,","_RPS_",")
QUIT
+42 ;IB*2.0*602/DM do not choose a DO NOT PURGE response
+43 IF +$$GET1^DIQ(365,RPIEN_",","DO NOT PURGE","I")
QUIT
+44 SET FOUND=1
+45 SET BEGDT=$PIECE(DATE,".",1)
+46 QUIT
End DoDot:2
if FOUND
QUIT
+47 QUIT
End DoDot:1
+48 ;
+49 ; default end date, Today minus 182 days (approx 6 months)
+50 SET ENDDT=$$FMADD^XLFDT(DT,-182)
+51 ;
+52 ;I IBVER=1,'FOUND!(BEGDT>ENDDT) D S STOP=1 G INITX ; IB*2.0*621
+53 IF IBVER=1
IF 'FOUND
IF '$$PROD^XUPROD(1)!(BEGDT>ENDDT)
Begin DoDot:1
+54 WRITE !!?5,"Purging of eIV data is not possible at this time."
+55 IF 'FOUND
WRITE !?5,"There are no entries in the file that are eligible to be",!?5,"purged or there is no data in the file."
+56 IF '$TEST
WRITE !?5,"The oldest date in the file is ",$$FMTE^XLFDT(BEGDT,"5Z"),".",!?5,"Data cannot be purged unless it is at least 6 months old."
+57 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
+58 QUIT
End DoDot:1
SET STOP=1
GOTO INITX
+59 IF IBVER=2
IF 'FOUND!(BEGDT>ENDDT)
Begin DoDot:1
+60 ; Send a MailMan message with Eligible Purge counts ; IB*2.0*621 - Updated Message
+61 NEW MGRP,MSG,IBXMY
+62 SET MSG(1)="Purge Electronic Insurance Verification (eIV) Data Files did not find records"
+63 SET MSG(2)="for station "_+$$SITE^VASITE()_"."
+64 SET MSG(3)=""
+65 SET MSG(4)="The option runs automatically on a monthly basis and purges data from the"
+66 SET MSG(5)="IIV RESPONSE file (#365), the IIV TRANSMISSION QUEUE file (#365.1), and the"
+67 SET MSG(6)="EIV EICD TRACKING file (#365.18). The data must be at least six months old"
+68 SET MSG(7)="before it can be purged. Only insurance transactions that have a transmission"
+69 SET MSG(8)="status of ""Response Received"", ""Communication Failure"", or ""Cancelled"""
+70 SET MSG(9)="may be purged."
+71 ; Set to IB site parameter MAILGROUP - IBCNE EIV MESSAGE
+72 SET MGRP=$$MGRP^IBCNEUT5()
+73 ; IB*659/DW Added production check & changed eInsurance mail group to be more self documenting
+74 IF $$PROD^XUPROD(1)
SET IBXMY("VHAeInsuranceRapidResponse@domain.ext")=""
+75 ; emails postmaster if IBXMY is null
DO MSG^IBCNEUT5(MGRP,"eIV Purge No Data Found for Station "_+$$SITE^VASITE(),"MSG(",,.IBXMY)
+76 QUIT
End DoDot:1
SET STOP=1
GOTO INITX
+77 ;
+78 ; At this point, we know that there are some entries eligible for
+79 ; purging. Display a message to the user about this option.
+80 IF IBVER=2
GOTO INITX
+81 WRITE @IOF
+82 WRITE !?8,"Purge Electronic Insurance Verification (eIV) Data Files"
+83 WRITE !!!," This option will allow you to purge data from the eIV Response File (#365)"
+84 WRITE !," and the eIV Transmission Queue File (#365.1). The data must be at least six"
+85 WRITE !," months old before it can be purged. Only insurance transactions that have a"
+86 WRITE !," transmission status of ""Response Received"", ""Communication Failure"", or"
+87 WRITE !," ""Cancelled"" may be purged. You will be allowed to select a date range for"
+88 WRITE !," this purging. The default beginning date will be the date of the oldest"
+89 WRITE !," eligible record in the system. The default ending date will be six months"
+90 WRITE !," ago from today's date. You may modify this default date range. However, you"
+91 WRITE !," may not select an ending date that is more recent than six months ago."
+92 WRITE !!
INITX ;
+1 QUIT
+2 ;
DEFLT ; IB*621/DW Added to assist with testing
+1 IF IBVER=1
IF ('$$PROD^XUPROD(1))
Begin DoDot:1
+2 WRITE ?5,"*** For Test Purposes Only:"
+3 WRITE !!?5,"In test systems one may override the DEFAULT end date."
+4 WRITE !!?5,"Current default end date is TODAY - 182 DAYS: "_$$FMTE^XLFDT(ENDDT,"5Z"),!!
+5 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+6 SET DIR(0)="DOA^"_BEGDT_":"_DT_":AEX"
+7 SET DIR("A")="Enter the purge default date: "
+8 SET DIR("B")=$$FMTE^XLFDT(ENDDT,"5Z")
+9 SET DIR("?")="This response must be a date between "_$$FMTE^XLFDT(BEGDT,"5Z")_" and "_$$FMTE^XLFDT(DT,"5Z")_"."
+10 DO ^DIR
KILL DIR
+11 IF $DATA(DIRUT)!'Y
SET STOP=1
GOTO DEFLTX
+12 SET ENDDT=Y
End DoDot:1
+13 WRITE !!!
DEFLTX ;
+1 QUIT
+2 ;
BEGDT ; This procedure captures the beginning date from the user.
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="DOA^"_BEGDT_":"_ENDDT_":AEX"
+3 SET DIR("A")="Enter the purge begin date: "
+4 SET DIR("B")=$$FMTE^XLFDT(BEGDT,"5Z")
+5 SET DIR("?")="This response must be a date between "_$$FMTE^XLFDT(BEGDT,"5Z")_" and "_$$FMTE^XLFDT(ENDDT,"5Z")_"."
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)!'Y
SET STOP=1
GOTO BEGDTX
+8 SET BEGDT=Y
BEGDTX ;
+1 QUIT
+2 ;
ENDDT ; This procedure captures the ending date from the user.
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 WRITE !
+3 SET DIR(0)="DOA^"_BEGDT_":"_ENDDT_":AEX"
+4 SET DIR("A")=" Enter the purge end date: "
+5 SET DIR("B")=$$FMTE^XLFDT(ENDDT,"5Z")
+6 SET DIR("?")="This response must be a date between "_$$FMTE^XLFDT(BEGDT,"5Z")_" and "_$$FMTE^XLFDT(ENDDT,"5Z")_"."
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)!'Y
SET STOP=1
GOTO ENDDTX
+9 SET ENDDT=Y
ENDDTX ;
+1 QUIT
+2 ;
CONFIRM ; This procedure displays a confirmation message to the user and
+1 ; asks if it is OK to proceed with the purge.
+2 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+3 WRITE !!!," You want to purge all eIV data created between "
+4 WRITE $$FMTE^XLFDT(BEGDT,"5Z")," and ",$$FMTE^XLFDT(ENDDT,"5Z"),"."
+5 WRITE !
+6 SET DIR(0)="YO"
SET DIR("A")=" OK to continue"
+7 SET DIR("B")="NO"
+8 DO ^DIR
KILL DIR
+9 IF 'Y
SET STOP=1
CONFX ;
+1 QUIT
+2 ;
QUEUE ; This procedure queues the purge process for later at night.
+1 ; The concept for queuing the purge came from the insurance buffer
+2 ; purge routine, IBCNBPG. That purge process is also hard-coded to
+3 ; be run at 8:00 PM just like this one is.
+4 ;
+5 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
+6 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+7 ;
+8 ; IB*621/DW Added loop below to assist with testing
+9 IF IBVER=1
IF ('$$PROD^XUPROD(1))
Begin DoDot:1
+10 WRITE !!!!,"*** TEST System only - you may run this immediately",!
+11 SET DIR("A")="Do you want to run this now instead of tasking it for 8:00pm"
+12 SET DIR(0)="Y"
SET DIR("B")="YES"
+13 DO ^DIR
+14 IF Y="^"
SET STOP=1
End DoDot:1
IF Y
DO PURGE^IBCNEKIT
GOTO QUEUEX
+15 ;
+16 ; IB*2.0*621
IF STOP
GOTO QUEUEX
+17 ; TaskMan task entry point
SET ZTRTN="PURGE^IBCNEKIT"
+18 ; Task description
SET ZTDESC="Purge eIV Data"
+19 ; start it at 8:00 PM tonight
SET ZTDTH=DT_".20"
+20 SET ZTIO=""
+21 SET ZTSAVE("BEGDT")=""
+22 SET ZTSAVE("ENDDT")=""
+23 SET ZTSAVE("STATLIST")=""
+24 DO ^%ZTLOAD
+25 IF IBVER=2
GOTO QUEUEX
+26 IF $GET(ZTSK)
WRITE !!," Task# ",ZTSK," has been scheduled to purge the eIV data tonight at 8:00 PM."
+27 IF '$TEST
WRITE !!," TaskManager could not schedule this task.",!," Contact IRM for technical assistance."
+28 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUEUEX ;
+1 QUIT
+2 ;
CHKTRK(IBTQ1) ; IB*621, Evaluate associated records for one EICD transaction
+1 ; IBTQ1 = EICD Identification TQ IEN
+2 ;
+3 NEW FILE,HLIEN,IBTQIEN1,IBTQIEN2,IBFIELDS,IBPURGE,IBSKIP,IBTQIEN,IBTQS
+4 NEW IBTRKIEN,PFLAG
+5 ;
+6 SET (IBSKIP,PFLAG)=0
+7 KILL IBPURGE
+8 SET IBTQIEN1=+$$FIND1^DIC(365.18,,"QX",IBTQ1,"B")
+9 ; the passed TQ IEN is not in the tracking file
if 'IBTQIEN1
QUIT
+10 ;EICD TQ for identifications
SET IBPURGE("EICD",365.1,IBTQ1)=""
+11 ;EICD RESPONSE for identifications
SET IBTQIEN=+$$GET1^DIQ(365.18,IBTQIEN1,.06,"I")
+12 IF IBTQIEN
SET IBPURGE("EICD",365,IBTQIEN)=""
+13 ;
+14 ; loop through the EICD verification entries looking for exclusions
+15 SET IBTRKIEN=0
FOR
SET IBTRKIEN=$ORDER(^IBCN(365.18,IBTQIEN1,"INS-FND",IBTRKIEN))
if 'IBTRKIEN
QUIT
Begin DoDot:1
+16 ;
+17 ; check the 1 node data for associated TQs & their responses
+18 SET IBTQIEN2=IBTRKIEN_","_IBTQIEN1_","
+19 KILL IBFIELDS
DO GETS^DIQ(365.185,IBTQIEN2,"1.01:1.04","I","IBFIELDS")
+20 ;
+21 ; No TQ was created
IF IBFIELDS(365.185,IBTQIEN2,1.02,"I")=""
QUIT
+22 ; TQ not old enough
IF IBFIELDS(365.185,IBTQIEN2,1.02,"I")>ENDDT
SET IBSKIP=1
QUIT
+23 ; EICD VER INQ TQ
SET IBTQIEN=+IBFIELDS(365.185,IBTQIEN2,1.01,"I")
+24 ; TQ Transmission Status
SET IBTQS=+$$GET1^DIQ(365.1,IBTQIEN_",",.04,"I")
+25 ; must be in the list
IF IBTQS
IF ('$FIND(STATLIST,","_IBTQS_","))
SET IBSKIP=1
QUIT
+26 ;
+27 ; Loop thru all EICD Verifications if any are DO NOT PURGE then kill
+28 ; nothing associated with it
+29 SET HLIEN=0
+30 FOR
SET HLIEN=$ORDER(^IBCN(365.1,IBTQIEN,2,HLIEN))
if 'HLIEN!PFLAG
QUIT
Begin DoDot:2
+31 SET DA=$PIECE($GET(^IBCN(365.1,IBTQIEN,2,HLIEN,0)),U,3)
if 'DA
QUIT
+32 ;"DO NOT PURGE"
IF +$$GET1^DIQ(365,DA_",",.11,"I")
SET PFLAG=1
QUIT
+33 ; array of Verifications to purge (responses)
SET IBPURGE("EICD",365,DA)=""
End DoDot:2
+34 IF PFLAG
QUIT
+35 ; array of Verifications to purge (inquiries)
SET IBPURGE("EICD",365.1,IBTQIEN)=""
End DoDot:1
if IBSKIP
QUIT
+36 ;
+37 ; DO NOT PURGE is set or Not all records are old enough
IF PFLAG!IBSKIP
KILL IBPURGE
+38 ;
+39 ; No records associated with this entry to purge
IF '$DATA(IBPURGE)
QUIT
+40 SET IBPURGE("EICD",365.18,IBTQ1)=""
+41 SET FILE=""
FOR
SET FILE=$ORDER(IBPURGE("EICD",FILE))
if 'FILE
QUIT
Begin DoDot:1
+42 SET DIK="^IBCN("_FILE_","
+43 SET DA=""
FOR
SET DA=$ORDER(IBPURGE("EICD",FILE,DA))
if 'DA
QUIT
Begin DoDot:2
+44 DO ^DIK
End DoDot:2
End DoDot:1
+45 KILL IBPURGE,DA,DIK
+46 QUIT
+47 ;
