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

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

initial load of WorldVistAEHR
File size: 6.9 KB
Line 
1IBARXMN ;LL/ELZ-PHARMCAY COPAY CAP RX PROCESSING ;17-NOV-2000
2 ;;2.0;INTEGRATED BILLING;**150,158,156,186,308**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5TRACK(DFN) ; checks out patient if tracked already
6 I '$D(^IBAM(354.7,DFN,0)) D QUERY(DFN,$E(DT,1,5)_"00")
7 Q
8 ;
9QUERY(DFN,IBDT) ; if there are treating facilities, perform query
10 N IBT,IBX,IBS,IBD,IBB,DIE,DA,DR,X,IBA,IBP,IBZ,IBY,IBFD,IBTD
11 S IBB=0,IBP=$$PRIORITY^IBARXMU(DFN)
12 D ADD^IBARXMU(DFN) Q:'IBP
13 S IBT=$$TFL^IBARXMU(DFN,.IBT) Q:'IBT
14 D CAP^IBARXMC(IBDT,IBP,.IBZ,.IBY,.IBFD,.IBTD) I 'IBY,'IBZ Q
15 I 'IBFD!('IBTD) Q
16 W !!,"This patient has never had billing information tracked before",!,"Now querying other facilities..."
17 S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 W !,"Now sending query to ",$P(IBT(IBX),"^",2)," ..." D
18 . ;
19 . ; need to query every month in the cap billing period
20 . S IBDT=IBFD D F S IBDT=$$NEXTMO^IBARXMC(IBDT) Q:IBDT>IBTD D
21 .. D UQUERY^IBARXMU(DFN,$E(IBDT,1,5)_"00",IBX,.IBD)
22 .. ;
23 .. ; error returned
24 .. I -1=+$G(IBD,"-1") Q
25 .. ;
26 .. ; loop through query and file data
27 .. S X=0 F S X=$O(IBD(X)) Q:X<1 S:$E(IBD(X),1,4)=+IBT(IBX)_"-" IBA=$$ADD(DFN,IBD(X)),IBB=IBB+$P(IBD(X),"^",11)
28 .. K IBD
29 ;
30 Q
31 ;
32ACCT(DFN,IBB,IBU,IBDT,IBS) ; - update amount in patient account
33 ; IBB = amount to be added to pt account (billed)
34 ; IBU = amount to be added to pt account (not billable)
35 ; IBDT = effective date for amount
36 ; IBS = flag, if passed the amounts are totals not to be added to what is already there
37 ;
38 N DIE,DR,DO,DIC,DA,Y,IBA
39 ;
40 S DA(1)=DFN,IBDT=$E(IBDT,1,5)_"00"
41 ;
42 ; check to see if there is already that mo/year there and add if not
43 S DA=$O(^IBAM(354.7,DFN,1,"B",IBDT,0))
44 I 'DA S DIC="^IBAM(354.7,"_DFN_",1,",DIC(0)="",X=IBDT D FILE^DICN S DA=+Y
45 ;
46 ; now edit and add the new amount
47 S IBA=^IBAM(354.7,DFN,1,DA,0)
48 S:'$D(IBS) IBB=IBB+$P(IBA,"^",2),IBU=IBU+$P(IBA,"^",4)
49 L +^IBAM(354.7,DFN):10 I '$T Q
50 S DIE="^IBAM(354.7,"_DFN_",1,",DR=".02///^S X=IBB;.04///^S X=IBU"
51 D ^DIE L -^IBAM(354.7,DFN)
52 ;
53 D FLAG^IBARXMC(DFN,IBDT)
54 ;
55 Q
56 ;
57UPCHG(IBX,IBU,IBC) ; update a charge (from one that is on hold only)
58 ; IBX = ien in 354.71
59 ; IBU = updated # of units
60 ; IBC = updated charge amount
61 N IBO,IBY,DIE,DA,DR
62 W !,"Updating copay cap account records..."
63 S IBO=^IBAM(354.71,IBX,0)
64 ;
65 ; first update 354.71 entry
66 S DIE="^IBAM(354.71,",DA=IBX,DR=".07///^S X=IBU;.08///^S X=IBC;.11///^S X=IBC;.05///P"
67 L +^IBAM(354.71,DA):10 I '$T W !!,"Unable to update records, entry locked!!" Q
68 D ^DIE L -^IBAM(354.71,DA)
69 ;
70 ; now update account
71 D ACCT($P(IBO,"^",2),IBC-$P(IBO,"^",11),0,$P(IBO,"^",3))
72 ;
73 ; send to IDX
74 I $$SWSTAT^IBBAPI S IBO=$$QUEUE^VDEFQM("DFT^P03","SUBTYPE=CPIN^IEN="_IBX,,"PFSS OUTBOUND")
75 ;
76 ; finally clean transmission record
77 D CLEAN(IBX)
78 ;
79 Q
80CLEAN(IBX) ; clean out transmission record
81 N IBA,DA,DIK,X,Y
82 S IBA=0 F S IBA=$O(^IBAM(354.71,IBX,1,IBA)) Q:IBA<1 S DA=IBA,DA(1)=IBX,DIK="^IBAM(354.71,"_IBX_",1," D ^DIK
83 Q
84 ;
85CANCEL(DFN,IBX,IBY,IBR) ; cancel a transaction (flags old one and creates a new one)
86 ; IBX is the ien from 354.71, IBY is the error flag (y) passed by ref
87 ; IBR is optional, it is the reason to cancel
88 ;
89 N IBN,IBD,DIE,DA,DR,X,Y
90 ;
91 ; is IBX there or is this an old transaction
92 S IBD=$G(^IBAM(354.71,+IBX,0)) I 'IBD S IBN=0 G CANQ
93 S IBAMP=$P($G(^IBAM(354.71,+$P(IBD,"^",10),0)),"^")
94 ;
95 ; set flag for at or above cap
96 S:'$D(IBCAP) IBCAP=+$P($G(^IBAM(354.7,DFN,1,+$O(^IBAM(354.7,DFN,1,"B",$E($P(IBD,"^",3),1,5)_"00",0)),0)),"^",3)
97 ;
98 ; flag old one as canceled, and clean out transmission record.
99 S DIE="^IBAM(354.71,",DA=IBX,DR=".05///Y;.16///"_DUZ_";.17///"_$$NOW^XLFDT_";.19///"_$S($D(IBR):IBR,1:16)
100 L +^IBAM(354.71,IBX):5 I '$T S IBY="-1^IB318",IBN=0 G CANQ
101 D ^DIE L -^IBAM(354.71,IBX)
102 D CLEAN(IBX)
103 ;
104 ; send to IDX
105 I $$SWSTAT^IBBAPI S IBO=$$QUEUE^VDEFQM("DFT^P03","SUBTYPE=CPIN^IEN="_IBX,,"PFSS OUTBOUND")
106 ;
107 ; now create new transaction to adjust amounts
108 ; first set up parent, clear out .01, set facility, - dollar amt, status
109 S $P(IBD,"^",10)=$P(IBD,"^"),$P(IBD,"^")="",$P(IBD,"^",13)=+$P($$FAC^IBARXMU(+$$SITE^IBARXMU),"^",2),$P(IBD,"^",11)=-$P(IBD,"^",11),$P(IBD,"^",12)=-$P(IBD,"^",12),$P(IBD,"^",5)="P"
110 S IBN=$$ADD(DFN,$P(IBD,"^",1,13)) I IBN<1 S IBY="-1^IB316"
111 ;
112 ; set up variable to check for cap and re-bill if necessary
113 S IBCAP($E($P(IBD,"^",3),1,5)_"00")=""
114 ;
115 ; now check to see if the patient has previously reached cap and has some unbilled (only if not updating, check for flag)
116 ;I '$G(IBUPDATE) D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
117 ;D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
118 ;
119CANQ Q IBN
120 ;
121ADD(DFN,IBD,IBT,IBPFSS) ; adds a transaction to 354.71
122 ; IBD = data in 354.71 format, if $p(IBD,"^")="" create new number
123 ; IBT = action type pointer (optional, but needed for local site)
124 ; returns ien in 354.71
125 ; IBPFSS optional to indicate came from PFSS system
126 ;
127 N IBA,DIC,X,IBS,IBN
128 Q:'$G(DFN)
129 D ADD^IBARXMU(DFN)
130 I $P(IBD,"^") S IBA=$O(^IBAM(354.71,"B",$P(IBD,"^"),0)) D Q IBA
131 . ;I IBA D TRANF(DFN,IBA,IBD,$G(IBT)) Q
132 . I 'IBA S DIC="^IBAM(354.71,",DIC(0)="",X=$P(IBD,"^") D FILE^DICN S IBA=+Y
133 . I IBA>0 D TRANF(DFN,IBA,IBD,$G(IBT)),ACCT(DFN,$P(IBD,"^",11),$P(IBD,"^",12),$P(IBD,"^",3))
134 K DO S DIC="^IBAM(354.71,",DIC(0)="",IBS=+$P($$SITE^IBARXMU,"^",3)
135 ;
136 ; get next number and file
137 F L +^IBAM(354.71,0):20 I $T S IBN=$P(^IBAM(354.71,0),"^",3) S:'IBN IBN=0 Q
138 I +$G(^IBAM(354.71,+IBN,0))'=IBS,IBN F S IBN=$O(^IBAM(354.71,IBN),-1) Q:IBS=+$G(^IBAM(354.71,IBN,0))!('IBN)
139 S IBN=$P($P($G(^IBAM(354.71,+IBN,0)),"^"),"-",2)+1 F IBN=IBN:1 S X=IBS_"-"_IBN I '$D(^IBAM(354.71,"B",X)) L +^IBAM(354.71,"B",X):10 I $T D FILE^DICN L -^IBAM(354.71,"B",X) I Y>0 S IBA=+Y Q
140 L -^IBAM(354.71,0)
141 ;
142 D TRANF(DFN,IBA,IBD,$G(IBT),$G(IBPFSS)),ACCT(DFN,$P(IBD,"^",11),$P(IBD,"^",12),$P(IBD,"^",3))
143 ;I '$G(IBUPDATE) D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
144 ;
145 Q IBA
146 ;
147TRANF(DFN,IBA,IBD,IBT,IBPFSS) ; file transaction data in 354.71
148 ; DFN = patient's dfn
149 ; IBA = ien from file 354.71
150 ; IBD = data in global file format for file 354.71
151 ; piece 2 will be changed to dfn
152 ; pieces 10 and 13 will be resolved
153 ; pieces 14,15 will be created new if they don't exist
154 ; pieces 16,17 will be created new
155 ; piece 18 will be filled if not $g(IBT)=""
156 ;
157 N X,Y,IBZ,IBN,D,IBU,DIC,IBPAR,DA,DIK Q:'$D(^IBAM(354.71,IBA,0))
158 ;
159 X $S($P(IBD,"^")=$P(IBD,"^",10):"S $P(IBD,""^"",10)=IBA",1:"S X=$P(IBD,""^"",10),D=""B"",DIC=""^IBAM(354.71,"",DIC(0)=""OX"" D IX^DIC S $P(IBD,""^"",10)=$S(Y>0:+Y,1:"""")")
160 S IBPAR=$$PARENT^IBARXMC(+$P(IBD,"^",10)) S:IBPAR $P(IBD,"^",10)=IBPAR
161 S DIC="^DIC(4,",DIC(0)="O",X=$P(IBD,"^",13),D="D" D IX^DIC
162 S IBS=$S(Y>0:+Y,1:"")
163 S IBN=$$NOW^XLFDT,IBU=$P(^IBAM(354.71,IBA,0),"^",14,15)
164 ;
165 S $P(^IBAM(354.71,IBA,0),"^",2,18)=DFN_"^"_$P(IBD,"^",3,12)_"^"_IBS_"^"_$S(+IBU:+IBU,$D(IBDUZ):IBDUZ,1:DUZ)_"^"_$S($P(IBU,"^",2):$P(IBU,"^",2),1:IBN)_"^"_$S($D(IBDUZ):IBDUZ,1:DUZ)_"^"_IBN_$S($G(IBT):"^"_IBT,1:"")
166 S DA=IBA,DIK="^IBAM(354.71," D IX^DIK
167 I $$SWSTAT^IBBAPI,'$G(IBPFSS) S X=$$QUEUE^VDEFQM("DFT^P03","SUBTYPE=CPIN^IEN="_IBA,,"PFSS OUTBOUND") ; use IBA as the IEN
168 Q
Note: See TracBrowser for help on using the repository browser.