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

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

revised back to 6/30/08 version

File size: 5.7 KB
Line 
1IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;7:39 PM 30 Jan 2008
2 ;;2.0;INTEGRATED BILLING;**39,80,155,320,VWEHR1**;WorldVistA 30-Jan-08
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;Modified from FOIA VISTA,
6 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
7 ;General Public License See attached copy of the License.
8 ;
9 ;This program is free software; you can redistribute it and/or modify
10 ;it under the terms of the GNU General Public License as published by
11 ;the Free Software Foundation; either version 2 of the License, or
12 ;(at your option) any later version.
13 ;
14 ;This program is distributed in the hope that it will be useful,
15 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;GNU General Public License for more details.
18 ;
19 ;You should have received a copy of the GNU General Public License along
20 ;with this program; if not, write to the Free Software Foundation, Inc.,
21 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
22 ;
23CONT ; Continuation of Claim Information Screen Build
24 ; reason cancelled
25 I $P(IBD0,U,13)=7 D
26 . S (IBNC(1),IBTC(1))=2,(IBNC(2),IBTC(2))=0,IBNC(3)=28,IBTW(1)=29,IBTW(2)=0,IBSW(1)=49,IBSW(2)=0
27 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
28 . ;
29 . S IBGRPB=IBLN,IBLR=1
30 . K IBY D RCANC^IBJTU2(IBIFN,.IBY,50)
31 . S IBT="Reason Cancelled by ("_$P(IBY,U,3)_"): "
32 . S IBI=0 F S IBI=$O(IBY(IBI)) Q:'IBI S IBD=IBY(IBI) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
33 ;
34 S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE)
35 S (IBNC(1),IBTC(1))=2,IBTW(1)=16,IBSW(1)=50
36 S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
37 ;
38 S IBGRPB=IBLN,IBLR=1
39 ;
40 I +$P(IBDS,U,1) S IBT="Entered: ",IBD=$$EXT(IBDS,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
41 I +$P(IBDS,U,4) S IBT="Initial Review: ",IBD=$$EXT(IBDS,4,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
42 I +$P(IBDS,U,7) S IBT="MRA Request: ",IBD=$$EXT(IBDS,7,8) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
43 I +$P(IBDS,U,10) S IBT="Authorized: ",IBD=$$EXT(IBDS,10,11) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
44 I +$P(IBDS,U,12) S IBT="First Printed: ",IBD=$$EXT(IBDS,12,13) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
45 I $P(IBDS,U,14)>$P(IBDS,U,12) S IBT="Last Printed: ",IBD=$$EXT(IBDS,14,15) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
46 I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
47 ;
48 ; Patch 320 - added bill cloning history to TPJI report.
49 N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
50 S IBINDENT=0
51 D EN^IBCCR(IBIFN,.IBCCR) ; utility to pull cloning history
52 ;
53 ; attempt to go one claim forward from the current claim
54 S IBCURR="IBCCR("_+$P(IBDS,U,1)_","_IBIFN_")"
55 S IBNEXT=$Q(@IBCURR)
56 I IBNEXT'="" D
57 . N IBX S IBX=@IBNEXT
58 . S IBT="Copied: "
59 . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3)
60 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
61 . S IBT="Copied To: ",IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
62 . S IBINDENT=1
63 . Q
64 ;
65 ; now go backwards for claim cloning history all the way back
66 S IBBCH=IBCURR
67 ;
68 ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
69 ;
70 ;F S IBBCH=$Q(@IBBCH,-1) Q:IBBCH="" D
71 F S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH="" D
72 . ;
73 . ;END CHANGE
74 . ;
75 . N IBX S IBX=@IBBCH
76 . S IBT="Copied: " I IBINDENT S IBT=" "_IBT
77 . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3)
78 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
79 . S IBT="Copied From: " I IBINDENT S IBT=" "_IBT
80 . S IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
81 . S IBT="Reason Copied: " I IBINDENT S IBT=" "_IBT
82 . S IBD=$P(IBX,U,4),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
83 . S IBINDENT=1
84 . Q
85 ;
86 I $D(^DGCR(399,IBIFN,"R","AC",1)) S IBT="Returned to AR: ",X=0 F S X=$O(^DGCR(399,IBIFN,"R","AC",1,X)) Q:'X D
87 . S IBY=$G(^DGCR(399,IBIFN,"R",X,0)),IBD=$$EXT(IBY,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
88 ;
89 N IBCOB,IBX,IBY,IBI,IBJ,IBK D BCOB^IBCU3(IBIFN,.IBCOB) I $O(IBCOB(0)) D
90 . S IBTC(1)=2,IBTW(1)=12,IBSW(1)=68,IBLR=1,IBNC(1)=26
91 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
92 . S IBT="Payers and Related Bills" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
93 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
94 . S IBT="",IBD="Insurance Co. Bill # Status Original Collected Balance"
95 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
96 . S IBI=0 F S IBI=$O(IBCOB(IBI)) Q:'IBI D
97 .. S IBT=$S(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_": "
98 .. S IBJ=0 F S IBJ=$O(IBCOB(IBI,IBJ)) Q:'IBJ S IBK="" F S IBK=$O(IBCOB(IBI,IBJ,IBK)) Q:IBK="" D
99 ... S IBD="",IBY=$$BILL^RCJIBFN2(IBK)
100 ... S IBX=$P($G(^DIC(36,+IBJ,0)),U,1) S IBD=$$SLINE(IBD,IBX,0,15)
101 ... I +IBK D
102 .... S IBX=$P($G(^DGCR(399,+IBK,0)),U,1) S IBD=$$SLINE(IBD,IBX,17,10)
103 .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bill status
104 .... ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR
105 .... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1,$$MCRWNR^IBEFUNC(+IBJ) D
106 ..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & reset WNR amounts
107 .... S IBD=$$SLINE(IBD,IBX,30,3)
108 .... S IBX=$J($P(IBY,U,1),10,2) S IBD=$$SLINE(IBD,IBX,35,10)
109 .... S IBX=$J($P(IBY,U,4),10,2) S IBD=$$SLINE(IBD,IBX,46,10)
110 .... S IBX=$J($P(IBY,U,3),10,2) S IBD=$$SLINE(IBD,IBX,57,10)
111 ... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
112 Q
113 ;
114EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string
115 N X,Y S Y="",STR=$G(STR),DT=+$G(DT),USER=+$G(USER)
116 S X=$P(STR,U,DT),DT="" I +X S DT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
117 S X=$P(STR,U,USER),USER="" I +X S USER=$P($G(^VA(200,+X,0)),U,1)
118 S Y=DT_" by "_$S(USER="":"UNKNOWN",1:USER)
119 Q Y
120 ;
121SET(IBT,IBD,IBLN,IBLR) ;
122 N LN S LN=$$SET^IBJTCA1(IBT,IBD,IBLN,IBLR)
123 Q LN
124 ;
125SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields
126 S IBD=$E(IBD,1,(COL-1)),IBD=IBD_$J("",(COL-$L(IBD))),IBD=IBD_$E(DATA,1,WD)
127 Q IBD
Note: See TracBrowser for help on using the repository browser.