- IBAMTED1 ;ALB/AAS - MEANS TEST EVENT DRIVER - EXEMPTION PROCESSING ; 18-DEC-92
- ;;2.0;INTEGRATED BILLING;**15,112,153,385**;21-MAR-94;Build 35
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- EN N IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER,IBEXERR,IBJOB,IBON
- N IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP,IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
- N DA,DR,DIC,DIE,I,J,X,Y,X1
- ;
- S IBON=$$ON^IBARXEU0 I IBON<1 G ENQ
- S IBJOB=12,IBWHER=13
- ;
- ; -- quit if nothing different (except completion date)
- Q:'$D(DGMTA)!('$D(DGMTP))
- I $P(DGMTA,"^",1,5)=$P(DGMTP,"^",1,5),$P(DGMTA,"^",10,20)=$P(DGMTP,"^",10,20) Q
- I DGMTA]"",DGMTP]"",DGMTACT="DEL" Q ; IVM 'delete' transmission
- ;
- ; -- quit if invoked from ib=>mt=>ib
- Q:$D(IBEVT)
- ;
- ; -- quit if before start date
- I +DGMTA G ENQ:+$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
- I +DGMTP G ENQ:+$$PLUS^IBARXEU0(+DGMTP)<$$STDATE^IBARXEU
- ;
- ;
- I '$D(ZTQUEUED),$D(IBTALK) W !,"Determining Medication Co-Payment Exemption"
- ;
- ; -- if no patient add patient
- I '+$G(^IBA(354,DFN,0)) D ADDP^IBAUTL6 I $G(IBEXERR) G ENQ
- ;
- D AUTO I IBAUTO'="" G ENQ
- ;
- ; -- not auto exempt any more see if is more current auto status
- S X=$$LSTAC^IBARXEU0(DFN) I $L(+X)=2,$P(X,"^",2)>+DGMTA S IBOLDAUT=$P(X,"^",2)
- ; -- if mean test is required or no longer required
- ; or copay test is incomplete or no longer applicable
- ; add exemption of no income data
- S X=$P(DGMTA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(DGMTA,"^",14)) D AEX G ENQ
- ;
- I "^ADD^DEL^EDT^ADJ^STA^CAT^COM^UPL^DUP^"[DGMTACT D @DGMTACT
- ;
- ENQ ; -- exit copay exemption creation
- I $G(IBEXERR) D ^IBAERR
- I $D(IBADDE),$D(IBTALK) W !!,"Medication Copayment Exemption Status Updated: ",$P(^IBE(354.2,+IBADDE,0),"^")," ",$$DAT1^IBOUTL($P(IBADDE,"^",2))
- Q
- ;
- ADD ; -- adding a new test
- I DGMTACT="ADD" D AEX
- ;
- ADDQ Q
- ;
- AEX ; -- add exemption logic
- ; DO NOT USER FOR AUTOMATICS
- ;
- S IBEXREA=""
- ;
- ; -- if means test required, no longer required,
- ; or copay test incomplete or no longer applicable
- ; set up no income data exemption if not automatic.
- ;
- S X=$P(DGMTA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(DGMTA,"^",14)) S IBEXREA=$O(^IBE(354.2,"ACODE",$S($P(DGMTA,"^",14):110,1:210),0))
- ;
- ;
- I $$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$$MTCOMP^IBARXEU5($$INCDT^IBARXEU1(DGMTA),DGMTA)
- I '$$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$P($$INCDT^IBARXEU1(DGMTA),"^",3)
- ;
- ; -- make sure more recent exemption than current test date is inactivetd
- D MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
- D ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$G(IBOLDAUT))
- Q
- ;
- UPL ; -- uploading an IVM-verified means test
- DUP ; -- deleting an IVM-verified means test
- EDT ; -- editing an old means test
- ; if data different attempt to add new test
- I DGMTA=DGMTP G EDITQ
- D AEX
- EDITQ Q
- ;
- DEL ; -- means test deleted
- ; find exemption for date and inactivate
- ; update current exemption status
- ;
- N IBFORCE,IBVFAOK
- Q:'$D(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
- S IBFORCE=+DGMTP ; force inactivate entries for deleted date
- ;
- S IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP),IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
- ;
- ; -- look up VFA status
- S IBVFAOK=$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$P(IBEXREA,"^",2)))
- ;
- ; -- cancel prior exemption with a no data exemption if last date older than 1 year, only if it is not VFA OK.
- I $$PLUS^IBARXEU0($P(IBEXREA,"^",2))<DT,'IBVFAOK D ADDEX^IBAUTL6(+$O(^IBE(354.2,"ACODE",210,0)),+DGMTP) G DELQ
- ;
- ; -- add correct exemption and update current status
- D ADDEX^IBAUTL6(+IBEXREA,+$P(IBEXREA,"^",2))
- DELQ Q
- ;
- COM ; -- complete a required means test
- CAT ; -- category change
- STA ; -- status change
- ADJ ; -- means test adjudication
- ;
- S IBAX1=$$CODE(DGMTP),IBAX=$$CODE(DGMTA)
- ;
- I $$NETW^IBARXEU1,IBAX1="P",IBAX'="P" D G ADJQ ;treat as an adjudication
- .I $P(DGMTA,"^",19)=1 S IBEXREA=$S(IBAX="C":140,IBAX="A":150,1:"") ; means test codes
- .I $P(DGMTA,"^",19)=2 S IBEXREA=$S(IBAX="N":140,IBAX="E":150,1:"") ; copay exemption test
- .S IBEXREA=$O(^IBE(354.2,"ACODE",+IBEXREA,0))
- .Q:'$G(IBEXREA)
- .D ADDEX^IBAUTL6(IBEXREA,+DGMTA,1,1)
- .Q
- ;
- ;I $P(DGMTA,"^",19)=1,IBAX1="C",IBAX="A" D ADDEX^IBAUTL6($O(^IBE(354.2,"ACODE",2010,0)),+DGMTA) G ADJQ ;is a means test hardship
- ;
- I $P(DGMTA,"^",19)=2,IBAX1="N",IBAX="E" D ADDEX^IBAUTL6($O(^IBE(354.2,"ACODE",2010,0)),+DGMTA) G ADJQ ;is income test hardship
- ;
- D AEX
- ;
- ADJQ Q
- ;
- CODE(TEST) ; -- return means test status
- I '$G(TEST) S TEST=""
- Q $P($G(^DG(408.32,+$P(TEST,"^",3),0)),"^",2)
- ;
- AUTO ; -- if auto status patient
- ; add auto exemption if needed
- S IBDT=$S(+DGMTA:+DGMTA,+DGMTP:+DGMTP,1:"")
- S IBAUTO=$$AUTOST^IBARXEU1(DFN,IBDT) I IBAUTO'="" D G AUTOQ
- .S X=$$RXST^IBARXEU(DFN,IBDT)
- .I X=""!($$PLUS^IBARXEU0($P(X,"^",5))<DT) S IBAD=1 D ADDEX^IBAUTL6(+IBAUTO,DT) Q ; add exemption if none or old
- .I $P(X,"^",3)'=$P($G(^IBE(354.2,+IBAUTO,0)),"^",5) S IBAD=1 D ADDEX^IBAUTL6(+IBAUTO,IBDT) Q ; if computes different add new exemption
- ;
- AUTOQ Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTED1 5140 printed Feb 18, 2025@23:32:59 Page 2
- IBAMTED1 ;ALB/AAS - MEANS TEST EVENT DRIVER - EXEMPTION PROCESSING ; 18-DEC-92
- +1 ;;2.0;INTEGRATED BILLING;**15,112,153,385**;21-MAR-94;Build 35
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- EN NEW IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER,IBEXERR,IBJOB,IBON
- +1 NEW IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP,IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
- +2 NEW DA,DR,DIC,DIE,I,J,X,Y,X1
- +3 ;
- +4 SET IBON=$$ON^IBARXEU0
- IF IBON<1
- GOTO ENQ
- +5 SET IBJOB=12
- SET IBWHER=13
- +6 ;
- +7 ; -- quit if nothing different (except completion date)
- +8 if '$DATA(DGMTA)!('$DATA(DGMTP))
- QUIT
- +9 IF $PIECE(DGMTA,"^",1,5)=$PIECE(DGMTP,"^",1,5)
- IF $PIECE(DGMTA,"^",10,20)=$PIECE(DGMTP,"^",10,20)
- QUIT
- +10 ; IVM 'delete' transmission
- IF DGMTA]""
- IF DGMTP]""
- IF DGMTACT="DEL"
- QUIT
- +11 ;
- +12 ; -- quit if invoked from ib=>mt=>ib
- +13 if $DATA(IBEVT)
- QUIT
- +14 ;
- +15 ; -- quit if before start date
- +16 IF +DGMTA
- if +$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
- GOTO ENQ
- +17 IF +DGMTP
- if +$$PLUS^IBARXEU0(+DGMTP)<$$STDATE^IBARXEU
- GOTO ENQ
- +18 ;
- +19 ;
- +20 IF '$DATA(ZTQUEUED)
- IF $DATA(IBTALK)
- WRITE !,"Determining Medication Co-Payment Exemption"
- +21 ;
- +22 ; -- if no patient add patient
- +23 IF '+$GET(^IBA(354,DFN,0))
- DO ADDP^IBAUTL6
- IF $GET(IBEXERR)
- GOTO ENQ
- +24 ;
- +25 DO AUTO
- IF IBAUTO'=""
- GOTO ENQ
- +26 ;
- +27 ; -- not auto exempt any more see if is more current auto status
- +28 SET X=$$LSTAC^IBARXEU0(DFN)
- IF $LENGTH(+X)=2
- IF $PIECE(X,"^",2)>+DGMTA
- SET IBOLDAUT=$PIECE(X,"^",2)
- +29 ; -- if mean test is required or no longer required
- +30 ; or copay test is incomplete or no longer applicable
- +31 ; add exemption of no income data
- +32 SET X=$PIECE(DGMTA,"^",3)
- IF X=1!(X=3)!(X=10)!(X=9)!($PIECE(DGMTA,"^",14))
- DO AEX
- GOTO ENQ
- +33 ;
- +34 IF "^ADD^DEL^EDT^ADJ^STA^CAT^COM^UPL^DUP^"[DGMTACT
- DO @DGMTACT
- +35 ;
- ENQ ; -- exit copay exemption creation
- +1 IF $GET(IBEXERR)
- DO ^IBAERR
- +2 IF $DATA(IBADDE)
- IF $DATA(IBTALK)
- WRITE !!,"Medication Copayment Exemption Status Updated: ",$PIECE(^IBE(354.2,+IBADDE,0),"^")," ",$$DAT1^IBOUTL($PIECE(IBADDE,"^",2))
- +3 QUIT
- +4 ;
- ADD ; -- adding a new test
- +1 IF DGMTACT="ADD"
- DO AEX
- +2 ;
- ADDQ QUIT
- +1 ;
- AEX ; -- add exemption logic
- +1 ; DO NOT USER FOR AUTOMATICS
- +2 ;
- +3 SET IBEXREA=""
- +4 ;
- +5 ; -- if means test required, no longer required,
- +6 ; or copay test incomplete or no longer applicable
- +7 ; set up no income data exemption if not automatic.
- +8 ;
- +9 SET X=$PIECE(DGMTA,"^",3)
- IF X=1!(X=3)!(X=10)!(X=9)!($PIECE(DGMTA,"^",14))
- SET IBEXREA=$ORDER(^IBE(354.2,"ACODE",$SELECT($PIECE(DGMTA,"^",14):110,1:210),0))
- +10 ;
- +11 ;
- +12 IF $$NETW^IBARXEU1
- IF 'IBEXREA
- SET IBEXREA=+$$MTCOMP^IBARXEU5($$INCDT^IBARXEU1(DGMTA),DGMTA)
- +13 IF '$$NETW^IBARXEU1
- IF 'IBEXREA
- SET IBEXREA=+$PIECE($$INCDT^IBARXEU1(DGMTA),"^",3)
- +14 ;
- +15 ; -- make sure more recent exemption than current test date is inactivetd
- +16 DO MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
- +17 DO ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$GET(IBOLDAUT))
- +18 QUIT
- +19 ;
- UPL ; -- uploading an IVM-verified means test
- DUP ; -- deleting an IVM-verified means test
- EDT ; -- editing an old means test
- +1 ; if data different attempt to add new test
- +2 IF DGMTA=DGMTP
- GOTO EDITQ
- +3 DO AEX
- EDITQ QUIT
- +1 ;
- DEL ; -- means test deleted
- +1 ; find exemption for date and inactivate
- +2 ; update current exemption status
- +3 ;
- +4 NEW IBFORCE,IBVFAOK
- +5 if '$DATA(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
- QUIT
- +6 ; force inactivate entries for deleted date
- SET IBFORCE=+DGMTP
- +7 ;
- +8 SET IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP)
- SET IBSTAT=$PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",4)
- +9 ;
- +10 ; -- look up VFA status
- +11 SET IBVFAOK=$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$PIECE(IBEXREA,"^",2)))
- +12 ;
- +13 ; -- cancel prior exemption with a no data exemption if last date older than 1 year, only if it is not VFA OK.
- +14 IF $$PLUS^IBARXEU0($PIECE(IBEXREA,"^",2))<DT
- IF 'IBVFAOK
- DO ADDEX^IBAUTL6(+$ORDER(^IBE(354.2,"ACODE",210,0)),+DGMTP)
- GOTO DELQ
- +15 ;
- +16 ; -- add correct exemption and update current status
- +17 DO ADDEX^IBAUTL6(+IBEXREA,+$PIECE(IBEXREA,"^",2))
- DELQ QUIT
- +1 ;
- COM ; -- complete a required means test
- CAT ; -- category change
- STA ; -- status change
- ADJ ; -- means test adjudication
- +1 ;
- +2 SET IBAX1=$$CODE(DGMTP)
- SET IBAX=$$CODE(DGMTA)
- +3 ;
- +4 ;treat as an adjudication
- IF $$NETW^IBARXEU1
- IF IBAX1="P"
- IF IBAX'="P"
- Begin DoDot:1
- +5 ; means test codes
- IF $PIECE(DGMTA,"^",19)=1
- SET IBEXREA=$SELECT(IBAX="C":140,IBAX="A":150,1:"")
- +6 ; copay exemption test
- IF $PIECE(DGMTA,"^",19)=2
- SET IBEXREA=$SELECT(IBAX="N":140,IBAX="E":150,1:"")
- +7 SET IBEXREA=$ORDER(^IBE(354.2,"ACODE",+IBEXREA,0))
- +8 if '$GET(IBEXREA)
- QUIT
- +9 DO ADDEX^IBAUTL6(IBEXREA,+DGMTA,1,1)
- +10 QUIT
- End DoDot:1
- GOTO ADJQ
- +11 ;
- +12 ;I $P(DGMTA,"^",19)=1,IBAX1="C",IBAX="A" D ADDEX^IBAUTL6($O(^IBE(354.2,"ACODE",2010,0)),+DGMTA) G ADJQ ;is a means test hardship
- +13 ;
- +14 ;is income test hardship
- IF $PIECE(DGMTA,"^",19)=2
- IF IBAX1="N"
- IF IBAX="E"
- DO ADDEX^IBAUTL6($ORDER(^IBE(354.2,"ACODE",2010,0)),+DGMTA)
- GOTO ADJQ
- +15 ;
- +16 DO AEX
- +17 ;
- ADJQ QUIT
- +1 ;
- CODE(TEST) ; -- return means test status
- +1 IF '$GET(TEST)
- SET TEST=""
- +2 QUIT $PIECE($GET(^DG(408.32,+$PIECE(TEST,"^",3),0)),"^",2)
- +3 ;
- AUTO ; -- if auto status patient
- +1 ; add auto exemption if needed
- +2 SET IBDT=$SELECT(+DGMTA:+DGMTA,+DGMTP:+DGMTP,1:"")
- +3 SET IBAUTO=$$AUTOST^IBARXEU1(DFN,IBDT)
- IF IBAUTO'=""
- Begin DoDot:1
- +4 SET X=$$RXST^IBARXEU(DFN,IBDT)
- +5 ; add exemption if none or old
- IF X=""!($$PLUS^IBARXEU0($PIECE(X,"^",5))<DT)
- SET IBAD=1
- DO ADDEX^IBAUTL6(+IBAUTO,DT)
- QUIT
- +6 ; if computes different add new exemption
- IF $PIECE(X,"^",3)'=$PIECE($GET(^IBE(354.2,+IBAUTO,0)),"^",5)
- SET IBAD=1
- DO ADDEX^IBAUTL6(+IBAUTO,IBDT)
- QUIT
- End DoDot:1
- GOTO AUTOQ
- +7 ;
- AUTOQ QUIT