IBPEX ;ALB/AAS - PURGE MEDICATION CO-PAY EXEMPTIONS ; 12-NOV-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% I '$D(DT) D DT^DICRW
I '$D(IOF) D HOME^%ZIS
;
W @IOF,?15,"Purge Medication Copayment Exemptions",!!
;
S DIR("?")="Enter the date through which you want to purge entries for the BILLING EXEMPTIONS file (354.1)"
S DIR("?",1)="This must be a date at least one year in the past."
S DIR("?",2)="This option will purge inactive exemptions whose exemption date is earlier"
S DIR("?",3)="than this date and active exemptions older than one year before this date."
S DIR(0)="D^2920101:"_(DT-10000)_":EX",DIR("A")="Purge Date"
S Y=DT-10000 D D^DIQ S DIR("B")=Y
D ^DIR K DIR
I $D(DIRUT)!(Y'?7N) G END
S IBPDT=Y
;
W !!,"There is no output from this routine it just purges.",!
S DIR(0)="Y",DIR("A")="Are you sure you want to purge now",DIR("B")="NO" D ^DIR K DIR
I $D(DIRUT)!(Y'=1) G END
;
DEV S %ZIS="QM" D ^%ZIS G:POP END
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
U IO
;
DQ ; -- entry point for later
; if exemption not active, not current, earlier than ibpdt
; or
; if active, not current, earlier that ibpdt-10000
; then purge
;
S (IBDT,IBPURG,IBPCNT,IBPAG)=0
D NOW^%DTC S Y=% D D^DIQ S IBPDAT=Y
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
D HDR,REPORT
G END
;
END Q:$D(ZTQUEUED)
D ^%ZISC
;K IBPDT,IBPURG,DIR
Q
;
CHK ; -- check entries
W:'$D(ZTQUEUED) "."
S IBPURG=0
S X=$G(^IBA(354.1,IBDA,0)) G CHKQ:X=""
S X1=$G(^IBA(354,$P(X,"^",2),0))
;
; -- quit if contains ar pass dates
I $P(X,"^",14) G CHKQ
;
; -- quit if is current exemption
I +X=$P(X1,"^",3) G CHKQ
;
; -- if active, older than purge date - 1 year
I $P(X,"^",10),+X<(IBPDT-10000) S IBPURG=1
;
; -- if inactive, older than purge date
I '$P(X,"^",10),+X<IBPDT S IBPURG=1
;
CHKQ Q
;
PURGE ; -- blow away the entry
S DA=IBDA,DIK="^IBA(354.1," D ^DIK
K DA,DIK
S IBPCNT=IBPCNT+1
Q
;
HDR ; -- simple header for 1 line report
I $E(IOST,1,2)="C-"!(IBPAG) W @IOF
S IBPAG=IBPAG+1
W "BILLING EXEMPTION PURGE REPORT",?IOM-30,IBPDAT," PAGE ",IBPAG
W !,$TR($J(" ",IOM)," ","-")
Q
;
REPORT ; -- simple report
I 'IBPCNT W !,"No exemption found that met purge criteria" G REPORTQ
W !,"There were ",IBPCNT," entries purged from the billing exemption file"
REPORTQ ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBPEX 2638 printed Dec 13, 2024@02:26:30 Page 2
IBPEX ;ALB/AAS - PURGE MEDICATION CO-PAY EXEMPTIONS ; 12-NOV-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% IF '$DATA(DT)
DO DT^DICRW
+1 IF '$DATA(IOF)
DO HOME^%ZIS
+2 ;
+3 WRITE @IOF,?15,"Purge Medication Copayment Exemptions",!!
+4 ;
+5 SET DIR("?")="Enter the date through which you want to purge entries for the BILLING EXEMPTIONS file (354.1)"
+6 SET DIR("?",1)="This must be a date at least one year in the past."
+7 SET DIR("?",2)="This option will purge inactive exemptions whose exemption date is earlier"
+8 SET DIR("?",3)="than this date and active exemptions older than one year before this date."
+9 SET DIR(0)="D^2920101:"_(DT-10000)_":EX"
SET DIR("A")="Purge Date"
+10 SET Y=DT-10000
DO D^DIQ
SET DIR("B")=Y
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)!(Y'?7N)
GOTO END
+13 SET IBPDT=Y
+14 ;
+15 WRITE !!,"There is no output from this routine it just purges.",!
+16 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to purge now"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+17 IF $DATA(DIRUT)!(Y'=1)
GOTO END
+18 ;
DEV SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO END
+1 IF $DATA(IO("Q"))
SET ZTRTN="DQ^IBPEX"
SET ZTSAVE("IB*")=""
SET ZTDESC="IB Purge exemption entries"
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO HOME^%ZIS
GOTO END
+2 USE IO
+3 ;
DQ ; -- entry point for later
+1 ; if exemption not active, not current, earlier than ibpdt
+2 ; or
+3 ; if active, not current, earlier that ibpdt-10000
+4 ; then purge
+5 ;
+6 SET (IBDT,IBPURG,IBPCNT,IBPAG)=0
+7 DO NOW^%DTC
SET Y=%
DO D^DIQ
SET IBPDAT=Y
+8 FOR
SET IBDT=$ORDER(^IBA(354.1,"B",IBDT))
if 'IBDT!(IBDT>IBPDT)
QUIT
SET IBDA=0
FOR
SET IBDA=$ORDER(^IBA(354.1,"B",IBDT,IBDA))
if 'IBDA
QUIT
DO CHK
if IBPURG
DO PURGE
+9 DO HDR
DO REPORT
+10 GOTO END
+11 ;
END if $DATA(ZTQUEUED)
QUIT
+1 DO ^%ZISC
+2 ;K IBPDT,IBPURG,DIR
+3 QUIT
+4 ;
CHK ; -- check entries
+1 if '$DATA(ZTQUEUED)
WRITE "."
+2 SET IBPURG=0
+3 SET X=$GET(^IBA(354.1,IBDA,0))
if X=""
GOTO CHKQ
+4 SET X1=$GET(^IBA(354,$PIECE(X,"^",2),0))
+5 ;
+6 ; -- quit if contains ar pass dates
+7 IF $PIECE(X,"^",14)
GOTO CHKQ
+8 ;
+9 ; -- quit if is current exemption
+10 IF +X=$PIECE(X1,"^",3)
GOTO CHKQ
+11 ;
+12 ; -- if active, older than purge date - 1 year
+13 IF $PIECE(X,"^",10)
IF +X<(IBPDT-10000)
SET IBPURG=1
+14 ;
+15 ; -- if inactive, older than purge date
+16 IF '$PIECE(X,"^",10)
IF +X<IBPDT
SET IBPURG=1
+17 ;
CHKQ QUIT
+1 ;
PURGE ; -- blow away the entry
+1 SET DA=IBDA
SET DIK="^IBA(354.1,"
DO ^DIK
+2 KILL DA,DIK
+3 SET IBPCNT=IBPCNT+1
+4 QUIT
+5 ;
HDR ; -- simple header for 1 line report
+1 IF $EXTRACT(IOST,1,2)="C-"!(IBPAG)
WRITE @IOF
+2 SET IBPAG=IBPAG+1
+3 WRITE "BILLING EXEMPTION PURGE REPORT",?IOM-30,IBPDAT," PAGE ",IBPAG
+4 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
+5 QUIT
+6 ;
REPORT ; -- simple report
+1 IF 'IBPCNT
WRITE !,"No exemption found that met purge criteria"
GOTO REPORTQ
+2 WRITE !,"There were ",IBPCNT," entries purged from the billing exemption file"
REPORTQ ;
+1 QUIT
