- 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
- 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
