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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.7 KB
Line 
1IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;16-FEB-1995
2 ;;2.0;INTEGRATED BILLING;**39,80,155,320**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CONT ; Continuation of Claim Information Screen Build
6 ; reason cancelled
7 I $P(IBD0,U,13)=7 D
8 . 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
9 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
10 . ;
11 . S IBGRPB=IBLN,IBLR=1
12 . K IBY D RCANC^IBJTU2(IBIFN,.IBY,50)
13 . S IBT="Reason Cancelled by ("_$P(IBY,U,3)_"): "
14 . S IBI=0 F S IBI=$O(IBY(IBI)) Q:'IBI S IBD=IBY(IBI) S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
15 ;
16 S (IBLN,VALMCNT)=$S(IBLN>IBGRPE:IBLN,1:IBGRPE)
17 S (IBNC(1),IBTC(1))=2,IBTW(1)=16,IBSW(1)=50
18 S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
19 ;
20 S IBGRPB=IBLN,IBLR=1
21 ;
22 I +$P(IBDS,U,1) S IBT="Entered: ",IBD=$$EXT(IBDS,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
23 I +$P(IBDS,U,4) S IBT="Initial Review: ",IBD=$$EXT(IBDS,4,5) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
24 I +$P(IBDS,U,7) S IBT="MRA Request: ",IBD=$$EXT(IBDS,7,8) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
25 I +$P(IBDS,U,10) S IBT="Authorized: ",IBD=$$EXT(IBDS,10,11) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
26 I +$P(IBDS,U,12) S IBT="First Printed: ",IBD=$$EXT(IBDS,12,13) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
27 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)
28 I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
29 ;
30 ; Patch 320 - added bill cloning history to TPJI report.
31 N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
32 S IBINDENT=0
33 D EN^IBCCR(IBIFN,.IBCCR) ; utility to pull cloning history
34 ;
35 ; attempt to go one claim forward from the current claim
36 S IBCURR="IBCCR("_+$P(IBDS,U,1)_","_IBIFN_")"
37 S IBNEXT=$Q(@IBCURR)
38 I IBNEXT'="" D
39 . N IBX S IBX=@IBNEXT
40 . S IBT="Copied: "
41 . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3)
42 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
43 . S IBT="Copied To: ",IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
44 . S IBINDENT=1
45 . Q
46 ;
47 ; now go backwards for claim cloning history all the way back
48 S IBBCH=IBCURR
49 F S IBBCH=$Q(@IBBCH,-1) Q:IBBCH="" D
50 . N IBX S IBX=@IBBCH
51 . S IBT="Copied: " I IBINDENT S IBT=" "_IBT
52 . S IBD=$$FMTE^XLFDT($P(IBX,U,1),"2Z")_" by "_$P(IBX,U,3)
53 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
54 . S IBT="Copied From: " I IBINDENT S IBT=" "_IBT
55 . S IBD=$P(IBX,U,2),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
56 . S IBT="Reason Copied: " I IBINDENT S IBT=" "_IBT
57 . S IBD=$P(IBX,U,4),IBLN=$$SET(IBT,IBD,IBLN,IBLR)
58 . S IBINDENT=1
59 . Q
60 ;
61 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
62 . S IBY=$G(^DGCR(399,IBIFN,"R",X,0)),IBD=$$EXT(IBY,1,2) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
63 ;
64 N IBCOB,IBX,IBY,IBI,IBJ,IBK D BCOB^IBCU3(IBIFN,.IBCOB) I $O(IBCOB(0)) D
65 . S IBTC(1)=2,IBTW(1)=12,IBSW(1)=68,IBLR=1,IBNC(1)=26
66 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
67 . S IBT="Payers and Related Bills" S IBLN=$$SETN^IBJTCA1(IBT,IBLN,IBLR,1)
68 . S (IBT,IBD)="" S IBLN=$$SET(IBT,IBD,IBLN,1)
69 . S IBT="",IBD="Insurance Co. Bill # Status Original Collected Balance"
70 . S IBLN=$$SET(IBT,IBD,IBLN,IBLR) D CNTRL^VALM10(IBLN-1,(IBTC(1)+IBTW(1)),IBSW(1),IOUON,IOUOFF)
71 . S IBI=0 F S IBI=$O(IBCOB(IBI)) Q:'IBI D
72 .. S IBT=$S(IBI=1:"Primary",IBI=2:"Secondary",IBI=3:"Tertiary",1:"Other")_": "
73 .. 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
74 ... S IBD="",IBY=$$BILL^RCJIBFN2(IBK)
75 ... S IBX=$P($G(^DIC(36,+IBJ,0)),U,1) S IBD=$$SLINE(IBD,IBX,0,15)
76 ... I +IBK D
77 .... S IBX=$P($G(^DGCR(399,+IBK,0)),U,1) S IBD=$$SLINE(IBD,IBX,17,10)
78 .... S IBX=$P($$STNO^RCJIBFN2(+$P(IBY,U,2)),U,2) ;bill status
79 .... ; if MRA active & bill pyr seq >1 & dsply'g prmry & prmry ins is WNR
80 .... I $$EDIACTV^IBCEF4(2),$$COBN^IBCEF(+IBK)>1,IBI=1,$$MCRWNR^IBEFUNC(+IBJ) D
81 ..... S IBX=" ",IBY="0^^0^0^0" ;blank out status & reset WNR amounts
82 .... S IBD=$$SLINE(IBD,IBX,30,3)
83 .... S IBX=$J($P(IBY,U,1),10,2) S IBD=$$SLINE(IBD,IBX,35,10)
84 .... S IBX=$J($P(IBY,U,4),10,2) S IBD=$$SLINE(IBD,IBX,46,10)
85 .... S IBX=$J($P(IBY,U,3),10,2) S IBD=$$SLINE(IBD,IBX,57,10)
86 ... S IBLN=$$SET(IBT,IBD,IBLN,IBLR),IBT=""
87 Q
88 ;
89EXT(STR,DT,USER) ; returns external form of user and date, given their position in the string
90 N X,Y S Y="",STR=$G(STR),DT=+$G(DT),USER=+$G(USER)
91 S X=$P(STR,U,DT),DT="" I +X S DT=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
92 S X=$P(STR,U,USER),USER="" I +X S USER=$P($G(^VA(200,+X,0)),U,1)
93 S Y=DT_" by "_$S(USER="":"UNKNOWN",1:USER)
94 Q Y
95 ;
96SET(IBT,IBD,IBLN,IBLR) ;
97 N LN S LN=$$SET^IBJTCA1(IBT,IBD,IBLN,IBLR)
98 Q LN
99 ;
100SLINE(IBD,DATA,COL,WD) ; format a single line with multiple data fields
101 S IBD=$E(IBD,1,(COL-1)),IBD=IBD_$J("",(COL-$L(IBD))),IBD=IBD_$E(DATA,1,WD)
102 Q IBD
Note: See TracBrowser for help on using the repository browser.