IBARXEP ;ALB/AAS - RX COPAY EXEMPTION PRINT BILLING PATIENTS ; 20-JAN-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% ; -- print list of patient by status
K IBCNTE,BY
I '$D(IOF) D HOME^%ZIS
W @IOF,?20,"Print Patient Medication Copayment Exemptions",!!!
;
S DIR("?")="Answer YES if you only want to print a statistical summary or answer NO if you want a list of patients plus the statistical summary."
S DIR(0)="Y",DIR("A")="Print Summary Only",DIR("B")="YES" D ^DIR K DIR
I $D(DIRUT) G END
S IBSUM=Y
I 'IBSUM W !!,"You will need a 132 column printer for this report!",!
W !! D BY G END:$G(BY)=""
S DIC="^IBA(354,",L=0,FR="?,?,?",TO="?,?,?"
S FLDS=$S(IBSUM:"[IB BILLING PATIENT SUMMARY]",1:"[IB BILLING PATIENT]")
S DHD="Patient Medication Copayment Exemption "_$S(IBSUM:"Statistics",1:"Report")
S DIOEND="D SUMMARY^IBARXEP"
;
; -- exclude deceased patients
I 'IBSUM S DIS(0)="I '+$G(^DPT(+D0,.35))"
;
D EN1^DIP
END K DIC,L,FLDS,DIOEND,FR,TO,BY,DHD,X,Y,IBCNTE,IBCNT,IBSUM,DUOUT,DIRUT
Q
;
;
CNT ; -- set counts into ^tmp for summary report
N X,Y S X=$G(^IBA(354,D0,0)) Q:X=""
S Y=$P($G(^IBE(354.2,+$P(X,"^",5),0)),"^") Q:Y=""
S X=$P(X,"^",4) Q:X=""
S:'$D(IBCNTE(X,Y)) IBCNTE(X,Y)=0 S IBCNTE(X,Y)=IBCNTE(X,Y)+1
Q
;
BY ; -- sort by exemption reason or by exemption status
S DIR(0)="SMA^.04:EXEMPTION STATUS;.05:EXEMPTION REASON",DIR("A")="SORT BY: ",DIR("B")="EXEMPTION STATUS"
S DIR("?")="Sort by either Exemption Status (.04) or Exemption Reason (.05)"
D ^DIR K DIR I $D(DIRUT) Q
S BY=$S(Y=.05:"[IB BILLING PATIENT BY REASON]",Y=.04:"[IB BILLING PATIENT BY STATUS]",1:"")
Q
;
SUMMARY ; -- print summary page
N X,Y
W:'IBSUM !!,"===================================================="
S (X,Y)="",IBCNT(0)=0,IBCNT(1)=0
F S X=$O(IBCNTE(X)) Q:X="" S IBCNT=0 F S Y=$O(IBCNTE(X,Y)) Q:Y="" D
.;sub counts
.S IBCNT(X)=IBCNT(X)+IBCNTE(X,Y)
.S IBCNT=IBCNT+1
.;print line
.W:IBCNT=1 !,$S(X:"Exempt",1:"Non-Exempt")," Status:"
.W !?5,Y,?40,"= ",IBCNTE(X,Y)
W !
W:$D(IBCNTE(1)) !,"Total Exempt Patients",?40,"= ",IBCNT(1)
W:$D(IBCNTE(0)) !,"Total Non-Exempt Patients",?40,"= ",IBCNT(0)
;
I IBSUM W !!!,"Statistics DO include counts from deceased patients."
I 'IBSUM W !!!,"Statistics and report DO NOT include deceased patients."
Q
;
NOINC ; -- print list of patient with no income data with address
;
K IBCNTE,BY
I '$D(IOF) D HOME^%ZIS
W @IOF,?10,"Print Patients with NO INCOME DATA Medication Copayment Exemptions",!!!
;
S IBSUM=0
S DIC="^IBA(354,",L=0,FR="?,?,?",TO="?,?,?"
S BY="[IB BILLING PAT W/INCOME]"
S FLDS="[IB BILLING PAT W/INCOME]"
S DHD="Patient with a NO INCOME DATA Medication Copayment Exemption Report"
;S DIOEND="D SUMMARY^IBARXEP"
;
; -- exclude deceased patients
S DIS(0)="I '+$G(^DPT(+D0,.35))"
;
D EN1^DIP
NOINCQ K DIC,L,FLDS,DIOEND,FR,TO,BY,DHD,X,Y,IBCNTE,IBCNT,IBSUM,DUOUT,DIRUT
Q
;
EXADD ; -- print list of EXEMPT patients with address
;
K IBCNTE,BY
I '$D(IOF) D HOME^%ZIS
W @IOF,?10,"Print List of Exempt Patients with Addresses",!!!
;
S IBSUM=0
S DIC="^IBA(354,",L=0,FR="?,?,?",TO="?,?,?"
S BY="[IB EXEMPT PATIENTS]"
S FLDS="[IB PATIENT ADDRESSES]"
S DHD="List of Exempt Patients with Addresses"
;
; -- exclude deceased patients
S DIS(0)="I '+$G(^DPT(+D0,.35))"
;
D EN1^DIP
EXADDQ K DIC,L,FLDS,DIOEND,FR,TO,BY,DHD,X,Y,IBCNTE,IBCNT,IBSUM,DUOUT,DIRUT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEP 3528 printed Dec 13, 2024@02:07:16 Page 2
IBARXEP ;ALB/AAS - RX COPAY EXEMPTION PRINT BILLING PATIENTS ; 20-JAN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% ; -- print list of patient by status
+1 KILL IBCNTE,BY
+2 IF '$DATA(IOF)
DO HOME^%ZIS
+3 WRITE @IOF,?20,"Print Patient Medication Copayment Exemptions",!!!
+4 ;
+5 SET DIR("?")="Answer YES if you only want to print a statistical summary or answer NO if you want a list of patients plus the statistical summary."
+6 SET DIR(0)="Y"
SET DIR("A")="Print Summary Only"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
GOTO END
+8 SET IBSUM=Y
+9 IF 'IBSUM
WRITE !!,"You will need a 132 column printer for this report!",!
+10 WRITE !!
DO BY
if $GET(BY)=""
GOTO END
+11 SET DIC="^IBA(354,"
SET L=0
SET FR="?,?,?"
SET TO="?,?,?"
+12 SET FLDS=$SELECT(IBSUM:"[IB BILLING PATIENT SUMMARY]",1:"[IB BILLING PATIENT]")
+13 SET DHD="Patient Medication Copayment Exemption "_$SELECT(IBSUM:"Statistics",1:"Report")
+14 SET DIOEND="D SUMMARY^IBARXEP"
+15 ;
+16 ; -- exclude deceased patients
+17 IF 'IBSUM
SET DIS(0)="I '+$G(^DPT(+D0,.35))"
+18 ;
+19 DO EN1^DIP
END KILL DIC,L,FLDS,DIOEND,FR,TO,BY,DHD,X,Y,IBCNTE,IBCNT,IBSUM,DUOUT,DIRUT
+1 QUIT
+2 ;
+3 ;
CNT ; -- set counts into ^tmp for summary report
+1 NEW X,Y
SET X=$GET(^IBA(354,D0,0))
if X=""
QUIT
+2 SET Y=$PIECE($GET(^IBE(354.2,+$PIECE(X,"^",5),0)),"^")
if Y=""
QUIT
+3 SET X=$PIECE(X,"^",4)
if X=""
QUIT
+4 if '$DATA(IBCNTE(X,Y))
SET IBCNTE(X,Y)=0
SET IBCNTE(X,Y)=IBCNTE(X,Y)+1
+5 QUIT
+6 ;
BY ; -- sort by exemption reason or by exemption status
+1 SET DIR(0)="SMA^.04:EXEMPTION STATUS;.05:EXEMPTION REASON"
SET DIR("A")="SORT BY: "
SET DIR("B")="EXEMPTION STATUS"
+2 SET DIR("?")="Sort by either Exemption Status (.04) or Exemption Reason (.05)"
+3 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+4 SET BY=$SELECT(Y=.05:"[IB BILLING PATIENT BY REASON]",Y=.04:"[IB BILLING PATIENT BY STATUS]",1:"")
+5 QUIT
+6 ;
SUMMARY ; -- print summary page
+1 NEW X,Y
+2 if 'IBSUM
WRITE !!,"===================================================="
+3 SET (X,Y)=""
SET IBCNT(0)=0
SET IBCNT(1)=0
+4 FOR
SET X=$ORDER(IBCNTE(X))
if X=""
QUIT
SET IBCNT=0
FOR
SET Y=$ORDER(IBCNTE(X,Y))
if Y=""
QUIT
Begin DoDot:1
+5 ;sub counts
+6 SET IBCNT(X)=IBCNT(X)+IBCNTE(X,Y)
+7 SET IBCNT=IBCNT+1
+8 ;print line
+9 if IBCNT=1
WRITE !,$SELECT(X:"Exempt",1:"Non-Exempt")," Status:"
+10 WRITE !?5,Y,?40,"= ",IBCNTE(X,Y)
End DoDot:1
+11 WRITE !
+12 if $DATA(IBCNTE(1))
WRITE !,"Total Exempt Patients",?40,"= ",IBCNT(1)
+13 if $DATA(IBCNTE(0))
WRITE !,"Total Non-Exempt Patients",?40,"= ",IBCNT(0)
+14 ;
+15 IF IBSUM
WRITE !!!,"Statistics DO include counts from deceased patients."
+16 IF 'IBSUM
WRITE !!!,"Statistics and report DO NOT include deceased patients."
+17 QUIT
+18 ;
NOINC ; -- print list of patient with no income data with address
+1 ;
+2 KILL IBCNTE,BY
+3 IF '$DATA(IOF)
DO HOME^%ZIS
+4 WRITE @IOF,?10,"Print Patients with NO INCOME DATA Medication Copayment Exemptions",!!!
+5 ;
+6 SET IBSUM=0
+7 SET DIC="^IBA(354,"
SET L=0
SET FR="?,?,?"
SET TO="?,?,?"
+8 SET BY="[IB BILLING PAT W/INCOME]"
+9 SET FLDS="[IB BILLING PAT W/INCOME]"
+10 SET DHD="Patient with a NO INCOME DATA Medication Copayment Exemption Report"
+11 ;S DIOEND="D SUMMARY^IBARXEP"
+12 ;
+13 ; -- exclude deceased patients
+14 SET DIS(0)="I '+$G(^DPT(+D0,.35))"
+15 ;
+16 DO EN1^DIP
NOINCQ KILL DIC,L,FLDS,DIOEND,FR,TO,BY,DHD,X,Y,IBCNTE,IBCNT,IBSUM,DUOUT,DIRUT
+1 QUIT
+2 ;
EXADD ; -- print list of EXEMPT patients with address
+1 ;
+2 KILL IBCNTE,BY
+3 IF '$DATA(IOF)
DO HOME^%ZIS
+4 WRITE @IOF,?10,"Print List of Exempt Patients with Addresses",!!!
+5 ;
+6 SET IBSUM=0
+7 SET DIC="^IBA(354,"
SET L=0
SET FR="?,?,?"
SET TO="?,?,?"
+8 SET BY="[IB EXEMPT PATIENTS]"
+9 SET FLDS="[IB PATIENT ADDRESSES]"
+10 SET DHD="List of Exempt Patients with Addresses"
+11 ;
+12 ; -- exclude deceased patients
+13 SET DIS(0)="I '+$G(^DPT(+D0,.35))"
+14 ;
+15 DO EN1^DIP
EXADDQ KILL DIC,L,FLDS,DIOEND,FR,TO,BY,DHD,X,Y,IBCNTE,IBCNT,IBSUM,DUOUT,DIRUT
+1 QUIT
