- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m
r613 r623 1 IBCECSA3 ;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 5 EN ; 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 30 LIST ; 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 83 LISTQ I $D(ZTQUEUED) S ZTREQ="@" Q 84 W ! D ^%ZISC 85 Q 86 IBPAY(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) 91 HDR1 ; 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 ; 109 RESORT ; 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 131 RES1 ; 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 ; 145 RESORTX ; 146 Q 147 ; 148 MCS ; 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" 163 MCSX ; 164 Q 165 ; 1 IBCECSA3 ;ALB/CXW - CLAIMS STATUS AWAITING RESOLUTION REPORT ;23-JUL-99 2 ;;2.0;INTEGRATED BILLING;**137,320**;21-MAR-94 3 Q 4 EN ; Report of claims status awaiting resolution 5 D FULL^VALM1 6 W !!,"You will need a 132 column printer for this report!",! 7 ; 8 N %ZIS,ZTSAVE,ZTRTN,ZTDESC 9 S %ZIS="QM" D ^%ZIS Q:POP 10 I $D(IO("Q")) K IO("Q") D Q 11 . S ZTRTN="LIST^IBCECSA3" 12 . S ZTSAVE("IBSORT1")="" 13 . S ZTSAVE("IBSORT2")="" 14 . S ZTSAVE("IBSORT3")="" 15 . S ZTSAVE("IBSORTOR")="" 16 . S ZTSAVE("^TMP(""IBCECSB"",$J,")="" 17 . S ZTDESC="IB -Claims Status Awaiting Resolution Report" D ^%ZTLOAD K ZTSK D HOME^%ZIS 18 U IO 19 LIST ; display 20 N IBSTOP,X,IBPAGE,IBX,IBDIV,IBDA,IBPAY,IB,IBZ,IBZFT,IBFST,IBX2 21 W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen 22 S (IBSTOP,IBPAGE,IBFST,IBDIV)=0 23 I IBSORT1="D" S IBDIV=1 24 I '$D(^TMP("IBCECSB",$J)) D G LISTQ 25 . D HDR1 W !,"No entries found for this report" 26 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 27 . I 'IBFST S IBPAY=$$IBPAY(IBX,IBX2,IBX3) D HDR1 S:'IBDIV IBFST=1 Q:IBSTOP 28 . 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 29 .. I ($Y+5)>IOSL D HDR1 Q:IBSTOP 30 .. W $$BN1^PRCAFN(+IB),?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),! 31 .. W " FORM TYPE: "_$P($G(^IBE(353,$P($G(^DGCR(399,+IB,0)),U,19),0)),U),! 32 .. I 'IBDIV S X=" DIVISION: "_$P(IB,U,8) W X,$J(" ",40-$L(X))_"AUTHORIZING BILLER: "_$P($P(IB,U,9),"~",1),! 33 .. W " MESSAGE TEXT: " S IBZFT=0 34 .. S IBZ=0 F S IBZ=$O(^IBM(361,IBDA,1,IBZ)) Q:'IBZ D Q:IBSTOP 35 ... W:'IBZFT ?15 S X=$G(^IBM(361,IBDA,1,IBZ,0)) 36 ... F I=1:131:$L(X) W " "_$E(X,I,I+130),! 37 ... S IBZFT=1 38 ... I ($Y+5)>IOSL D HDR1 Q:IBSTOP 39 .. W ! 40 G:IBSTOP LISTQ 41 I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR 42 LISTQ I $D(ZTQUEUED) S ZTREQ="@" Q 43 W ! D ^%ZISC 44 Q 45 IBPAY(IBX,IBX2,IBX3) ; return biller name 46 N X 47 S X=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,0)) 48 S X=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,X)) 49 Q $P($P(X,U,9),"~",1) 50 HDR1 ; 51 N DIR,Y 52 I IBPAGE D Q:IBSTOP 53 . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP 54 . W @IOF 55 S IBPAGE=IBPAGE+1 56 W !,"Sort 1: ",$$SD^IBCECSA(IBSORT1) 57 W ?46,"Claims Status Awaiting Resolution Report",?120,$J("Page: "_IBPAGE,11) 58 W !,"Sort 2: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a") 59 W ?104,$J("Run Date: "_$$HTE^XLFDT($H,"2Z"),27) 60 W !,"Sort 3: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a") 61 I IBDIV W !!,"Division: "_$S($G(IBX)=0:"",1:$G(IBX)),!,"Authorizing Biller: "_$G(IBPAY) 62 W !,?72,"Last",?78,"Date of",?88,"Location",?100,"Current",?110,"Source of",?122,"Days Msg" 63 W !,"Bill #",?13,"Payer Name",?40,"Patient Name",?72,"4 SSN",?78,"Service",?88,"of Service",?100,"Balance",?110,"Message",?122,"Pending" 64 W !,$TR($J("",132)," ","-"),! 65 Q 66 ; 67 ; 68 RESORT ; CSA screen re-sort action 69 NEW DIR,X,Y,Z,IBSAVE,VALMQUIT,IBCURR 70 D FULL^VALM1 S VALMBCK="R" 71 W !!?2,"The CSA screen is currently sorted in the following manner:" 72 W !!?9,"Primary Sort: ",$S($G(IBSORT1)'="":$$SD^IBCECSA(IBSORT1),1:"n/a") 73 W !?7,"Secondary Sort: ",$S($G(IBSORT2)'="":$$SD^IBCECSA(IBSORT2),1:"n/a") 74 W !?8,"Tertiary Sort: ",$S($G(IBSORT3)'="":$$SD^IBCECSA(IBSORT3),1:"n/a") 75 ; 76 W ! 77 S DIR(0)="Y",DIR("A")="Would you like to change the sort criteria" 78 S DIR("B")="Yes" D ^DIR K DIR 79 I 'Y G RESORTX 80 ; 81 ; save the old sort criteria 82 S IBSAVE=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3) 83 S Z="" F S Z=$O(IBSORTOR(Z)) Q:Z="" S IBSAVE=IBSAVE_U_Z_U_IBSORTOR(Z) 84 ; 85 W ! 86 K IBSORTOR 87 D SORT^IBCECSA(1,$P(IBSAVE,U,1)) I $G(VALMQUIT) G RES1 88 D SORT^IBCECSA(2) I $G(VALMQUIT) G RES1 89 I $G(IBSORT2)'="" D SORT^IBCECSA(3) I $G(VALMQUIT) G RES1 90 RES1 ; 91 I $G(IBSORT1)="" S IBSORT1=$P(IBSAVE,U,1) ; need at least one 92 ; 93 ; see if the sort criteria changed 94 S IBCURR=$G(IBSORT1)_U_$G(IBSORT2)_U_$G(IBSORT3) 95 S Z="" F S Z=$O(IBSORTOR(Z)) Q:Z="" S IBCURR=IBCURR_U_Z_U_IBSORTOR(Z) 96 I IBSAVE=IBCURR G RESORTX ; no sort changes made at all 97 ; 98 ; time to rebuild the list because sorts have changed 99 I $G(IBDAYS)="" S IBDAYS=0 100 I $G(IBSEV)="" S IBSEV="R" 101 D BLD^IBCECSA1 102 S VALMBCK="R",VALMBG=1 103 ; 104 RESORTX ; 105 Q 106 ; 107 MCS ; Link to the Multiple CSA Message Management option 108 NEW IBCSAMCS S IBCSAMCS=1 109 D FULL^VALM1 S VALMBCK="R" 110 I '$$KCHK^XUSRB("IB MESSAGE MANAGEMENT") D G MCSX 111 . W !!?5,"You must hold the IB MESSAGE MANAGEMENT key to access this option." 112 . D PAUSE^VALM1 113 . Q 114 ; 115 D ; call the MCS screen 116 . NEW IBSORT1,IBSORT2,IBSORT3,IBDAYS,IBSEV ; protect CSA vars 117 . D EN^IBCEMCL 118 . Q 119 ; 120 I $G(IBCSAMCS)=2 D BLD^IBCECSA1 S VALMBG=1 ; rebuild CSA 121 S VALMBCK="R" 122 MCSX ; 123 Q 124 ;
Note:
See TracChangeset
for help on using the changeset viewer.
