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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.2 KB
Line 
1IBCECSA3 ;ALB/CXW - CLAIMS STATUS AWAITING RESOLUTION REPORT ;23-JUL-99
2 ;;2.0;INTEGRATED BILLING;**137,320,371,377**;21-MAR-94;Build 23
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5EN ; Report of claims status awaiting resolution
6 NEW %ZIS,ZTSAVE,ZTRTN,ZTDESC,DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBRVW
7 ;
8 D FULL^VALM1
9 W !
10 S DIR(0)="YO" ; IB*2*377 new question
11 S DIR("A")="Would you like to include Review Comments with this report"
12 S DIR("B")="No"
13 D ^DIR K DIR
14 I $D(DIRUT) Q
15 S IBRVW=Y
16 ;
17 W !!,"You will need a 132 column printer for this report!",!
18 ;
19 S %ZIS="QM" D ^%ZIS Q:POP
20 I $D(IO("Q")) K IO("Q") D Q
21 . S ZTRTN="LIST^IBCECSA3"
22 . S ZTSAVE("IBSORT1")=""
23 . S ZTSAVE("IBSORT2")=""
24 . S ZTSAVE("IBSORT3")=""
25 . S ZTSAVE("IBSORTOR")=""
26 . S ZTSAVE("^TMP(""IBCECSB"",$J,")=""
27 . S ZTSAVE("IBRVW")=""
28 . S ZTDESC="IB -Claims Status Awaiting Resolution Report" D ^%ZTLOAD K ZTSK D HOME^%ZIS
29 U IO
30LIST ; display
31 N IBSTOP,X,IBPAGE,IBX,IBDIV,IBDA,IBPAY,IB,IBZ,IBZFT,IBFST,IBX2
32 W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen
33 S (IBSTOP,IBPAGE,IBFST,IBDIV)=0
34 I IBSORT1="D" S IBDIV=1
35 I '$D(^TMP("IBCECSB",$J)) D G LISTQ
36 . D HDR1 W !,"No entries found for this report"
37 S IBX="" F S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP S IBX2="" F S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP S IBX3="" F S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP D Q:IBSTOP
38 . I 'IBFST S IBPAY=$$IBPAY(IBX,IBX2,IBX3) D HDR1 S:'IBDIV IBFST=1 Q:IBSTOP
39 . S IBDA=0 F S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D Q:IBSTOP
40 .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP
41 .. W $$BN1^PRCAFN(+IB),$P(IB,U,12),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),!
42 .. I $P(IB,U,12)="*" W " ***** CSA REVIEW IN PROCESS *****",!
43 .. W " FORM TYPE: "_$P($G(^IBE(353,$P($G(^DGCR(399,+IB,0)),U,19),0)),U),!
44 .. I 'IBDIV S X=" DIVISION: "_$P(IB,U,8) W X,$J(" ",40-$L(X))_"AUTHORIZING BILLER: "_$P($P(IB,U,9),"~",1),!
45 .. W " MESSAGE TEXT: " S IBZFT=0
46 .. S IBZ=0 F S IBZ=$O(^IBM(361,IBDA,1,IBZ)) Q:'IBZ D Q:IBSTOP
47 ... W:'IBZFT ?15 S X=$G(^IBM(361,IBDA,1,IBZ,0))
48 ... F I=1:131:$L(X) W " "_$E(X,I,I+130),!
49 ... S IBZFT=1
50 ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
51 ... Q
52 .. Q:IBSTOP
53 .. ;
54 .. ; Display the Review Comments if they exist based on user choice (IB*377)
55 .. I $G(IBRVW),+$O(^IBM(361,IBDA,2,0)) D Q:IBSTOP
56 ... N IBCM,IBT1,IBT0,IBD0,IBCL
57 ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
58 ... W ?3,"*** Review Comments for Claim "_$$BN1^PRCAFN(+IB)_" ***",!
59 ... S IBCM=0 F IBT1=0:1 S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM ; count up # of comments
60 ... S IBT0=0
61 ... S IBCM=0 F S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM!IBSTOP D Q:IBSTOP
62 .... S IBT0=IBT0+1
63 .... S IBD0=$G(^IBM(361,IBDA,2,IBCM,0))
64 .... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
65 .... W ?7,"Entered "_$$FMTE^XLFDT($P(IBD0,U,1),"5ZPM")
66 .... I $P(IBD0,U,2) W " by "_$P($G(^VA(200,$P(IBD0,U,2),0)),U,1)
67 .... W " ("_IBT0_" of "_IBT1_")",!
68 .... S IBCL=0 F S IBCL=$O(^IBM(361,IBDA,2,IBCM,1,IBCL)) Q:'IBCL!IBSTOP D Q:IBSTOP
69 ..... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
70 ..... W ?10,$G(^IBM(361,IBDA,2,IBCM,1,IBCL,0)),!
71 ..... Q
72 .... Q
73 ... Q
74 .. ;
75 .. ; Display a line break before the next claim in this report
76 .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP
77 .. W !
78 .. Q
79 . Q
80 ;
81 G:IBSTOP LISTQ
82 I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR
83LISTQ I $D(ZTQUEUED) S ZTREQ="@" Q
84 W ! D ^%ZISC
85 Q
86IBPAY(IBX,IBX2,IBX3) ; return biller name
87 N X
88 S X=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,0))
89 S X=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,X))
90 Q $P($P(X,U,9),"~",1)
91HDR1 ;
92 N DIR,Y
93 I IBPAGE D Q:IBSTOP
94 . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP
95 . W @IOF
96 S IBPAGE=IBPAGE+1
97 W !,"Sort 1: ",$$SD^IBCECSA(IBSORT1)
98 W ?46,"Claims Status Awaiting Resolution Report",?120,$J("Page: "_IBPAGE,11)
99 W !,"Sort 2: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a")
100 W ?104,$J("Run Date: "_$$HTE^XLFDT($H,"2Z"),27)
101 W !,"Sort 3: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a")
102 I IBDIV W !!,"Division: "_$S($G(IBX)=0:"",1:$G(IBX)),!,"Authorizing Biller: "_$G(IBPAY)
103 W !,?72,"Last",?78,"Date of",?88,"Location",?100,"Current",?110,"Source of",?122,"Days Msg"
104 W !,"Bill #",?13,"Payer Name",?40,"Patient Name",?72,"4 SSN",?78,"Service",?88,"of Service",?100,"Balance",?110,"Message",?122,"Pending"
105 W !,$TR($J("",132)," ","-"),!
106 Q
107 ;
108 ;
109RESORT ; CSA screen re-sort action
110 NEW DIR,X,Y,Z,IBSAVE,VALMQUIT,IBCURR
111 D FULL^VALM1 S VALMBCK="R"
112 W !!?2,"The CSA screen is currently sorted in the following manner:"
113 W !!?9,"Primary Sort: ",$S($G(IBSORT1)'="":$$SD^IBCECSA(IBSORT1),1:"n/a")
114 W !?7,"Secondary Sort: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a")
115 W !?8,"Tertiary Sort: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a")
116 ;
117 W !
118 S DIR(0)="Y",DIR("A")="Would you like to change the sort criteria"
119 S DIR("B")="Yes" D ^DIR K DIR
120 I 'Y G RESORTX
121 ;
122 ; save the old sort criteria
123 S IBSAVE=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3)
124 S Z="" F S Z=$O(IBSORTOR(Z)) Q:Z="" S IBSAVE=IBSAVE_U_Z_U_IBSORTOR(Z)
125 ;
126 W !
127 K IBSORTOR
128 D SORT^IBCECSA(1,$P(IBSAVE,U,1)) I $G(VALMQUIT) G RES1
129 D SORT^IBCECSA(2) I $G(VALMQUIT) G RES1
130 I $G(IBSORT2)'="" D SORT^IBCECSA(3) I $G(VALMQUIT) G RES1
131RES1 ;
132 I $G(IBSORT1)="" S IBSORT1=$P(IBSAVE,U,1) ; need at least one
133 ;
134 ; see if the sort criteria changed
135 S IBCURR=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3)
136 S Z="" F S Z=$O(IBSORTOR(Z)) Q:Z="" S IBCURR=IBCURR_U_Z_U_IBSORTOR(Z)
137 I IBSAVE=IBCURR G RESORTX ; no sort changes made at all
138 ;
139 ; time to rebuild the list because sorts have changed
140 I $G(IBDAYS)="" S IBDAYS=0
141 I $G(IBSEV)="" S IBSEV="R"
142 D BLD^IBCECSA1
143 S VALMBCK="R",VALMBG=1
144 ;
145RESORTX ;
146 Q
147 ;
148MCS ; Link to the Multiple CSA Message Management option
149 NEW IBCSAMCS S IBCSAMCS=1
150 D FULL^VALM1 S VALMBCK="R"
151 I '$$KCHK^XUSRB("IB MESSAGE MANAGEMENT") D G MCSX
152 . W !!?5,"You must hold the IB MESSAGE MANAGEMENT key to access this option."
153 . D PAUSE^VALM1
154 . Q
155 ;
156 D ; call the MCS screen
157 . NEW IBSORT1,IBSORT2,IBSORT3,IBDAYS,IBSEV ; protect CSA vars
158 . D EN^IBCEMCL
159 . Q
160 ;
161 I $G(IBCSAMCS)=2 D BLD^IBCECSA1 S VALMBG=1 ; rebuild CSA
162 S VALMBCK="R"
163MCSX ;
164 Q
165 ;
Note: See TracBrowser for help on using the repository browser.