source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBPEX.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.5 KB
Line 
1IBPEX ;ALB/AAS - PURGE MEDICATION CO-PAY EXEMPTIONS ; 12-NOV-92
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5% I '$D(DT) D DT^DICRW
6 I '$D(IOF) D HOME^%ZIS
7 ;
8 W @IOF,?15,"Purge Medication Copayment Exemptions",!!
9 ;
10 S DIR("?")="Enter the date through which you want to purge entries for the BILLING EXEMPTIONS file (354.1)"
11 S DIR("?",1)="This must be a date at least one year in the past."
12 S DIR("?",2)="This option will purge inactive exemptions whose exemption date is earlier"
13 S DIR("?",3)="than this date and active exemptions older than one year before this date."
14 S DIR(0)="D^2920101:"_(DT-10000)_":EX",DIR("A")="Purge Date"
15 S Y=DT-10000 D D^DIQ S DIR("B")=Y
16 D ^DIR K DIR
17 I $D(DIRUT)!(Y'?7N) G END
18 S IBPDT=Y
19 ;
20 W !!,"There is no output from this routine it just purges.",!
21 S DIR(0)="Y",DIR("A")="Are you sure you want to purge now",DIR("B")="NO" D ^DIR K DIR
22 I $D(DIRUT)!(Y'=1) G END
23 ;
24DEV S %ZIS="QM" D ^%ZIS G:POP END
25 I $D(IO("Q")) S ZTRTN="DQ^IBPEX",ZTSAVE("IB*")="",ZTDESC="IB Purge exemption entries" D ^%ZTLOAD K IO("Q"),ZTSK D HOME^%ZIS G END
26 U IO
27 ;
28DQ ; -- entry point for later
29 ; if exemption not active, not current, earlier than ibpdt
30 ; or
31 ; if active, not current, earlier that ibpdt-10000
32 ; then purge
33 ;
34 S (IBDT,IBPURG,IBPCNT,IBPAG)=0
35 D NOW^%DTC S Y=% D D^DIQ S IBPDAT=Y
36 F S IBDT=$O(^IBA(354.1,"B",IBDT)) Q:'IBDT!(IBDT>IBPDT) S IBDA=0 F S IBDA=$O(^IBA(354.1,"B",IBDT,IBDA)) Q:'IBDA D CHK,PURGE:IBPURG
37 D HDR,REPORT
38 G END
39 ;
40END Q:$D(ZTQUEUED)
41 D ^%ZISC
42 ;K IBPDT,IBPURG,DIR
43 Q
44 ;
45CHK ; -- check entries
46 W:'$D(ZTQUEUED) "."
47 S IBPURG=0
48 S X=$G(^IBA(354.1,IBDA,0)) G CHKQ:X=""
49 S X1=$G(^IBA(354,$P(X,"^",2),0))
50 ;
51 ; -- quit if contains ar pass dates
52 I $P(X,"^",14) G CHKQ
53 ;
54 ; -- quit if is current exemption
55 I +X=$P(X1,"^",3) G CHKQ
56 ;
57 ; -- if active, older than purge date - 1 year
58 I $P(X,"^",10),+X<(IBPDT-10000) S IBPURG=1
59 ;
60 ; -- if inactive, older than purge date
61 I '$P(X,"^",10),+X<IBPDT S IBPURG=1
62 ;
63CHKQ Q
64 ;
65PURGE ; -- blow away the entry
66 S DA=IBDA,DIK="^IBA(354.1," D ^DIK
67 K DA,DIK
68 S IBPCNT=IBPCNT+1
69 Q
70 ;
71HDR ; -- simple header for 1 line report
72 I $E(IOST,1,2)="C-"!(IBPAG) W @IOF
73 S IBPAG=IBPAG+1
74 W "BILLING EXEMPTION PURGE REPORT",?IOM-30,IBPDAT," PAGE ",IBPAG
75 W !,$TR($J(" ",IOM)," ","-")
76 Q
77 ;
78REPORT ; -- simple report
79 I 'IBPCNT W !,"No exemption found that met purge criteria" G REPORTQ
80 W !,"There were ",IBPCNT," entries purged from the billing exemption file"
81REPORTQ ;
82 Q
Note: See TracBrowser for help on using the repository browser.