source: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL6.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1RCDPEWL6 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;18-MAR-03
2 ;;4.5;Accounts Receivable;**173,208,222**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6DISTADJ ; Distribute an adjustment that retracts a payment to other bill(s)
7 ; NOTE: RCSCR is assumed to be the IEN of the ERA entry in file 344.49
8 N RCDA,RCDA1,RCAMT,RCADJ,RCQUIT,Z,Z0,Z1,DIR,X,Y,CT,RCZ,RCZ1,RCZ2,RCADJOK,TOT,DTOUT,DUOUT
9 D FULL^VALM1
10 I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G DISTQ
11 I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL G DISTQ
12 ;
13 S Z=0,RCADJOK="" F S Z=$O(^TMP("RCDPE-EOB_WLDX",$J,Z)) Q:'Z S Z1=+$P($G(^(Z)),U,2),Z0=$G(^RCY(344.49,RCSCR,1,Z1,0)) D
14 . ;(^RCY(344.49,RCSCR,1,Z)) Q:'Z S Z0=$G(^(Z,0)) D
15 . I $P(Z0,U)'["." S RCADJOK=($P(Z0,U,2)["**ADJ") Q
16 . I '$P(Z0,U,7),'RCADJOK Q ; Suspense item cannot be used to adjust
17 . I $P(Z0,U,6)<0 S RCZ(Z)=$P(Z0,U,6)_U_Z1 Q
18 . I $P(Z0,U,6)>0 D Q
19 .. N Q,ONHLD,IBA
20 .. S ONHLD=0
21 .. I $P(Z0,U,7) I $$IB^IBRUTL(+$P(Z0,U,7),1) S Q=0 F S Q=$O(IBA(Q)) Q:'Q I $P($G(^IB(+IBA(Q),0)),U,5)=8 S ONHLD=1 Q
22 .. S RCZ1(+$P(Z0,U,6),Z)=Z1_U_ONHLD,RCZ2(Z)=Z1_U_$P(Z0,U,6)_U_ONHLD Q
23 ;
24 I $O(RCZ(0))="" D G DISTQ
25 . S DIR(0)="EA",DIR("A",1)="NO LINES EXIST NEEDING ADJUSTMENT DISTRIBUTION",DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
26 ;
27 I $O(RCZ1(0))="" D G DISTQ
28 . S DIR(0)="EA",DIR("A",1)="NO VALID LINES EXIST ON THIS ERA WHERE A DISTRIBUTION CAN BE MADE",DIR("A",2)=$$WHAT(RCSCR),DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
29 ;
30 S RCQUIT=0
31 F S DIR(0)="NA^1:9999:3",DIR("A")="SELECT A LINE THAT NEEDS AN ADJUSTMENT AMOUNT DISTRIBUTED: " D Q:RCQUIT
32 . S DIR("?",1)="THE FOLLOWING LINE(S) HAVE AN ADJUSTMENT THAT CAUSED A NEGATIVE NET PAYMENT.",DIR("?",2)="IN ORDER TO BALANCE THE RECEIPT AND THE DEPOSIT, THESE AMOUNTS WILL NEED TO",DIR("?",3)=" BE DISTRIBUTED TO OTHER LINE(S)",CT=3
33 . S Z=0
34 . F S Z=$O(RCZ(Z)) Q:'Z S CT=CT+1,DIR("?",CT)=" "_$J(Z,8)_" "_$J($P(RCZ(Z),U),15,2)
35 . S DIR("?")=" "
36 . I $O(RCZ(0))=$O(RCZ(""),-1) S DIR("B")=$O(RCZ(0))
37 . W ! D ^DIR K DIR
38 . I $D(DUOUT)!$D(DTOUT)!(Y="") S RCQUIT=1,RCDA="" Q
39 . I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !,"THIS LINE DOES NOT EXIST FOR THIS ERA" W ! Q
40 . I '$D(RCZ(Y)) D Q:Y=""
41 .. I Y'[".",$D(RCZ(Y_".001")),$O(RCZ(Y+1),-1)=(Y_".001") S Y=Y_".001" Q
42 .. W !,$S(Y["."!($O(RCZ(Y))\1'=(Y\1)):"THIS LINE DOESN'T NEED AN ADJUSTMENT DISTRIBUTION",1:"PLEASE ENTER THE ENTIRE LINE # (Such as: 1.001)") W !
43 .. S Y=""
44 . W !," LINE #: "_+Y_" AMOUNT NEEDED TO DISTRIBUTE: "_$J(+RCZ(Y),"",2),!
45 . ; RCDA = the ien of the line in file 344.491
46 . ; RCDA(1) = the line # RCDA(2) = the amount to be adjusted (+)
47 . S RCDA=$P(RCZ(Y),U,2),RCDA(1)=Y,RCQUIT=1,RCDA(2)=-$P(RCZ(Y),U)
48 ;
49 G:$G(RCDA)="" DISTQ
50 ;
51 S RCQUIT=0
52 ;
53 S (TOT,Z)=0 F S Z=$O(RCZ1(Z)) Q:'Z S TOT=TOT+Z
54 I TOT<RCDA(2) D G DISTQ
55 . S DIR(0)="EA",DIR("A",1)="THE ERA DOES NOT HAVE ENOUGH VALID PAYMENTS TO OFFSET THIS DISTRIBUTION",DIR("A",2)=$$WHAT(RCSCR),DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
56 ;
57 F S DIR(0)="NA^1:9999:3",DIR("A")="SELECT A LINE TO DISTRIBUTE THE ADJUSTMENT AMOUNT TO: " D Q:RCQUIT
58 . S DIR("?",1)="THE FOLLOWING LINE(S) HAVE A NET PAYMENT THAT CAN BE USED TO OFFSET THE",DIR("?",2)=" NEGATIVE NET PAYMENT FOR LINE "_RCDA(1)_" ("_$J(+$P(RCZ(RCDA(1)),U),"",2)_"):",CT=2
59 . S Z="" F S Z=$O(RCZ1(Z),-1) Q:'Z S Z0=0 F S Z0=$O(RCZ1(Z,Z0)) Q:'Z0 S CT=CT+1,DIR("?",CT)=" "_$J(Z0,8)_" "_$J(+Z,15,2)_$S($P(RCZ1(Z,Z0),U,2):" On hold exists",1:"")
60 . S DIR("?")=" "
61 . I $O(RCZ2(0))=$O(RCZ2(""),-1) S DIR("B")=$O(RCZ2(0))
62 . W ! D ^DIR K DIR
63 . I $D(DUOUT)!$D(DTOUT)!(Y="") S RCQUIT=1,RCDA1="" Q
64 . I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !,"THIS LINE DOES NOT EXIST FOR THIS ERA" W ! Q
65 . I '$D(RCZ2(Y)) D Q:Y=""
66 .. I Y'[".",$D(RCZ2(Y_".001")),$O(RCZ2(Y+1),-1)=(Y_".001") S Y=Y_".001" Q
67 .. I Y'[".",$O(RCZ2(Y))\1'=Y S Y=Y_"."
68 .. W !,$S(Y[".":"THIS LINE CANNOT BE USED FOR AN ADJUSTMENT DISTRIBUTION",1:"PLEASE ENTER THE ENTIRE LINE # (Such as: 1.001)") W !
69 .. S Y=""
70 . I $P(RCZ2(Y),U,3) W !,"Warning - on-hold exists for this claim",!
71 . W !," LINE #: "_+Y_" LINE BALANCE: "_$J(+$P(RCZ2(Y),U,2),"",2),!
72 . ; RCDA1 = the ien of the line in file 344.491
73 . ; RCDA1(1) = the line # in the display
74 . S RCDA1(1)=Y,RCDA1=+$G(RCZ2(Y)),RCQUIT=1
75 . S Z=$O(^RCY(344.49,RCSCR,1,"B",RCDA1(1)\1,0))
76 . S RCADJ=0
77 . I $P($G(^RCY(344.49,RCSCR,1,Z,0)),U,2)["**ADJ" S RCADJ=1 W !,"THE LINE SELECTED IS AN ADDITIONAL PAYMENT LINE, NOT SPECIFIC TO A CLAIM",!,"THE AMT WILL BE DISTRIBUTED, BUT A DECREASE ADJUSTMENT WILL NOT BE PERFORMED",!
78 ;
79 G:'$G(RCDA1) DISTQ
80 ;
81 S DIR("B")=$S(RCDA(2)<$P(RCZ2(RCDA1(1)),U,2):$J(RCDA(2),"",2),1:$J($P(RCZ2(+RCDA1(1)),U,2),"",2))
82 S DIR(0)="NA^.01:"_DIR("B")_":2",DIR("A")="ADJUSTMENT AMOUNT TO DISTRIBUTE: "
83 S DIR("?",1)="THIS IS THE AMOUNT OF THE ADJUSTMENT THAT SHOULD BE APPLIED TO THIS",DIR("?")="PAYMENT LINE. THE AMT ENTERED MUST BE BETWEEN .01 AND "_$J(DIR("B"),"",2)
84 D ^DIR K DIR
85 ;
86 I $D(DUOUT)!$D(DTOUT)!'Y D G DISTQ
87 . S DIR(0)="EA",DIR("A",1)="NO AMOUNT WAS ENTERED - TRY AGAIN LATER",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
88 S RCAMT=$J(Y,"",2)
89 ;
90 D ^DIR K DIR
91 I $D(DUOUT)!$D(DTOUT) D G DISTQ
92 . S DIR(0)="EA",DIR("A")="USER ABORT - PRESS RETURN TO CONTINUE " D ^DIR K DIR
93 ;
94 S Y=""
95 I 'RCADJ D G:'$D(RCDA) DISTQ
96 . N Z,RCA
97 . S RCA=0,Z1=+$P($G(^TMP("RCDPE-EOB_WLDX",$J,RCDA(1)\1)),U,2),Z=$G(^RCY(344.49,RCSCR,1,Z1,0)),RCA("#")=+$P($P(Z,U,2),"**ADJ",2)
98 . I $P(Z,U,2)["**ADJ" D
99 .. S RCA=1
100 .. S RCA("REF")=$S(RCA("#"):$P($G(^RCY(344.4,RCSCR,2,RCA("#"),0)),U),1:$P(Z,U,9))
101 . S Z=$S(RCA:RCA("#"),1:$G(^RCY(344.49,RCSCR,1,RCDA,0)))
102 . S DIR(0)="FAO^1:60",DIR("A")=" > ",DIR("A",1)="DECREASE ADJ COMMENT (1-60 CHARACTERS): "
103 . S DIR("B")="RETRACTED FOR "
104 . S DIR("B")=DIR("B")_$S(RCA:"ERA ADJ #"_Z_" Ref: "_RCA("REF"),1:"CLAIM "_$S($P(Z,U,2)'="":$P(Z,U,2),1:"UNKNOWN"))
105 . I $L(DIR("B"))>60 S DIR("B")=$E(DIR("B"),1,60)
106 . D ^DIR K DIR
107 . ;
108 . I $D(DUOUT)!$D(DTOUT) D Q
109 .. K RCDA
110 .. S DIR(0)="EA",DIR("A")="USER ABORT - PRESS RETURN TO CONTINUE " D ^DIR K DIR
111 ;
112 D DISTADJ^RCDPEWL4(RCDA,RCDA1,RCAMT,Y)
113 ;
114DISTQ S VALMBCK="R"
115 Q
116 ;
117REFRESH ; Refresh the entry in file 344.49 to remove all user adjustments
118 N RCREDEF,RCQUIT,DIR,X,Y,Z,Z0,DA,DIK
119 D FULL^VALM1
120 I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G REFQ
121 I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL G REFQ
122 S DIR(0)="YA"
123 S DIR("A",1)="THIS ACTION WILL DELETE AND REBUILD THIS EEOB WORKLIST SCRATCH PAD ENTRY",DIR("A",2)="ALL EDITS/SPLITS/DISTRIBUTE ADJUSTMENTS ENTERED FOR THIS ERA WILL BE ERASED"
124 S DIR("A",3)="AND ALL ENTRIES MARKED AS MANUALLY VERIFIED WILL BE UNMARKED",DIR("A",4)=" "
125 S DIR("A")="ARE YOU SURE YOU WANT TO DO THIS?: "
126 W ! D ^DIR K DIR
127 I Y'=1 G REFQ
128 I $O(^RCY(344.49,RCSCR,3,0)) S RCQUIT=0 D I RCQUIT G REFQ
129 . S DIR(0)="YA",DIR("A")="DO YOU WANT TO REDEFINE YOUR BATCHES TOO?: ",DIR("B")="NO" W ! D ^DIR K DIR
130 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q
131 . S RCREDEF=+Y
132 . K ^TMP($J,"BATCHES")
133 . S Z=0 F S Z=$O(^RCY(344.49,RCSCR,3,Z)) Q:'Z S Z0=$G(^(Z,0)) D
134 .. I RCREDEF S DA=Z,DA(1)=RCSCR,DIK="^RCY(344.49,"_DA(1)_",3," D ^DIK Q
135 .. S ^TMP($J,"BATCHES",+$P(Z0,U,6),$P(Z0,U,7))=+Z0_U_$P(Z0,U,8)
136 . I 'RCREDEF S ^TMP($J,"BATCHES")=+$O(^TMP($J,"BATCHES",0))
137 . I RCREDEF D SETBATCH^RCDPEWLB(RCSCR)
138 D ADDLINES^RCDPEWLA(RCSCR)
139 D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
140 K ^TMP($J,"BATCHES")
141REFQ S VALMBG=1,VALMBCK="R"
142 Q
143 ;
144WHAT(RCSCR) ; Text for what to do if not enough funds found for dist adj
145 Q $S($O(^RCY(344.31,"AERA",+RCSCR,0)):"THIS ERA MUST BE MOVED TO SUSPENSE",1:"THIS ERA'S RECEIPT MUST BE ENTERED MANUALLY")
146 ;
147ADJUST ; Allow entry into increase/decrease adjustment functions
148 N DIR,X,Y,RCTYP,RCY,DIC
149 D FULL^VALM1
150 ;
151 I $G(RCSCR("NOEDIT"))=2 D NOTAV^RCDPEWL2 G ADJUSTQ
152 ;
153 S DIR(0)="SA^D:DECREASE ADJUSTMENT;I:INCREASE ADJUSTMENT",DIR("B")="DECREASE ADJUSTMENT",DIR("A")="TYPE OF ADJUSTMENT: "
154 W ! D ^DIR K DIR
155 M ^TMP("RC_SAVE_TMP",$J)=^TMP($J)
156 I $D(DUOUT)!$D(DTOUT)!(Y="") G ADJUSTQ
157 ;
158 S RCTYP=$S(Y="D":"DECREASE",1:"INCREASE")
159 F S RCY=$$GETABILL^RCBEUBIL Q:RCY<0!(RCY'<1)
160 G:RCY<1 ADJUSTQ
161 D ADJUST^RCBEADJ(RCTYP,RCY_";"_RCSCR)
162 I $D(^TMP("RC_BILL",$J,RCY)) D
163 . D UPDBAL(RCY)
164 . W !,"Claim balance is now: ",$J(+$P($$BILL^RCJIBFN2(RCY),U,3),"",2)
165 ;
166ADJUSTQ D RESTMP
167 D RET^RCDPEWL2
168 S VALMBCK="R"
169 Q
170 ;
171RESTMP ;
172 I $D(^TMP("RC_SAVE_TMP",$J)) M ^TMP($J)=^TMP("RC_SAVE_TMP",$J) K ^TMP("RC_SAVE_TMP")
173 Q
174 ;
175UPDBAL(RCY) ; Updates the claim balance if bill exists in list
176 ; RCY = ien of bill in file 430
177 ;
178 N X,Y,Z,Z0,Z1
179 S Z0=$J(+$P($$BILL^RCJIBFN2(RCY),U,3),"",2)
180 S Z=0 F S Z=$O(^TMP("RC_BILL",$J,RCY,Z)) Q:'Z D
181 . S X=+$G(^TMP("RCDPE-EOB_WLDX",$J,Z))
182 . Q:'X
183 . S Y=$G(^TMP("RCDPE-EOB_WL",$J,X+1,0))
184 . I Y["Claim Bal: " S Z1=$P(Y,"Claim Bal: ")_"Claim Bal: "_Z0_$G(^TMP("RC_BILL",$J,RCY,Z)),^TMP("RCDPE-EOB_WL",$J,X+1,0)=Z1
185 Q
186 ;
Note: See TracBrowser for help on using the repository browser.