- IBARXEX1 ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION, CONT. ; 16-NOV-92
- ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;
- AUTO ; -- auto update of exemption reason file and billing pat file.
- ; -- if computes to pending but status is adjudicated quit
- N IBOLDAUT,IBFORCE
- I $$NETW^IBARXEU1,$P(IBSTAT,"^",5)=130 S X=$$LST^IBARXEU0(DFN,DT),Y=$P($G(^IBE(354.2,$P(X,"^",5),0)),"^",5) I Y=140!(Y=150) Q
- ;
- ; -- ask if sure
- S DIR(0)="Y",DIR("A")="Update Patient Billing Status",DIR("B")="NO" D ^DIR K DIR I $D(DIRUT)!(Y<1) S IBQUIT=1 G AUTOQ
- D SELCY^IBARXEX G:IBQUIT AUTOQ
- ;
- L +^IBA(354,DFN):5 I '$T W !,"Another User accessing Record, Try Again Later." G AUTOQ
- S IBCHANGE=1
- ;
- S (IBEVT,X)=$$STATUS^IBARXEU1(DFN,IBDT)
- ;
- ; -- not currently autoexempt, see if most recent is auto
- S IBOLDAUT=""
- I $L($P(^IBE(354.2,+IBEVT,0),"^",5))>2 D OLDAUT(IBEVT)
- ;
- ; -- first inactivate all entries for day
- S IBFORCE=$P(X,"^",2)
- ;
- ; -- for income, inactivate most recent
- D MOSTR^IBARXEU5($P(X,"^",2),+X)
- D ADDEX^IBAUTL6(+X,$P(X,"^",2),1,1,$G(IBOLDAUT))
- L -^IBA(354,DFN)
- ;W !!,"Entry Updated!"
- AUTOQ K IBFORCE D PAUSE^IBOUTL
- Q
- ;
- OLDAUT(X1) ; -- not currently autoexempt, most current is auto exempt delete
- ; inactivate autoexempt
- N X
- S X=$$LSTAC^IBARXEU0(DFN) I $L(+X)'=3,$P(X,"^",2)'<$P(X1,"^",2) S IBOLDAUT=$P(X,"^",2)
- Q
- ;
- MANUAL ; -- allow user to do manual change
- S DIR(0)="Y",DIR("A")="Do you wish to manually assign a Hardship Copay Exemption",DIR("B")="NO" D ^DIR K DIR I $D(DIRUT)!(Y<1) S IBQUIT=1 G MANUALQ
- ;
- D SELCY^IBARXEX G:IBQUIT MANUALQ
- S IBEXREA=$O(^IBE(354.2,"ACODE",2010,0)) ;only hardships
- S IBCODA=2010
- ;
- ; -- if current exemption is exempt can't give hardship
- S X=$$LST^IBARXEU0(DFN,IBDT)
- I +X'<(DT-100000),$P(X,"^",4) K IBEXREA W !!,"You can only give a hardship to a Non-Exempt patient",!,*7 G MANUALQ
- ;
- L +^IBA(354,DFN):5 I '$T W !,"Another User accessing record, Try Again Later." G MANUALQ
- S IBCHANGE=1
- S DIR(0)="Y",DIR("A")="Are You Sure" D ^DIR K DIR G:$D(DIRUT)!(Y<1) MANUALQ
- ;
- ; -- get electronic signature code
- D SIG^XUSESIG
- I X1=""!(X'=X1) W !,"Not your electronic signature" G MANUALQ
- S IBASIG=X1
- ;
- ; -- add new exemption
- D ADDEX^IBAUTL6(IBEXREA,IBDT,2,1)
- ;
- MANUALQ L -^IBA(354,DFN)
- D PAUSE^IBOUTL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEX1 2433 printed Feb 18, 2025@23:33:54 Page 2
- IBARXEX1 ;ALB/AAS - RX COPAY INCOME EXEMPTION ROUTINE - MANUAL UPDATE OPTION, CONT. ; 16-NOV-92
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;**34**; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;
- AUTO ; -- auto update of exemption reason file and billing pat file.
- +1 ; -- if computes to pending but status is adjudicated quit
- +2 NEW IBOLDAUT,IBFORCE
- +3 IF $$NETW^IBARXEU1
- IF $PIECE(IBSTAT,"^",5)=130
- SET X=$$LST^IBARXEU0(DFN,DT)
- SET Y=$PIECE($GET(^IBE(354.2,$PIECE(X,"^",5),0)),"^",5)
- IF Y=140!(Y=150)
- QUIT
- +4 ;
- +5 ; -- ask if sure
- +6 SET DIR(0)="Y"
- SET DIR("A")="Update Patient Billing Status"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)!(Y<1)
- SET IBQUIT=1
- GOTO AUTOQ
- +7 DO SELCY^IBARXEX
- if IBQUIT
- GOTO AUTOQ
- +8 ;
- +9 LOCK +^IBA(354,DFN):5
- IF '$TEST
- WRITE !,"Another User accessing Record, Try Again Later."
- GOTO AUTOQ
- +10 SET IBCHANGE=1
- +11 ;
- +12 SET (IBEVT,X)=$$STATUS^IBARXEU1(DFN,IBDT)
- +13 ;
- +14 ; -- not currently autoexempt, see if most recent is auto
- +15 SET IBOLDAUT=""
- +16 IF $LENGTH($PIECE(^IBE(354.2,+IBEVT,0),"^",5))>2
- DO OLDAUT(IBEVT)
- +17 ;
- +18 ; -- first inactivate all entries for day
- +19 SET IBFORCE=$PIECE(X,"^",2)
- +20 ;
- +21 ; -- for income, inactivate most recent
- +22 DO MOSTR^IBARXEU5($PIECE(X,"^",2),+X)
- +23 DO ADDEX^IBAUTL6(+X,$PIECE(X,"^",2),1,1,$GET(IBOLDAUT))
- +24 LOCK -^IBA(354,DFN)
- +25 ;W !!,"Entry Updated!"
- AUTOQ KILL IBFORCE
- DO PAUSE^IBOUTL
- +1 QUIT
- +2 ;
- OLDAUT(X1) ; -- not currently autoexempt, most current is auto exempt delete
- +1 ; inactivate autoexempt
- +2 NEW X
- +3 SET X=$$LSTAC^IBARXEU0(DFN)
- IF $LENGTH(+X)'=3
- IF $PIECE(X,"^",2)'<$PIECE(X1,"^",2)
- SET IBOLDAUT=$PIECE(X,"^",2)
- +4 QUIT
- +5 ;
- MANUAL ; -- allow user to do manual change
- +1 SET DIR(0)="Y"
- SET DIR("A")="Do you wish to manually assign a Hardship Copay Exemption"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)!(Y<1)
- SET IBQUIT=1
- GOTO MANUALQ
- +2 ;
- +3 DO SELCY^IBARXEX
- if IBQUIT
- GOTO MANUALQ
- +4 ;only hardships
- SET IBEXREA=$ORDER(^IBE(354.2,"ACODE",2010,0))
- +5 SET IBCODA=2010
- +6 ;
- +7 ; -- if current exemption is exempt can't give hardship
- +8 SET X=$$LST^IBARXEU0(DFN,IBDT)
- +9 IF +X'<(DT-100000)
- IF $PIECE(X,"^",4)
- KILL IBEXREA
- WRITE !!,"You can only give a hardship to a Non-Exempt patient",!,*7
- GOTO MANUALQ
- +10 ;
- +11 LOCK +^IBA(354,DFN):5
- IF '$TEST
- WRITE !,"Another User accessing record, Try Again Later."
- GOTO MANUALQ
- +12 SET IBCHANGE=1
- +13 SET DIR(0)="Y"
- SET DIR("A")="Are You Sure"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)!(Y<1)
- GOTO MANUALQ
- +14 ;
- +15 ; -- get electronic signature code
- +16 DO SIG^XUSESIG
- +17 IF X1=""!(X'=X1)
- WRITE !,"Not your electronic signature"
- GOTO MANUALQ
- +18 SET IBASIG=X1
- +19 ;
- +20 ; -- add new exemption
- +21 DO ADDEX^IBAUTL6(IBEXREA,IBDT,2,1)
- +22 ;
- MANUALQ LOCK -^IBA(354,DFN)
- +1 DO PAUSE^IBOUTL
- +2 QUIT
