source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAMTED1.m@ 1806

Last change on this file since 1806 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.7 KB
Line 
1IBAMTED1 ;ALB/AAS - MEANS TEST EVENT DRIVER - EXEMPTION PROCESSING ; 18-DEC-92
2 ;;2.0;INTEGRATED BILLING;**15,112,153**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN N IBAD,IBADDE,IBADD,IBDT,IBEXREA,IBAUTO,IBAX,IBAX1,IBOLDAUT,IBWHER,IBEXERR,IBJOB,IBON
6 N IBAFY,IBATYP,IBBDT,IBCANDT,IBCHRG,IBCODA,IBCODP,IBCRES,IBDEPEN,IBFAC,IBIL,IBL,IBAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBSITE,IBUNIT
7 N DA,DR,DIC,DIE,I,J,X,Y,X1
8 ;
9 S IBON=$$ON^IBARXEU0 I IBON<1 G ENQ
10 S IBJOB=12,IBWHER=13
11 ;
12 ; -- quit if nothing different (except completion date)
13 Q:'$D(DGMTA)!('$D(DGMTP))
14 I $P(DGMTA,"^",1,5)=$P(DGMTP,"^",1,5),$P(DGMTA,"^",10,20)=$P(DGMTP,"^",10,20) Q
15 I DGMTA]"",DGMTP]"",DGMTACT="DEL" Q ; IVM 'delete' transmission
16 ;
17 ; -- quit if invoked from ib=>mt=>ib
18 Q:$D(IBEVT)
19 ;
20 ; -- quit if before start date
21 I +DGMTA G ENQ:+$$PLUS^IBARXEU0(+DGMTA)<$$STDATE^IBARXEU
22 I +DGMTP G ENQ:+$$PLUS^IBARXEU0(+DGMTP)<$$STDATE^IBARXEU
23 ;
24 ;
25 I '$D(ZTQUEUED),$D(IBTALK) W !,"Determining Medication Co-Payment Exemption"
26 ;
27 ; -- if no patient add patient
28 I '+$G(^IBA(354,DFN,0)) D ADDP^IBAUTL6 I $G(IBEXERR) G ENQ
29 ;
30 D AUTO I IBAUTO'="" G ENQ
31 ;
32 ; -- not auto exempt any more see if is more current auto status
33 S X=$$LSTAC^IBARXEU0(DFN) I $L(+X)=2,$P(X,"^",2)>+DGMTA S IBOLDAUT=$P(X,"^",2)
34 ; -- if mean test is required or no longer required
35 ; or copay test is incomplete or no longer applicable
36 ; add exemption of no income data
37 S X=$P(DGMTA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(DGMTA,"^",14)) D AEX G ENQ
38 ;
39 I "^ADD^DEL^EDT^ADJ^STA^CAT^COM^UPL^DUP^"[DGMTACT D @DGMTACT
40 ;
41ENQ ; -- exit copay exemption creation
42 I $G(IBEXERR) D ^IBAERR
43 I $D(IBADDE),$D(IBTALK) W !!,"Medication Copayment Exemption Status Updated: ",$P(^IBE(354.2,+IBADDE,0),"^")," ",$$DAT1^IBOUTL($P(IBADDE,"^",2))
44 Q
45 ;
46ADD ; -- adding a new test
47 I DGMTACT="ADD" D AEX
48 ;
49ADDQ Q
50 ;
51AEX ; -- add exemption logic
52 ; DO NOT USER FOR AUTOMATICS
53 ;
54 S IBEXREA=""
55 ;
56 ; -- if means test required, no longer required,
57 ; or copay test incomplete or no longer applicable
58 ; set up no income data exemption if not automatic.
59 ;
60 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))
61 ;
62 ;
63 I $$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$$MTCOMP^IBARXEU5($$INCDT^IBARXEU1(DGMTA),DGMTA)
64 I '$$NETW^IBARXEU1,'IBEXREA S IBEXREA=+$P($$INCDT^IBARXEU1(DGMTA),"^",3)
65 ;
66 ; -- make sure more recent exemption than current test date is inactivetd
67 D MOSTR^IBARXEU5(+DGMTA,+IBEXREA)
68 D ADDEX^IBAUTL6(+IBEXREA,+DGMTA,1,1,$G(IBOLDAUT))
69 Q
70 ;
71UPL ; -- uploading an IVM-verified means test
72DUP ; -- deleting an IVM-verified means test
73EDT ; -- editing an old means test
74 ; if data different attempt to add new test
75 I DGMTA=DGMTP G EDITQ
76 D AEX
77EDITQ Q
78 ;
79DEL ; -- means test deleted
80 ; find exemption for date and inactivate
81 ; update current exemption status
82 ;
83 N IBFORCE
84 Q:'$D(^IBA(354.1,"AIVDT",1,DFN,-DGMTP))
85 S IBFORCE=+DGMTP ; force inactivate entries for deleted date
86 ;
87 S IBEXREA=$$STATUS^IBARXEU1(DFN,+DGMTP),IBSTAT=$P($G(^IBE(354.2,+IBEXREA,0)),"^",4)
88 ;
89 ; -- cancel prior exemption with a no data exemption if last date older than 1 year
90 I $$PLUS^IBARXEU0($P(IBEXREA,"^",2))<DT D ADDEX^IBAUTL6(+$O(^IBE(354.2,"ACODE",210,0)),+DGMTP) G DELQ
91 ;
92 ; -- add correct exemption and update current status
93 D ADDEX^IBAUTL6(+IBEXREA,+$P(IBEXREA,"^",2))
94DELQ Q
95 ;
96COM ; -- complete a required means test
97CAT ; -- category change
98STA ; -- status change
99ADJ ; -- means test adjudication
100 ;
101 S IBAX1=$$CODE(DGMTP),IBAX=$$CODE(DGMTA)
102 ;
103 I $$NETW^IBARXEU1,IBAX1="P",IBAX'="P" D G ADJQ ;treat as an adjudication
104 .I $P(DGMTA,"^",19)=1 S IBEXREA=$S(IBAX="C":140,IBAX="A":150,1:"") ; means test codes
105 .I $P(DGMTA,"^",19)=2 S IBEXREA=$S(IBAX="N":140,IBAX="E":150,1:"") ; copay exemption test
106 .S IBEXREA=$O(^IBE(354.2,"ACODE",+IBEXREA,0))
107 .Q:'$G(IBEXREA)
108 .D ADDEX^IBAUTL6(IBEXREA,+DGMTA,1,1)
109 .Q
110 ;
111 ;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
112 ;
113 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
114 ;
115 D AEX
116 ;
117ADJQ Q
118 ;
119CODE(TEST) ; -- return means test status
120 I '$G(TEST) S TEST=""
121 Q $P($G(^DG(408.32,+$P(TEST,"^",3),0)),"^",2)
122 ;
123AUTO ; -- if auto status patient
124 ; add auto exemption if needed
125 S IBDT=$S(+DGMTA:+DGMTA,+DGMTP:+DGMTP,1:"")
126 S IBAUTO=$$AUTOST^IBARXEU1(DFN,IBDT) I IBAUTO'="" D G AUTOQ
127 .S X=$$RXST^IBARXEU(DFN,IBDT)
128 .I X=""!($$PLUS^IBARXEU0($P(X,"^",5))<DT) S IBAD=1 D ADDEX^IBAUTL6(+IBAUTO,DT) Q ; add exemption if none or old
129 .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
130 ;
131AUTOQ Q
Note: See TracBrowser for help on using the repository browser.