source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEKI2.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1IBCNEKI2 ;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 ; ---------------------------------------------------
9MMPURGE ; 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 ;
64MMPURGX ;
65 Q
66 ;
Note: See TracBrowser for help on using the repository browser.