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

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

initial load of WorldVistAEHR
File size: 7.2 KB
Line 
1IBARX ;ALB/AAS-INTEGRATED BILLING, PHARMACY COPAY INTERFACE ;14-FEB-91
2 ;;2.0;INTEGRATED BILLING;**101,150,156,168,186,237,308**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5XTYPE ; - tag XTYPE - returns array of billable action types for service
6 ; - see IBARXDOC for documentation
7 ;
8X1 K Y D INSTAL I '$T S Y=-1 Q
9 N I,J,X1,X2,DA,DFN,IBCAP S Y=1,IBSAVX=X,IBTAG=1,IBWHER=5
10 ;
11 D CHKX^IBAUTL G:+Y<1 XTYPEQ
12 ;
13 I '$D(^IBE(350.1,"ANEW",IBSERV,1,1)) D S Y=-1 G XTYPEQ
14 .I '$D(ZTQUEUED) W !!,*7,"WARNING: Pharmacy Copay not working,",!," Check IB SERVICE/SECTION in Pharmacy Site File.",!!
15 .D E3^IBAERR
16 ;
17 N X D ELIG^VADPT,INP^VADPT,DOM S Y=1
18 F I=0:0 S I=$O(^IBE(350.1,"ANEW",IBSERV,1,I)) Q:'I I $D(^IBE(350.1,I,40)) S DA=I X ^IBE(350.1,DA,40) S Y(DA,X)=I_"^"_X1_"^"_X2 S:'$G(IBCAP) IBCAP=X
19 ;
20 I $G(IBCAP),$G(DFN) D NEW^IBARXPFS(DFN)
21 ;
22XTYPEQ K X1,X2,IBSERV,VAEL,VA,VAERR,IBDOM,VAIN,IBSAVX,IBTAG,IBWHER
23 ;
24 Q
25 ;
26DOM S IBDOM=0 I $D(VAIN(4)),$D(^DIC(42,+VAIN(4),0)),$P(^(0),"^",3)="D" S IBDOM=1
27 Q
28NEW ; - process new/renew/refill rx for charges
29 ; - see IBARXDOC for documentation
30 ;
31N1 K Y,IBSAVX D INSTAL I '$T S Y=-1 Q
32 N I,J,X1,X2,DA,DFN,IBEXMP
33 S IBWHER=1,IBSAVX=X,Y=1,IBTAG=2 D CHKX^IBAUTL I +Y<1 G NEWQ
34 I $D(X)<11 S Y="-1^IB010" G NEWQ
35 S J="" F S J=$O(X(J)) Q:J="" S IBSAVX(J)=X(J)
36 D ARPARM^IBAUTL I +Y<1 G NEWQ
37 ;
38 ; -- check rx exemption in case refill is exempt
39 ; -- if exempt set amount to each rx and total to zero
40 ; 1= exempt, 0= non-exempt, -1=copay off (manila)
41 S IBEXMP=+$$RXEXMT^IBARXEU0(DFN,DT)
42 I IBEXMP'=0 D S Y="1^0" G NEWQ
43 .S IBJ=""
44 .; changed return value 6th piece is the exempt flag
45 .F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S $P(Y(IBJ),"^",6)=IBEXMP
46 .Q
47 ;
48 ; check to see if billing has been tracked across facilities before,
49 ; if not, start now.
50 D TRACK^IBARXMN(DFN) I +Y<1 G NEWQ
51 ;
52 S IBTOTL=0
53 D BILLNO^IBAUTL I +Y<1 G NEWQ
54 ;
55 S IBTOTL=0,IBJ="",IBSEQNO=$P(^IBE(350.1,IBATYP,0),"^",5) I 'IBSEQNO S Y="-1^IB023" G NEWQ
56 F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S IBX=IBSAVX(IBJ) D RX^IBARX1
57 I +Y<1 G NEWQ
58 ;
59 ; changed to only do if charge exists
60 D:IBTOTL ^IBAFIL
61 ;
62 S IBJ="" F S IBJ=$O(IBSAVY(IBJ)) Q:IBJ="" S Y(IBJ)=IBSAVY(IBJ)
63 S:+Y>0 Y="1^"_IBTOTL S X=IBSAVX
64 ;
65NEWQ D:+Y<1 ^IBAERR
66 D END
67 Q
68 ;
69INSTAL I $S($D(^IBE(350.9,1,0)):1,$D(^IB(0)):1,1:0)
70 Q
71 ;
72CANCEL ; - cancel charges for a rx
73 ; - see IBARXDOC for documentation
74 ;
75C1 K Y,IBSAVX N I,J,X1,X2,DA,DFN I '$G(IBUPDATE) N IBCAP,IBAMP,IBSAVXMC
76 S IBWHER=1,IBSAVX=X,Y=1,IBTAG=3 D CHKX^IBAUTL I +Y<1 G CANQ
77 I $D(X)<11 S Y="-1^IB010" G CANQ
78 S J="" F S J=$O(X(J)) Q:J="" S IBSAVX(J)=X(J)
79 D ARPARM^IBAUTL I +Y<1 G CANQ
80 ;
81 S IBJ="",IBTOTL=0
82 F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S IBX=IBSAVX(IBJ) D CANRX^IBARX1 I +IBY(IBJ)'<1 D ^IBAFIL:$P(IBND,"^",5)'=8 I +Y<1 S IBY(IBJ)=Y
83 I +Y<1 S IBT="",IBY=Y,IBM="" F S IBM=$O(IBY(IBM)) Q:IBM="" I +IBY(IBM)<1 S Y=IBY(IBM) D ^IBAERR S Y(IBM)=IBY(IBM),Y=IBY
84CANQ D:+Y<1 ^IBAERR:('$D(IBT))
85 S X=IBSAVX
86 M IBSAVXMC=Y
87 D END
88 ;
89 ; now that I have cancelled lets see if there are some to be billed
90 I '$G(IBUPDATE),$D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCAP,.IBSAVXMC)
91 ;S IBD=0 F S IBD=$O(IBCAP(IBD)) Q:IBD<1 D CANCEL^IBARXMC(DFN,IBD)
92 Q
93 ;
94UPDATE ; - will cancel current open charge and create updated entry
95 ; - see IBARXDOC for documentation
96 ;
97U1 K Y,IBSAVX N I,J,X1,X2,DA,DFN,IBEXMP,IBUPDATE,IBCAP,IBEFDT,IBAMP,IBSAVXMC
98 S IBUPDATE=1 ; new flag so we know we are updating
99 S IBWHER=1,IBSAVX=X,Y=1,IBTAG=4 D CHKX^IBAUTL I +Y<1 G UPDQ
100 S IBSAVXU=IBSAVX
101 I $D(X)<11 S Y="-1^IB010" G UPDQ
102 S J="" F S J=$O(X(J)) Q:J="" S IBSAVXU(J)=X(J),X(J)=$P(X(J),"^",3,4) D EFDT^IBARXMU($P(X(J),"^"),.IBEFDT)
103 ;
104 D CANCEL
105U2 K X
106 S X=IBSAVXU S J="" F S J=$O(IBSAVXU(J)) Q:J="" S X(J)=$P(IBSAVXU(J),"^",1,3)
107 S IBSAVX=X,Y=1,IBTAG=4 D CHKX^IBAUTL I +Y<1 G UPDQ
108 D ARPARM^IBAUTL I +Y<1 G UPDQ
109 ;
110 ; -- check rx exemption in case refill is exempt
111 ; -- if exempt set amount to each rx and total to zero
112 S IBEXMP=+$$RXEXMT^IBARXEU0(DFN,DT)
113 I IBEXMP'=0 D S Y="1^0" G UPDQ
114 .; changed return value 6th piece is the exempt flag
115 .S IBJ="" F S IBJ=$O(IBSAVXU(IBJ)) Q:IBJ="" S $P(Y(IBJ),"^",6)=IBEXMP
116 .Q
117 ;
118 S IBATYP=$P(^IBE(350.1,+IBATYP,0),"^",7) I '$D(^IBE(350.1,+IBATYP,0)) S Y="-1^IB008" G UPDQ ;update type action
119 ;
120 D BILLNO^IBAUTL G:+Y<1 UPDQ
121 S IBTOTL=0,IBNOS="",IBSEQNO=$P(^IBE(350.1,IBATYP,0),"^",5) I 'IBSEQNO S Y="-1^IB023" G UPDQ
122 S IBJ="" F S IBJ=$O(IBSAVXU(IBJ)) Q:IBJ="" S IBX=IBSAVXU(IBJ) S:$D(IBEFDT(+$P(IBX,"^",3))) IBEFDT=IBEFDT(+$P(IBX,"^",3)) D UCHPAR,RX^IBARX1:'$D(IBSAVY(IBJ)) S IBEFDT=0
123 D ^IBAFIL
124 ;
125 S IBJ="" F S IBJ=$O(IBSAVY(IBJ)) Q:IBJ="" S Y(IBJ)=IBSAVY(IBJ),$P(Y(IBJ),"^",6)=+$G(IBEXMP) S:+Y(IBJ)<1 Y=Y(IBJ)
126 S:+Y>0 Y="1^"_IBTOTL S X=IBSAVXU
127 ;
128 ; now that I have the update done lets see if there are some to be billed
129 I $D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCAP,.IBSAVXMC)
130 ;S IBD=0 F S IBD=$O(IBCAP(IBD)) Q:IBD<1 D CANCEL^IBARXMC(DFN,IBD)
131 ;
132UPDQ D:+Y<1 ^IBAERR
133 K IBSAVXU
134END K %,%H,%I,K,X1,X2,X3,IBSERV,IBATYP,IBAFY,IBDUZ,IBNOW,IBSAVX,IBTOTL,IBX,IBT,IBCHRG,IBDESC,IBFAC,IBIL,IBN,IBNOS,IBSEQNO,IBSITE,IBTAG,IBTRAN,IBCRES,IBJ,IBLAST,IBND,IBY,IBPARNT,IBUNIT,IBJ,IBARTYP,IBI,IBSAVY,IBWHER
135 Q
136UCHPAR ; Check that IB action and its parent exist.
137 S IBPARNT=$P(IBX,"^",3)
138 I '$D(^IB(+IBPARNT,0)) S IBSAVY(IBJ)="-1^IB021" G UCHPARQ
139 S IBPARNT=$P(^IB(+IBPARNT,0),"^",9)
140 I '$D(^IB(+IBPARNT,0)) S IBSAVY(IBJ)="-1^IB027"
141UCHPARQ Q
142 ;
143STATUS(X) ; returns the status of a transaction in 350
144 ; - see IBARXDOC for documentation
145 ;
146 N Y S Y=$G(^IB(X,0))
147 Q +$S($P(Y,"^",5)=10:2,1:$P($G(^IBE(350.1,+$P(Y,"^",3),0)),"^",5))
148 ;
149CANIBAM ; used by pso to cancel a 354.71 transaction
150 ; - see IBARXDOC for documentation
151 N IBZ,IBXX,IBYY,IBCAP
152 M IBXX=X
153 S IBXX=0 F S IBXX=$O(IBXX(IBXX)) Q:IBXX="" D
154 . N IBY
155 . S IBZ=$G(^IBAM(354.71,+IBXX(IBXX),0))
156 . I $P(IBZ,"^",4) S IBYY(IBXX)="-1^Transaction has been billed" Q
157 . I $P(IBZ,"^",5)="Y"!($P(IBZ,"^",5)="X") S IBYY(IBXX)="-1^Transaction already cancelled" Q
158 . S IBZ=$$CANCEL^IBARXMN($P(IBZ,"^",2),+IBXX(IBXX),.IBY,$P(IBXX(IBXX),"^",2))
159 . S IBYY(IBXX)=$S($P($G(IBY),"^")=-1:IBY,1:IBZ)
160 K Y M Y=IBYY
161 Q
162 ;
163UPIBAM ; - will cancel current potential charge and create updated entry
164 ; - see IBARXDOC for documentation
165 ;
166 N IBXX,IBYY,IBWHER,IBTAG,IBZ,IBX,IBY,IBSAVX,IBA,IBAM,IBATYP,IBCAP,IBDESC,IBDUZ,IBSERV,IBTCH
167 M IBXX=X
168 S IBA=$O(X("")) I IBA="" S (Y)="-1^Invalid Subscript in X" Q
169 S IBWHER=1,Y=1,IBTAG=4,IBSAVX=X D CHKX^IBAUTL I +Y<1 S Y(IBA)=Y Q
170 S IBZ=$G(^IBAM(354.71,+$P($G(IBXX(IBA)),"^",3),0))
171 ;
172 ; check out the transaction sent
173 I 'IBZ S (Y,Y(IBA))="-1^Not a valid transaction number" Q
174 I $P(IBZ,"^",4) S (Y,Y(IBA))="-1^Transaction has been billed" Q
175 I $P(IBZ,"^",5)="Y"!($P(IBZ,"^",5)="X") S (Y,Y(IBA))="-1^Transaction already cancelled" Q
176 ;
177 ; cancel that transaction
178 S IBX=$$CANCEL^IBARXMN($P(IBZ,"^",2),$P($G(IBXX(IBA)),"^",3),.Y,$P(IBXX(IBA),"^",4)) I +Y<1 S Y(IBA)=Y Q
179 ;
180 ; create the new updated transaction
181 S IBX=IBXX(IBA) D BDESC^IBARX1 S IBATYP=$P(^IBE(350.1,+IBATYP,0),"^",7),DA=IBATYP D COST^IBAUTL S IBTCH=$P(IBX,"^",2)*X1
182 S IBAM=$$ADD^IBARXMN($P(IBZ,"^",2),"^^"_$P(IBZ,"^",3)_"^^P^"_$P(IBXX(IBA),"^")_"^"_$P(IBXX(IBA),"^",2)_"^"_IBTCH_"^"_IBDESC_"^"_$$PARENT^IBARXMC($P(IBXX(IBA),"^",3))_"^0^"_IBTCH_"^"_(+$P($$SITE^IBARXMU,"^",3)),IBATYP)
183 I IBAM<1 S (Y,Y(IBA))="-1^IB316" Q
184 ;
185 S Y(IBA)=IBAM,Y=1
186 ;
187 Q
Note: See TracBrowser for help on using the repository browser.