Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBAMTED1

IBAMTED1.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. EN N IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER,IBEXERR,IBJOB,IBON
  1. N IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP,IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
  1. N DA,DR,DIC,DIE,I,J,X,Y,X1
  1. ;
  1. S IBON=$$ON^IBARXEU0 I IBON<1 G ENQ
  1. S IBJOB=12,IBWHER=13
  1. ;
  1. ; -- quit if nothing different (except completion date)
  1. Q:'$D(DGMTA)!('$D(DGMTP))
  1. I $P(DGMTA,"^",1,5)=$P(DGMTP,"^",1,5),$P(DGMTA,"^",10,20)=$P(DGMTP,"^",10,20) Q
  1. I DGMTA]"",DGMTP]"",DGMTACT="DEL" Q ; IVM 'delete' transmission
  1. ;
  1. ; -- quit if invoked from ib=>mt=>ib
  1. Q:$D(IBEVT)
  1. ;
  1. ; -- quit if before start date
  1. I +DGMTA G ENQ:+$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
  1. I +DGMTP G ENQ:+$$PLUS^IBARXEU0(+DGMTP)<$$STDATE^IBARXEU
  1. ;
  1. ;
  1. I '$D(ZTQUEUED),$D(IBTALK) W !,"Determining Medication Co-Payment Exemption"
  1. ;
  1. ; -- if no patient add patient
  1. I '+$G(^IBA(354,DFN,0)) D ADDP^IBAUTL6 I $G(IBEXERR) G ENQ
  1. ;
  1. D AUTO I IBAUTO'="" G ENQ
  1. ;
  1. ; -- not auto exempt any more see if is more current auto status
  1. S X=$$LSTAC^IBARXEU0(DFN) I $L(+X)=2,$P(X,"^",2)>+DGMTA S IBOLDAUT=$P(X,"^",2)
  1. ; -- if mean test is required or no longer required
  1. ; or copay test is incomplete or no longer applicable
  1. ; add exemption of no income data
  1. S X=$P(DGMTA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(DGMTA,"^",14)) D AEX G ENQ
  1. ;
  1. I "^ADD^DEL^EDT^ADJ^STA^CAT^COM^UPL^DUP^"[DGMTACT D @DGMTACT
  1. ;
  1. ENQ ; -- exit copay exemption creation
  1. I $G(IBEXERR) D ^IBAERR
  1. I $D(IBADDE),$D(IBTALK) W !!,"Medication Copayment Exemption Status Updated: ",$P(^IBE(354.2,+IBADDE,0),"^")," ",$$DAT1^IBOUTL($P(IBADDE,"^",2))
  1. Q
  1. ;
  1. ADD ; -- adding a new test
  1. I DGMTACT="ADD" D AEX
  1. ;
  1. ADDQ Q
  1. ;
  1. AEX ; -- add exemption logic
  1. ; DO NOT USER FOR AUTOMATICS
  1. ;
  1. S IBEXREA=""
  1. ;
  1. ; -- if means test required, no longer required,
  1. ; or copay test incomplete or no longer applicable
  1. ; set up no income data exemption if not automatic.
  1. ;
  1. 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))
  1. ;
  1. ;
  1. I $$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$$MTCOMP^IBARXEU5($$INCDT^IBARXEU1(DGMTA),DGMTA)
  1. I '$$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$P($$INCDT^IBARXEU1(DGMTA),"^",3)
  1. ;
  1. ; -- make sure more recent exemption than current test date is inactivetd
  1. D MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
  1. D ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$G(IBOLDAUT))
  1. Q
  1. ;
  1. UPL ; -- uploading an IVM-verified means test
  1. DUP ; -- deleting an IVM-verified means test
  1. EDT ; -- editing an old means test
  1. ; if data different attempt to add new test
  1. I DGMTA=DGMTP G EDITQ
  1. D AEX
  1. EDITQ Q
  1. ;
  1. DEL ; -- means test deleted
  1. ; find exemption for date and inactivate
  1. ; update current exemption status
  1. ;
  1. N IBFORCE,IBVFAOK
  1. Q:'$D(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
  1. S IBFORCE=+DGMTP ; force inactivate entries for deleted date
  1. ;
  1. S IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP),IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
  1. ;
  1. ; -- look up VFA status
  1. S IBVFAOK=$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$P(IBEXREA,"^",2)))
  1. ;
  1. ; -- cancel prior exemption with a no data exemption if last date older than 1 year, only if it is not VFA OK.
  1. I $$PLUS^IBARXEU0($P(IBEXREA,"^",2))<DT,'IBVFAOK D ADDEX^IBAUTL6(+$O(^IBE(354.2,"ACODE",210,0)),+DGMTP) G DELQ
  1. ;
  1. ; -- add correct exemption and update current status
  1. D ADDEX^IBAUTL6(+IBEXREA,+$P(IBEXREA,"^",2))
  1. DELQ Q
  1. ;
  1. COM ; -- complete a required means test
  1. CAT ; -- category change
  1. STA ; -- status change
  1. ADJ ; -- means test adjudication
  1. ;
  1. S IBAX1=$$CODE(DGMTP),IBAX=$$CODE(DGMTA)
  1. ;
  1. I $$NETW^IBARXEU1,IBAX1="P",IBAX'="P" D G ADJQ ;treat as an adjudication
  1. .I $P(DGMTA,"^",19)=1 S IBEXREA=$S(IBAX="C":140,IBAX="A":150,1:"") ; means test codes
  1. .I $P(DGMTA,"^",19)=2 S IBEXREA=$S(IBAX="N":140,IBAX="E":150,1:"") ; copay exemption test
  1. .S IBEXREA=$O(^IBE(354.2,"ACODE",+IBEXREA,0))
  1. .Q:'$G(IBEXREA)
  1. .D ADDEX^IBAUTL6(IBEXREA,+DGMTA,1,1)
  1. .Q
  1. ;
  1. ;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
  1. ;
  1. 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
  1. ;
  1. D AEX
  1. ;
  1. ADJQ Q
  1. ;
  1. CODE(TEST) ; -- return means test status
  1. I '$G(TEST) S TEST=""
  1. Q $P($G(^DG(408.32,+$P(TEST,"^",3),0)),"^",2)
  1. ;
  1. AUTO ; -- if auto status patient
  1. ; add auto exemption if needed
  1. S IBDT=$S(+DGMTA:+DGMTA,+DGMTP:+DGMTP,1:"")
  1. S IBAUTO=$$AUTOST^IBARXEU1(DFN,IBDT) I IBAUTO'="" D G AUTOQ
  1. .S X=$$RXST^IBARXEU(DFN,IBDT)
  1. .I X=""!($$PLUS^IBARXEU0($P(X,"^",5))<DT) S IBAD=1 D ADDEX^IBAUTL6(+IBAUTO,DT) Q ; add exemption if none or old
  1. .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
  1. ;
  1. AUTOQ Q