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

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

initial load of WorldVistAEHR

File size: 8.9 KB
Line 
1IBCEU0 ;ALB/TMP - EDI UTILITIES ;02-OCT-96
2 ;;2.0;INTEGRATED BILLING;**137,197,155,296,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5NOTECHG(IBDA,IBNTEXT) ; Enter who/when review stat change was entered
6 ; IBDA = ien of entry in file 361.1
7 ; IBNTEXT = array containing the lines of text to store if not using the
8 ; default text IBNTEXT = # of lines IBNTEXT(#)=line text
9 N IBIEN,IBTEXT,DA,X,Y,DIC,DO,DLAYGO,DD
10 S DA(1)=IBDA,DIC="^IBM(361.1,"_DA(1)_",2,",DIC(0)="L",DLAYGO=361.121
11 S X=$$NOW^XLFDT
12 D FILE^DICN K DIC,DD,DO,DLAYGO
13 Q:Y'>0
14 S DA(2)=DA(1),DA(1)=+Y,IBIEN=DA(1)_","_DA(2)_","
15 I $G(IBNTEXT) D
16 . M IBTEXT=IBNTEXT
17 E D
18 . S IBTEXT(1)="REVIEW STATUS CHANGED TO '"_$$EXTERNAL^DILFD(361.1,.2,,$P(^IBM(361.1,DA(2),0),U,20))_"' BY: "_$$EXTERNAL^DILFD(361.121,.02,,+$G(DUZ))
19 D WP^DIE(361.121,IBIEN,.03,,"IBTEXT") K ^TMP("DIERR",$J)
20 Q
21 ;
22LOCK(IBFILE,IBREC) ; Lock record # IBREC in file #IBFILE (361 or 361.1)
23 N OK
24 S OK=0
25 L +^IBM(IBFILE,IBREC):3 I $T S OK=1
26 I 'OK D
27 . W !,"Another user has locked this record - try again later"
28 . D PAUSE^VALM1
29 Q OK
30 ;
31UNLOCK(IBFILE,IBREC) ; Unlock record # IBREC in file #IBFILE
32 I $G(IBREC) L -^IBM(IBFILE,IBREC)
33 Q
34 ;
35MSTAT ; Enter reviewed by selected range
36 N IBDAX,IBA,IBCLOSE,IBLOOK,IBOK,IBSTOP,IBREBLD,IBCLOK,DA,DIR,X,Y,DIE,DR
37 D FULL^VALM1
38 D SEL^IBCECSA4(.IBDAX)
39 S IBREBLD=0
40 I $O(IBDAX(""))="" G MSTATQ
41 S DIR("?,1")="ONLY SELECT TO CLOSE THE TRANSMIT RECORDS IF YOU KNOW THESE ARE THE FINAL",DIR("?",2)=" ELECTRONIC MESSAGES YOU WILL RECEIVE FOR ALL THE BILLS REFERENCED BY",DIR("?")=" THESE MESSAGES"
42 S DIR(0)="YA",DIR("A",1)="DO YOU WANT TO AUTOMATICALLY CLOSE THE TRANSMIT RECORDS FOR ANY MESSAGES",DIR("A")=" THAT AREN'T REJECTS?: ",DIR("B")="NO" W ! D ^DIR K DIR W !
43 G:$D(DIRUT) MSTATQ
44 S IBCLOSE=(Y=1)
45 S DIR(0)="YA",DIR("A")="DO YOU WANT TO SEE EACH MESSAGE BEFORE MARKING IT REVIEWED?: ",DIR("B")="NO"
46 S DIR("?",1)="IF YOU OPT TO SEE EACH MESSAGE, YOU CAN CONTROL WHETHER OR NOT THE MESSAGE",DIR("?",2)=" IS MARKED AS REVIEWED"
47 I 'IBCLOSE S DIR("?")=DIR("?",2) K DIR("?",2)
48 I IBCLOSE S DIR("?",2)=DIR("?",2)_" AND, FOR NON-REJECTS, WHETHER OR NOT TO CLOSE THE",DIR("?")=" TRANSMIT RECORD FOR THE BILL"
49 W ! D ^DIR K DIR W !
50 G:$D(DIRUT) MSTATQ
51 S IBLOOK=(Y=1)
52 S IBDAX=0,IBSTOP=0
53 F S IBDAX=+$O(IBDAX(IBDAX)) Q:'IBDAX D Q:IBSTOP
54 . S IBA=$G(IBDAX(IBDAX))
55 . S DIE="^IBM(361,",DA=$P(IBA,U,2),DR=""
56 . I DA D
57 .. S IBOK=1
58 .. S IBCLOK=$S(IBCLOSE:1,1:0)
59 .. I IBLOOK D Q:'IBOK
60 ... S DIC="^IBM(361," D EN^DIQ
61 ... I '$$LOCK(361,DA) W ! S IBOK=0 Q
62 ... S DIR(0)="YA",DIR("A")="OK TO MARK REVIEWED?: ",DIR("B")="YES",DIR("?",1)="IF YOU ENTER YES, THIS MESSAGE WILL BE MARKED REVIEWED"
63 ... S DIR("?",2)="IF YOU ENTER NO, THIS MESSAGE WILL NOT BE ALTERED",DIR("?",3)="IF YOU ENTER AN ^, THIS MESSAGE WILL NOT BE ALTERED & NONE OF THE",DIR("?")=" REMAINING MESSAGES WILL BE PROCESSED" D ^DIR K DIR
64 ... I Y'>0 S IBOK=0 S:$D(DIRUT) IBSTOP=1 Q
65 ... I 'IBCLOSE D
66 .... S DIR(0)="YA",DIR("A")="OK TO CLOSE THIS BILL'S TRANSMIT RECORD?: ",DIR("B")="NO"
67 .... S DIR("?",1)="If you respond YES to this prompt, the transmit status of this bill will",DIR("?",2)=" be set to CLOSED. No further electronic processing of this bill will be"
68 .... S DIR("?",3)=" allowed. If you respond NO to this prompt, this electronic message will",DIR("?",4)=" be filed as reviewed, but the bill's transmit status will not be changed."
69 .... S DIR("?",5)=" You may wish to periodically print a list of bills with a non-final",DIR("?",6)=" (closed/cancelled/etc) status to ensure the electronic processing of all"
70 .... S DIR("?",7)=" bills has been completed. Closing the transmit bill record here will",DIR("?")=" eliminate the bill from this list."
71 .... W ! D ^DIR K DIR W !
72 .... I Y'=1 S IBCLOK=0
73 .. I 'IBLOOK,$P($G(^IBM(361,DA,0)),U,3)="R" D Q:'IBOK
74 ... S DR="1",DIC="^IBM(361," D EN^DIQ W !,"Bill Number: ",$$EXPAND^IBTRE(361,.01,+^IBM(361,DA,0))
75 ... S DIR(0)="YA",DIR("A")="THIS IS A REJECTION ... ARE YOU SURE YOU WANT TO MARK IT REVIEWED?: ",DIR("B")="NO"
76 ... S DIR("?",1)="IF YOU ENTER YES, THIS MESSAGE WILL BE MARKED REVIEWED"
77 ... S DIR("?",2)="IF YOU ENTER NO, THIS MESSAGE WILL NOT BE ALTERED",DIR("?",3)="IF YOU ENTER AN ^, THIS MESSAGE WILL NOT BE ALTERED & NONE OF THE",DIR("?")=" MESSAGES FOLLOWING THIS ONE WILL BE PROCESSED" D ^DIR K DIR
78 ... I Y'=1 S IBOK=0 S:$D(DIRUT) IBSTOP=1
79 .. S:'IBREBLD IBREBLD=1
80 .. S DR=".09////2;.1////F" D ^DIE
81 .. N IBUPD
82 .. S IBUPD=0
83 .. I $$PRINTUPD($G(^IBM(361,DA,1,1,0)),+$P(^IBM(361,DA,0),U,11)) S IBUPD=1
84 .. I $G(^IBM(361,DA,1,1,0))["CLAIM SENT TO PAYER" D UPDTX^IBCECSA2(+$P(^IBM(361,DA,0),U,11),$S(IBCLOK:"Z",1:"A2")) S IBUPD=1
85 .. I $G(^IBM(361,DA,1,1,0))["CLAIM REJECTED" D UPDTX^IBCECSA2(+$P(^IBM(361,DA,0),U,11),"E") S IBUPD=1
86 .. I IBCLOK,'IBUPD D UPDTX^IBCECSA2(+$P(^IBM(361,DA,0),U,11),"Z")
87 .. I 'IBLOOK D
88 ... W !,"Seq #: ",IBDAX," Bill number: ",$$EXPAND^IBTRE(361,.01,+^IBM(361,DA,0)),?45,"REVIEWED"
89 .. D NOTECHG^IBCECSA2(DA,1)
90 .. D UNLOCK(361,DA)
91 W !!,"LAST SELECTION PROCESSED",!
92 D PAUSE^VALM1
93MSTATQ S VALMBCK="R"
94 I IBREBLD D BLD^IBCECSA1
95 Q
96 ;
97PRPAY(IBIFN,IBMCR) ; Returns total amount of prior payments applied to
98 ; bill ien IBIFN
99 ; IBMCR = flag passed in as 1 if MRA total should be included
100 ;
101 N IBTOT,IBZ,IBSEQ
102 S IBSEQ=$$COBN^IBCEF(IBIFN)
103 I IBSEQ'>1 S IBTOT=0 G PRPAYQ
104 D F^IBCEF("N-PRIOR PAYMENTS","IBZ",,IBIFN)
105 S IBTOT=IBZ
106 I $G(IBMCR),$$MCRONBIL^IBEFUNC(IBIFN)=1 D ; MCR on bill before curr ins
107 . N Z,Z0,Z2,Q
108 . F Z=1:1:IBSEQ-1 I $$WNRBILL^IBEFUNC(IBIFN,Z) D
109 .. S IBTOT=+$$MCRPAY(IBIFN)
110PRPAYQ Q IBTOT
111 ;
112PRINTUPD(IBTEXT,IBDA) ; If the status message indicates claim was printed
113 ; or the claim record in file 399 says it was, update the transmit
114 ; message status to closed
115 ; IBTEXT = the first line text of the status message (optional)
116 ; IBDA = the ien of the transmission record in file 364
117 ;
118 ; FUNCTION returns 1 if message status changed
119 ;
120 N IBP,IBP1
121 S IBP=0,IBP1=$P($G(^DGCR(399,+$G(^IBA(364,+$G(IBDA),0)),"TX")),U,7)
122 I $G(IBTEXT)["CLAIM RECEIVED, PRINTED AND MAILED BY PRINT CENTER"!IBP1 D
123 . N Z
124 . S Z=$E($P($G(^IBA(364,IBDA,0)),U,3),1)
125 . I "AP"'[Z Q ; Only change if status is pending or received/accepted
126 . D UPDTX^IBCECSA2(IBDA,"Z") S IBP=1
127 Q IBP
128 ;
129MCRPAY(IBIFN) ; Calculate MRA total for the bill IBIFN
130 N IBPAY,Q,Z0
131 S IBPAY=0
132 S Q=0 F S Q=$O(^IBM(361.1,"B",IBIFN,Q)) Q:'Q S Z0=$G(^IBM(361.1,Q,0)) I $P(Z0,U,4)=1 S IBPAY=IBPAY+$G(^(1))
133 Q IBPAY
134 ;
135PREOBTOT(IBIFN) ; Function - Calculates Patient Responsibility Amount
136 ; Input: IBIFN - ien of Bill Number (ien of file 399)
137 ; Output Function returns: Patient Responsibility Amount for all EOB's for bill
138 ;
139 N FRMTYP,IBPTRES
140 S IBPTRES=0
141 ; Form Type 2=CMS-1500; 3=UB-04
142 S FRMTYP=$$FT^IBCEF(IBIFN)
143 ;
144 ; For bills w/CMS-1500 Form Type, total up Pt Resp amount from top
145 ; level of EOB (field 1.02) for All MRA type EOB's on file for that
146 ; bill (IBIFN)
147 ;
148 I FRMTYP=2 D Q IBPTRES
149 . N IBEOB,EOBREC,EOBREC1,IBPRTOT
150 . S (IBEOB,IBPRTOT,IBPTRES)=0
151 . F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D ;
152 . . S EOBREC=$G(^IBM(361.1,IBEOB,0)),EOBREC1=$G(^(1))
153 . . I $P(EOBREC,U,4)'=1 Q ;make sure it's an MRA
154 . . ; Total up Pt Resp Amounts on all valid MRA's
155 . . S IBPTRES=IBPTRES+$P(EOBREC1,U,2)
156 ;
157 ; For bills w/UB-04 Form Type, loop through all EOB's and sum up amounts
158 ; on both Line level and on Claim level
159 N EOBADJ,IBEOB,LNLVL
160 S IBEOB=0
161 F S IBEOB=$O(^IBM(361.1,"B",IBIFN,IBEOB)) Q:'IBEOB D ;
162 . I $P($G(^IBM(361.1,IBEOB,0)),U,4)'=1 Q ; must be an MRA
163 . ;
164 . ; get claim level adjustments
165 . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,10)
166 . S IBPTRES=IBPTRES+$$CALCPR(.EOBADJ)
167 . ;
168 . ; get line level adjustments
169 . S LNLVL=0
170 . F S LNLVL=$O(^IBM(361.1,IBEOB,15,LNLVL)) Q:'LNLVL D ;
171 . . K EOBADJ M EOBADJ=^IBM(361.1,IBEOB,15,LNLVL,1)
172 . . S IBPTRES=IBPTRES+$$CALCPR(.EOBADJ)
173 Q IBPTRES
174 ;
175CALCPR(EOBADJ) ; Function - Calculate Patient Responsibilty Amount
176 ; For Group Code PR; Ignore the PR-AAA kludge
177 ; Input - EOBADJ = Array of Group Codes & Reason Codes from either the Claim
178 ; Level (10) or Service Line Level (15) of EOB file (#361.1)
179 ; Output - Function returns Patient Responsibility Amount
180 ;
181 N GRPLVL,RSNCD,RSNAMT,PTRESP
182 S (GRPLVL,PTRESP)=0
183 F S GRPLVL=$O(EOBADJ(GRPLVL)) Q:'GRPLVL D
184 . I $P($G(EOBADJ(GRPLVL,0)),U)'="PR" Q ;grp code must be PR
185 . S RSNCD=0
186 . F S RSNCD=$O(EOBADJ(GRPLVL,1,RSNCD)) Q:'RSNCD D
187 . . I $P($G(EOBADJ(GRPLVL,1,RSNCD,0)),U,1)="AAA" Q ; ignore PR-AAA
188 . . S RSNAMT=$P($G(EOBADJ(GRPLVL,1,RSNCD,0)),U,2)
189 . . S PTRESP=PTRESP+RSNAMT
190 Q PTRESP
191 ;
192COBMOD(IBXSAVE,IBXDATA,SEQ) ; output the modifiers from the COB
193 ; SEQ is which modifier we're extracting (1-4)
194 ; Build IBXDATA(line#)=Modifier# SEQ
195 NEW LN,N,Z,MOD,LNSEQ
196 KILL IBXDATA
197 I '$G(SEQ) Q
198 S (LN,LNSEQ)=0
199 F S LN=$O(IBXSAVE("LCOB",LN)) Q:'LN D
200 . S LNSEQ=LNSEQ+1
201 . S (N,Z)=0
202 . F S Z=$O(IBXSAVE("LCOB",LN,"COBMOD",Z)) Q:'Z D
203 .. S N=N+1
204 .. S MOD(LNSEQ,N)=$P($G(IBXSAVE("LCOB",LN,"COBMOD",Z,0)),U,1)
205 .. Q
206 . S MOD=$G(MOD(LNSEQ,SEQ))
207 . I MOD'="" S IBXDATA(LNSEQ)=MOD
208 . Q
209 Q
210 ;
Note: See TracBrowser for help on using the repository browser.