- IBARXEX ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION ; 16-NOV-92
- ;;2.0; INTEGRATED BILLING ;**199**; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- % I '$D(DT) D DT^DICRW
- D HOME^%ZIS
- PAT W @IOF,"Medication Copayment Exemption Update Option",!!
- S DIC("W")="N IBX S IBX=$G(^IBA(354,+Y,0)) W ?32,"" "",$P($G(^DPT(+IBX,0)),U,9),?46,"" "",$$TEXT^IBARXEU0($P(IBX,U,4)),?59,"" "",$P($G(^IBE(354.2,+$P(IBX,U,5),0)),U)"
- N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
- S DIC="^DPT(",DIC("S")="I $D(^IBA(354,+Y,0))",DIC(0)="AEQM",DIC("A")="Select BILLING PATIENT: " D ^DIC G:+Y<1 END S DFN=+Y K DIC I $P(Y,"^",3) S IBNEW=""
- ;
- EN ; -- entry point from alert processing , dfn defined
- S IBQUIT=0,IBTALK=1,IBJOB=13
- D DISP
- D STAT
- I $D(IBNEW)!(IBSTATR'=$P(IBPBN,"^",5))!($P(IBSTAT,"^",4)'=$P(IBPBN,"^",4)) D AUTO^IBARXEX1 G PATQ ;ask if autoupdate
- I $P(IBSTAT,"^",4)=$P(IBPBN,"^",4) D MANUAL^IBARXEX1 ; ask if want to change
- PATQ I 'IBQUIT D:$D(IBCHANGE) DISP,STAT,PAUSE^IBOUTL
- ;
- D END
- G PAT
- ;
- DISP ; -- single screen display of Pharmacy co-pay income exemption status
- S IBP=$$PT^IBEFUNC(DFN),IBPBN=$G(^IBA(354,DFN,0))
- D HDR
- S IBCNT=0
- ;
- S IBDT=-(DT+.000001)
- F S IBDT=$O(^IBA(354.1,"AIVDT",1,DFN,IBDT)) Q:'IBDT S IBDA=0 F S IBDA=$O(^IBA(354.1,"AIVDT",1,DFN,IBDT,IBDA)) Q:'IBDA D SHOWONE S IBCNT=IBCNT+1
- I 'IBCNT W !,"None"
- Q
- ;
- SHOWONE ; -- write display line for one entry
- S X=$G(^IBA(354.1,IBDA,0)) Q:X=""
- W !,$$DAT1^IBOUTL(+X),?12,$S($P(X,"^",3)=1:"RX COPAY",1:"")
- W ?22,$$TEXT^IBARXEU0($P(X,"^",4))
- W ?34,$E($P($G(^IBE(354.2,+$P(X,"^",5),0)),"^"),1,22)
- W ?56,$S($P(X,"^",6)=1:"SYSTEM",$G(^VA(200,+$P(X,"^",7),0))]"":$E($P(^(0),U),1,14),1:"Unknown"),"/ ",$$DAT1^IBOUTL($P(X,"^",8))
- Q
- ;
- STAT ; -- show current status
- S IBSTATR=+$$STATUS^IBARXEU1(DFN,DT)
- S IBSTAT=$G(^IBE(354.2,+IBSTATR,0))
- ;
- W !!,"Medication Copayment Exemption Status Currently computes to: ",$$TEXT^IBARXEU0($P(IBSTAT,"^",4))
- W !,$P(IBSTAT,"^",2),!!
- Q
- ;
- SELCY ; -- select calendar year to work with
- ;
- W !!
- S Y=+$$LST^IBARXEU0(DFN) I Y?7N D D^DIQ S DIR("B")=Y
- S DIR("?")="Enter the effective date you wish to add a new exemption record for. If the exemption is computed from income data then the effective date will be the date of the income test. It cannot be in the future."
- S DIR(0)="DO^"_$$STDATE^IBARXEU_":"_DT,DIR("A")="Select Effective Date" D ^DIR K DIR
- I $D(DIRUT)!(Y'?7N) S IBQUIT=1 G SELCYQ
- S IBDT=Y
- I '$D(^IBA(354.1,"APIDT",DFN,1,-IBDT))&(IBDT'=DT) K IBDT W !!?4,$C(7),"The DATE selected must be the date of an exemption or today!",!?4,"This is the same date as the date of a Means Test or Copay Test.",! G SELCY
- SELCYQ Q
- ;
- ;
- HDR W @IOF,"Medication Copayment Income Exemption Status"
- W !,$E($P(IBP,"^"),1,20)," ",$P(IBP,"^",3),?27," Currently: ",$$TEXT^IBARXEU0($P(IBPBN,"^",4))_"-"_$P($G(^IBE(354.2,+$P(IBPBN,"^",5),0)),"^"),?65," ",$$DAT1^IBOUTL($P(IBPBN,"^",3))
- W !!,"EFFECTIVE TYPE STATUS REASON ADDED BY/ON"
- W !,$TR($J(" ",IOM)," ","-")
- Q
- ;
- END K C,I,J,DA,DIC,DIE,DR,DFN,IBACTIVE,IBADDE,IBALERT,IBCHANGE,IBCNT,IBCODA,IBCODP,IBEXDA,IBDA,IBDT,IBEXREA,IBJ,IBJOB,IBNEW,IBP,IBPBN,DIRUT,IBQUIT,IBSTAT,IBSTATR,IBTALK,IBWHER,X,X1,XCNP,XMZ,Y
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEX 3332 printed Jan 18, 2025@03:08:42 Page 2
- IBARXEX ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION ; 16-NOV-92
- +1 ;;2.0; INTEGRATED BILLING ;**199**; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- % IF '$DATA(DT)
- DO DT^DICRW
- +1 DO HOME^%ZIS
- PAT WRITE @IOF,"Medication Copayment Exemption Update Option",!!
- +1 SET DIC("W")="N IBX S IBX=$G(^IBA(354,+Y,0)) W ?32,"" "",$P($G(^DPT(+IBX,0)),U,9),?46,"" "",$$TEXT^IBARXEU0($P(IBX,U,4)),?59,"" "",$P($G(^IBE(354.2,+$P(IBX,U,5),0)),U)"
- +2 ;Suppress PATIENT file fuzzy lookups
- NEW DPTNOFZY
- SET DPTNOFZY=1
- +3 SET DIC="^DPT("
- SET DIC("S")="I $D(^IBA(354,+Y,0))"
- SET DIC(0)="AEQM"
- SET DIC("A")="Select BILLING PATIENT: "
- DO ^DIC
- if +Y<1
- GOTO END
- SET DFN=+Y
- KILL DIC
- IF $PIECE(Y,"^",3)
- SET IBNEW=""
- +4 ;
- EN ; -- entry point from alert processing , dfn defined
- +1 SET IBQUIT=0
- SET IBTALK=1
- SET IBJOB=13
- +2 DO DISP
- +3 DO STAT
- +4 ;ask if autoupdate
- IF $DATA(IBNEW)!(IBSTATR'=$PIECE(IBPBN,"^",5))!($PIECE(IBSTAT,"^",4)'=$PIECE(IBPBN,"^",4))
- DO AUTO^IBARXEX1
- GOTO PATQ
- +5 ; ask if want to change
- IF $PIECE(IBSTAT,"^",4)=$PIECE(IBPBN,"^",4)
- DO MANUAL^IBARXEX1
- PATQ IF 'IBQUIT
- if $DATA(IBCHANGE)
- DO DISP
- DO STAT
- DO PAUSE^IBOUTL
- +1 ;
- +2 DO END
- +3 GOTO PAT
- +4 ;
- DISP ; -- single screen display of Pharmacy co-pay income exemption status
- +1 SET IBP=$$PT^IBEFUNC(DFN)
- SET IBPBN=$GET(^IBA(354,DFN,0))
- +2 DO HDR
- +3 SET IBCNT=0
- +4 ;
- +5 SET IBDT=-(DT+.000001)
- +6 FOR
- SET IBDT=$ORDER(^IBA(354.1,"AIVDT",1,DFN,IBDT))
- if 'IBDT
- QUIT
- SET IBDA=0
- FOR
- SET IBDA=$ORDER(^IBA(354.1,"AIVDT",1,DFN,IBDT,IBDA))
- if 'IBDA
- QUIT
- DO SHOWONE
- SET IBCNT=IBCNT+1
- +7 IF 'IBCNT
- WRITE !,"None"
- +8 QUIT
- +9 ;
- SHOWONE ; -- write display line for one entry
- +1 SET X=$GET(^IBA(354.1,IBDA,0))
- if X=""
- QUIT
- +2 WRITE !,$$DAT1^IBOUTL(+X),?12,$SELECT($PIECE(X,"^",3)=1:"RX COPAY",1:"")
- +3 WRITE ?22,$$TEXT^IBARXEU0($PIECE(X,"^",4))
- +4 WRITE ?34,$EXTRACT($PIECE($GET(^IBE(354.2,+$PIECE(X,"^",5),0)),"^"),1,22)
- +5 WRITE ?56,$SELECT($PIECE(X,"^",6)=1:"SYSTEM",$GET(^VA(200,+$PIECE(X,"^",7),0))]"":$EXTRACT($PIECE(^(0),U),1,14),1:"Unknown"),"/ ",$$DAT1^IBOUTL($PIECE(X,"^",8))
- +6 QUIT
- +7 ;
- STAT ; -- show current status
- +1 SET IBSTATR=+$$STATUS^IBARXEU1(DFN,DT)
- +2 SET IBSTAT=$GET(^IBE(354.2,+IBSTATR,0))
- +3 ;
- +4 WRITE !!,"Medication Copayment Exemption Status Currently computes to: ",$$TEXT^IBARXEU0($PIECE(IBSTAT,"^",4))
- +5 WRITE !,$PIECE(IBSTAT,"^",2),!!
- +6 QUIT
- +7 ;
- SELCY ; -- select calendar year to work with
- +1 ;
- +2 WRITE !!
- +3 SET Y=+$$LST^IBARXEU0(DFN)
- IF Y?7N
- DO D^DIQ
- SET DIR("B")=Y
- +4 SET DIR("?")="Enter the effective date you wish to add a new exemption record for. If the exemption is computed from income data then the effective date will be the date of the income test. It cannot be in the future."
- +5 SET DIR(0)="DO^"_$$STDATE^IBARXEU_":"_DT
- SET DIR("A")="Select Effective Date"
- DO ^DIR
- KILL DIR
- +6 IF $DATA(DIRUT)!(Y'?7N)
- SET IBQUIT=1
- GOTO SELCYQ
- +7 SET IBDT=Y
- +8 IF '$DATA(^IBA(354.1,"APIDT",DFN,1,-IBDT))&(IBDT'=DT)
- KILL IBDT
- WRITE !!?4,$CHAR(7),"The DATE selected must be the date of an exemption or today!",!?4,"This is the same date as the date of a Means Test or Copay Test.",!
- GOTO SELCY
- SELCYQ QUIT
- +1 ;
- +2 ;
- HDR WRITE @IOF,"Medication Copayment Income Exemption Status"
- +1 WRITE !,$EXTRACT($PIECE(IBP,"^"),1,20)," ",$PIECE(IBP,"^",3),?27," Currently: ",$$TEXT^IBARXEU0($PIECE(IBPBN,"^",4))_"-"_$PIECE($GET(^IBE(354.2,+$PIECE(IBPBN,"^",5),0)),"^"),?65," ",$$DAT1^IBOUTL($PIECE(IBPBN,"^",3))
- +2 WRITE !!,"EFFECTIVE TYPE STATUS REASON ADDED BY/ON"
- +3 WRITE !,$TRANSLATE($JUSTIFY(" ",IOM)," ","-")
- +4 QUIT
- +5 ;
- END KILL C,I,J,DA,DIC,DIE,DR,DFN,IBACTIVE,IBADDE,IBALERT,IBCHANGE,IBCNT,IBCODA,IBCODP,IBEXDA,IBDA,IBDT,IBEXREA,IBJ,IBJOB,IBNEW,IBP,IBPBN,DIRUT,IBQUIT,IBSTAT,IBSTATR,IBTALK,IBWHER,X,X1,XCNP,XMZ,Y
- +1 QUIT