source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXMC.m@ 1259

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1IBARXMC ;LL/ELZ-PHARMACY COPAY CAP FUNCTIONS ;26-APR-2001
2 ;;2.0;INTEGRATED BILLING;**156,186,237**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5NEW(IBQ,IBC,IBD,IBB,IBN) ; used to compute new bills amount above cap
6 ; DFN is assumed
7 ; IBQ = quantity
8 ; IBC = charge per item
9 ; IBD = effective date
10 ; Return:
11 ; IBB = Amount to bill
12 ; IBN = Amount NOT to bill
13 ;
14 N IBA,IBA,IBZ,IBP,IBE,IBY,IBFD,IBTD
15 ;
16 S IBP=$$PRIORITY^IBARXMU(DFN)
17 D CAP(IBD,IBP,.IBZ,.IBY,.IBFD,.IBTD)
18 S IBA=$$BILLED(DFN,IBD,IBFD,IBTD),IBE=$P(IBA,"^",2)
19 S IBB=IBQ*IBC
20 S IBB=$S('IBZ:IBB,IBB+IBA>IBZ:$S(IBZ-IBA>0:IBZ-IBA,1:0),1:IBB) ; monthly
21 I IBB,IBY S IBB=$S(IBB+IBE>IBY:$S(IBY-IBE>0:IBY-IBE,1:0),1:IBB) ; yearly
22 S IBN=$S(IBQ*IBC=IBB:0,1:IBQ*IBC-IBB)
23 ;
24 Q
25 ;
26BILLED(DFN,IBD,IBFD,IBTD) ; returns about billed, format: month^year
27 ; IBD = transaction date, IBFD = from date, IBTD = to date
28 N IBFY,IBX,IBM,IBY,IBZ
29 F IBX="IBD","IBFD","IBTD" S @IBX=$E(@IBX,1,5)_"00"
30 S IBX=+$O(^IBAM(354.7,DFN,1,"B",IBD,0))
31 S IBM=+$P($G(^IBAM(354.7,DFN,1,IBX,0)),"^",2)
32 S IBY=0,IBZ=IBFD-1 F S IBZ=$O(^IBAM(354.7,DFN,1,"B",IBZ)) Q:IBZ<1!(IBZ>IBTD) S IBX=$O(^IBAM(354.7,DFN,1,"B",IBZ,0)) I IBX S IBY=IBY+$P($G(^IBAM(354.7,DFN,1,IBX,0)),"^",2)
33 Q IBM_"^"_IBY
34 ;
35CAP(IBD,IBP,IBM,IBY,IBF,IBT) ; returns the cap amount and dates
36 ; IBD = date of transaction
37 ; IBP = priority level of patient
38 ; return (by reference):
39 ; IBM = monthly cap amount
40 ; IBY = yearly cap amount
41 ; IBF = from date for yearly cap determination
42 ; IBT = to date for yearly cap determination
43 N IBX,IBDT
44 I $D(^IBAM(354.75,"AC",IBP,IBD)) S IBX=+$O(^(IBD,0)) G CAPC
45 S IBDT=+$O(^IBAM(354.75,"AC",IBP,IBD),-1),IBX=+$O(^(IBDT,0))
46CAPC ;
47 S IBX=$G(^IBAM(354.75,IBX,0))
48 I 'IBX!($P(IBX,"^",5)&(IBD>$P(IBX,"^",5))) S (IBM,IBY,IBF,IBT)=0 Q
49 S IBM=$P(IBX,"^",3),IBY=$P(IBX,"^",4)
50 S IBDT=$P($$FYCY^IBCU8(IBD),"^",$S($P(IBX,"^",6)="C":1,1:3),$S($P(IBX,"^",6)="C":2,1:4))
51 S IBF=$S($P(IBDT,"^")>IBX:$P(IBDT,"^"),1:+IBX)
52 S IBT=$S('$P(IBX,"^",5):$P(IBDT,"^",2),$P(IBDT,"^",2)<$P(IBX,"^",5):$P(IBDT,"^",2),1:$P(IBX,"^",5))
53 ;
54 Q
55 ;
56FLAG(DFN,IBD) ; flag account if at or above cap
57 ; IBD = date of transaction (mo/year fm format)
58 ; flag in account is set to: 2 = cap exceeded, some copays not billed
59 ; 1 = cap reached
60 ; 0 = below cap
61 ;
62 N IBC,IBB,IBZ,IBF,IBX,DIE,DR,DA,X,Y,IBFD,IBTD,IBY
63 S IBX=+$O(^IBAM(354.7,DFN,1,"B",IBD,0)) Q:'IBX
64 S IBZ=$G(^IBAM(354.7,DFN,1,IBX,0))
65 D CAP(IBD+1,+$$PRIORITY^IBARXMU(DFN),.IBC,.IBY,.IBFD,.IBTD)
66 S IBB=$$BILLED(DFN,IBD,IBFD,IBTD)
67 S IBF=$S('IBC&('IBY):0,$P(IBZ,"^",4):2,IBC=+IBB:1,IBY=$P(IBB,"^",2):1,1:0)
68 I IBF'=$P(IBZ,"^",3) S DIE="^IBAM(354.7,"_DFN_",1,",DA=IBX,DR=".03///^S X=IBF",DA(1)=DFN L +^IBAM(354.7,DFN):10 I $T D ^DIE L -^IBAM(354.7,DFN)
69 Q
70 ;
71PARENT(X) ; returns the parent entry in 354.71 for a transaction
72 Q +$P($G(^IBAM(354.71,X,0)),"^",10)
73 ;
74NET(X) ; returns net amount billed for a parent and its children
75 ; X = ien from 354.71 (parent or child) output: billed ^ un-billed
76 ;
77 N Y,Z,B,N,P S P=$$PARENT(X),(Y,B,N)=0 F S Y=$O(^IBAM(354.71,"AF",P,Y)) Q:Y<1 S Z=^IBAM(354.71,Y,0),B=B+$P(Z,"^",11),N=N+$P(Z,"^",12)
78 Q B_"^"_N
79 ;
80CANCEL(DFN,IBDT) ; receives notification of a cancellation and determines
81 ; if more need to be billed. IBDT should be in fm format date to check
82 ;
83 N IBT,IBTFL,IBX,IBD,IBFD,IBTD,IBDTQ,IBBIL,IBS1,IBS2
84 ;
85 ; first determine if cap reached or quit
86 ;Q:'$P($G(^IBAM(354.7,DFN,1,+$O(^IBAM(354.7,DFN,1,"B",IBDT,0)),0)),"^",3)
87 ;
88C1 ; get starting values
89 S IBS=+$$SITE^IBARXMU
90 S IBP=+$$PRIORITY^IBARXMU(DFN)
91 D CAP(IBDT+1,IBP,.IBZ,.IBY,.IBFD,.IBTD)
92 I ('IBY&('IBZ))!('IBFD)!('IBTD) Q
93 S IBA=$$BILLED(DFN,IBDT+1,IBFD,IBTD),IBE=$P(IBA,"^",2)
94 ;
95 ; query (if any) other facilities to see what is there.
96C2 S IBT=$$TFL^IBARXMU(DFN,.IBTFL)
97 I IBT W:'$D(ZTQUEUED) !,"This patient is being seen at other VA treating facilities. I need to make",!,"sure there are no Rx fills that have not been billed elsewhere." S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1 D
98 . I '$D(ZTQUEUED) U IO W !,"Now sending queries to ",$P(IBTFL(IBX),"^",2)," ..."
99 . S IBDTQ=IBFD F D S IBDTQ=$$NEXTMO(IBDTQ) Q:IBDTQ>IBTD
100 .. D UQUERY^IBARXMU(DFN,$E(IBDTQ,1,5)_"00",+IBTFL(IBX),.IBD)
101 .. I $P(IBD(0),"^")=-1!(-1=+IBD) K IBD Q
102 .. S X=1 F S X=$O(IBD(X)) Q:X<1 S IBD=$$ADD^IBARXMN(DFN,IBD(X))
103 .. K IBD
104 I '$D(ZTQUEUED) U IO
105 ;
106C3 K ^TMP("IBD",$J)
107 ; now lets see if there are some unbilled that can be billed.
108 S IBDTQ=IBFD F D S IBDTQ=$$NEXTMO(IBDTQ) Q:IBDTQ>IBTD
109 . S IBX=0 F S IBX=$O(^IBAM(354.71,"AD",DFN,$E(IBDTQ,1,5)_"00",IBX)) Q:IBX<1 D
110 .. N IBZ S IBZ=^IBAM(354.71,IBX,0)
111 .. ;
112 .. ; check, am I the parent and still have some unbilled
113 .. I $P(IBZ,"^",10)'=IBX!('$P($$NET(IBX),"^",2)) Q
114 .. ;
115 .. ; ^TMP("IBD",$J format(date of transaction,date/time entry added,ien)
116 .. S ^TMP("IBD",$J,$P(IBZ,"^",3),$P(IBZ,"^",15),IBX)=IBZ
117 ;
118 I '$D(^TMP("IBD",$J)) W:'$D(ZTQUEUED) !,"No un-billed transactions exist" Q
119 ;
120 ; how much more can we bill
121C4 S IBB=$S('IBZ&('IBY):9999999,IBZ&((IBZ-IBA)<(IBY-IBE)):IBZ-IBA,1:IBY-IBE)
122 ;
123 ; we now have to bill some of the unbilled ones
124 S IBS1=0 F S IBS1=$O(^TMP("IBD",$J,IBS1)) Q:IBS1<1 S IBS2=0 F S IBS2=$O(^TMP("IBD",$J,IBS1,IBS2)) Q:IBS2<1 S IBX=0 F S IBX=$O(^TMP("IBD",$J,IBS1,IBS2,IBX)) Q:IBX<1 D
125 . S IBZ=^TMP("IBD",$J,IBS1,IBS2,IBX)
126 . ;
127C5 . ; determine how much to bill (if any)
128 . S IBA=$$NET(IBX)
129 . S IBBIL=$S(IBB>$P(IBA,"^",2):$P(IBA,"^",2),1:IBB)
130 . I 'IBBIL S IBS1=9999999999 Q
131 . S IBB=IBB-IBBIL
132 . ;
133 . D @($S(IBS=+IBZ:"BILL",1:"SEND")_"^IBARXMB($P(IBZ,""^""),IBBIL)")
134 K ^TMP("IBD",$J)
135 Q
136 ;
137NEXTMO(DATE) ; returns first date of next month
138 N X S X="",DATE=$G(DATE)\1 I DATE'?7N G NEXTMOQ
139 S X=$S($E(DATE,4,5)<12:$E(DATE,1,5)+1_"01",1:$E(DATE,1,3)+1_"0101")
140NEXTMOQ Q X
141 ;
142QCAN(DFN,IBCAP,IBSAVXMC) ; queue off job to look for back billing in the background
143 N ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK,ZTSAVE,Y,IBTAG
144 ;
145 S ZTRTN="DQCAN^IBARXMC",ZTDESC="IB Back Billing of Rx Copay Charges"
146 S ZTDTH=$$FMTH^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,"","",10))
147 S (ZTSAVE("DFN"),ZTSAVE("IBCAP("),ZTSAVE("IBSAVXMC("),ZTIO)="" D ^%ZTLOAD
148 ;
149 I ZTSK<1 S IBTAG=3,Y="^^Error when trying to queue back billing job." D BULL^IBAERR
150 ;
151 Q
152 ;
153DQCAN ; entry point for queued back billing job
154 N IBD,IBL,IBPAT,IBREF,IBSSN,IBTAG,Y
155 ;
156 ; try to get a lock
157 S IBL=0 F X=1:1:10 L +^IBAM(354.7,"APAT",DFN):10 H:'$T 600 I $T S IBL=1 Q
158 I 'IBL D Q
159 .S IBTAG=3
160 .S IBPAT=$P($G(^DPT(DFN,0)),"^",1) I IBPAT="" S IBPAT=DFN
161 .S IBSSN=$P($G(^DPT(DFN,0)),"^",9) I IBSSN="" S IBSSN="????"
162 .S (X,IBREF)=""
163 .F S X=$O(IBSAVXMC(X)) Q:X="" D
164 ..I IBREF'="" S IBREF=IBREF_", "_$P(IBSAVXMC(X),"^",1)
165 ..I IBREF="" S IBREF=$P(IBSAVXMC(X),"^",1)
166 .S Y="^^Unable to lock the IB PATIENT COPAY ACCOUNT (#354.7) file for back billing job related to "_IBPAT_" ("_IBSSN_") and IB reference number(s): "_IBREF_"."
167 .D ^IBAERR Q
168 ;
169 ; do query/back billing
170 S IBD=0 F S IBD=$O(IBCAP(IBD)) Q:IBD<1 D CANCEL(DFN,IBD)
171 ;
172 ; remove lock
173 L -^IBAM(354.7,"APAT",DFN)
174 ;
175 Q
Note: See TracBrowser for help on using the repository browser.