| [613] | 1 | IBCNEKI2 ;DAOU/BHS - PURGE IIV DATA FILES CONT'D ;11-JUL-2002
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**271,316**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ; This routine holds additional procedures for purging the IIV data
|
|---|
| 6 | ; from the Trans Queue file (365.1) and the Response file (365).
|
|---|
| 7 | ;
|
|---|
| 8 | ; ---------------------------------------------------
|
|---|
| 9 | MMPURGE ; This procedure is responsible for the creation and
|
|---|
| 10 | ; sending of the MailMan message on the first day of the month
|
|---|
| 11 | ; if the site has data eligible to be purged and if the mail group is
|
|---|
| 12 | ; defined appropriately in the IIV site parameters.
|
|---|
| 13 | ;
|
|---|
| 14 | ; Identify records eligible to be purged
|
|---|
| 15 | NEW ENDDT,STATLIST,DATE,TQIEN,TOTTQ,PURTQ,TQS
|
|---|
| 16 | NEW HLIEN,RPIEN,RPS,TOTRP,PURRP,MSG,MGRP
|
|---|
| 17 | ;
|
|---|
| 18 | ; default end date, Today minus 182 days (approx 6 months)
|
|---|
| 19 | S ENDDT=$$FMADD^XLFDT(DT,-182)
|
|---|
| 20 | S (TOTTQ,PURTQ,TOTRP,PURRP)=0
|
|---|
| 21 | ;
|
|---|
| 22 | ; This is the list of statuses that are OK to purge
|
|---|
| 23 | ; 3=Response Received
|
|---|
| 24 | ; 5=Communication Failure
|
|---|
| 25 | ; 7=Cancelled
|
|---|
| 26 | S STATLIST=",3,5,7,"
|
|---|
| 27 | ;
|
|---|
| 28 | S DATE=""
|
|---|
| 29 | F S DATE=$O(^IBCN(365.1,"AE",DATE)) Q:'DATE S TQIEN=0 F S TQIEN=$O(^IBCN(365.1,"AE",DATE,TQIEN)) Q:'TQIEN S TOTTQ=TOTTQ+1 I $P(DATE,".")'>ENDDT D
|
|---|
| 30 | . S TQS=$P($G(^IBCN(365.1,TQIEN,0)),U,4) ; status
|
|---|
| 31 | . I '$F(STATLIST,","_TQS_",") Q
|
|---|
| 32 | . S PURTQ=PURTQ+1
|
|---|
| 33 | . ; Loop thru responses to count them, too
|
|---|
| 34 | . S HLIEN=0
|
|---|
| 35 | . F S HLIEN=$O(^IBCN(365.1,TQIEN,2,HLIEN)) Q:'HLIEN D
|
|---|
| 36 | . . I $P($G(^IBCN(365.1,TQIEN,2,HLIEN,0)),U,3) S PURRP=PURRP+1
|
|---|
| 37 | ;
|
|---|
| 38 | S DATE=""
|
|---|
| 39 | F S DATE=$O(^IBCN(365,"AE",DATE)) Q:'DATE S RPIEN=0 F S RPIEN=$O(^IBCN(365,"AE",DATE,RPIEN)) Q:'RPIEN S TOTRP=TOTRP+1 I $P(DATE,".")'>ENDDT D
|
|---|
| 40 | . I $P($G(^IBCN(365,RPIEN,0)),U,5) Q ; include only unsolicited
|
|---|
| 41 | . S PURRP=PURRP+1
|
|---|
| 42 | ;
|
|---|
| 43 | ; Do not send message if no records are eligible
|
|---|
| 44 | I 'PURTQ,'PURRP G MMPURGX
|
|---|
| 45 | ;
|
|---|
| 46 | ; Send a MailMan message with Eligible Purge counts
|
|---|
| 47 | S MSG(1)="ATTENTION IRM: There are IIV TRANSMISSION QUEUE and"
|
|---|
| 48 | S MSG(2)="IIV RESPONSE records eligible to be purged."
|
|---|
| 49 | S MSG(3)=""
|
|---|
| 50 | S MSG(4)="File Eligible Total "
|
|---|
| 51 | S MSG(5)=" Count Count "
|
|---|
| 52 | S MSG(6)="------------------------------------ -------- --------"
|
|---|
| 53 | S MSG(7)="IIV RESPONSE FILE (#365) "_$J(PURRP,8)_" "_$J(TOTRP,8)
|
|---|
| 54 | S MSG(8)="IIV TRANSMISSION QUEUE FILE (#365.1) "_$J(PURTQ,8)_" "_$J(TOTTQ,8)
|
|---|
| 55 | S MSG(9)="==================================== ======== ========"
|
|---|
| 56 | S MSG(10)="Total "_$J(PURTQ+PURRP,8)_" "_$J(TOTTQ+TOTRP,8)
|
|---|
| 57 | S MSG(11)=""
|
|---|
| 58 | S MSG(12)="Please run option IBCNE PURGE IIV DATA - Purge IIV Transactions,"
|
|---|
| 59 | S MSG(13)="if you would like to purge the eligible records."
|
|---|
| 60 | ; Set to IB site parameter MAILGROUP
|
|---|
| 61 | S MGRP=$$MGRP^IBCNEUT5()
|
|---|
| 62 | D MSG^IBCNEUT5(MGRP,"IIV Data Eligible for Purge","MSG(")
|
|---|
| 63 | ;
|
|---|
| 64 | MMPURGX ;
|
|---|
| 65 | Q
|
|---|
| 66 | ;
|
|---|
