source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX3.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1RCDPEX3 ;ALB/TMK - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;10-OCT-02
2 ;;4.5;Accounts Receivable;**173,208**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; IA REF TO ^IBE(350.9 = 4049
5 Q
6 ;
7VP ; View/Print ERA Msgs - File 344.4
8 N X,Y,RCDA,RCTDA,RCALL,DIR,POP
9 D FULL^VALM1
10 S DIR(0)="SA^A:ALL;S:SELECTED",DIR("A")="PRINT (A)LL or (S)ELECTED RECORDS?: "
11 S DIR("B")="ALL"
12 D ^DIR K DIR
13 G:$D(DUOUT)!$D(DTOUT) VPQ
14 S RCALL=(Y="A")
15 ;
16 I 'RCALL D G:'$O(RCDA("")) VPQ
17 . D SEL(.RCDA)
18 ;
19 ; device
20 N %ZIS,ZTRTN,ZTSAVE,ZTDESC
21 S %ZIS="QM" D ^%ZIS G:POP VPQ
22 I $D(IO("Q")) D G VPQ
23 . S ZTRTN="VPOUT^RCDPEX3",ZTDESC="AR - Print ERA/EEOB Data With Exceptions"
24 . S ZTSAVE("RCDA")="",ZTSAVE("RCALL")="",ZTSAVE("^TMP(""RCDPEX_SUM-EOBDX"",$J,")=""
25 . D ^%ZTLOAD
26 . W !!,$S($D(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
27 . K ZTSK,IO("Q") D HOME^%ZIS
28 U IO
29 ;
30VPOUT ; Entrypoint queued job
31 ; RCDA, RCALL must be defined
32 N Z,RCSTOP,RCZ,RCPG,RCDOT,RCTDA1
33 K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT")
34 S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)=""
35 I RCALL D
36 . S RCZ=0 F S RCZ=$O(^TMP("RCDPEX_SUM-EOBDX",$J,RCZ)) Q:'RCZ S RCTDA=$G(^(RCZ)),RCTDA1=+$P(RCTDA,U,3),RCTDA=+$P(RCTDA,U,2) D Q:RCSTOP
37 .. D PRT(RCTDA,RCTDA1,.RCPG,.RCSTOP)
38 .. I $O(^TMP("RCDPEX_SUM-EOBDX",$J,RCZ)) D WRTSEP(RCDOT,RCPG)
39 I 'RCALL D
40 . S RCZ=0 F S RCZ=$O(RCDA(RCZ)) Q:'RCZ D
41 .. S RCTDA1=+$P(RCDA(RCZ),U,2),RCTDA=+RCDA(RCZ) D PRT(RCTDA,RCTDA1,.RCPG,.RCSTOP) I $O(RCDA(RCZ)) D WRTSEP(RCDOT,RCPG)
42 ;
43 I '$D(ZTQUEUED),'RCSTOP,RCPG D ASK(.RCSTOP)
44 ;
45 I $D(ZTQUEUED) S ZTREQ="@"
46 I '$D(ZTQUEUED) D ^%ZISC
47 ;
48VPQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT")
49 S VALMBCK="R"
50 Q
51 ;
52WRTSEP(RCDOT,RCPG) ; Separating lines if more records to print
53 W !,RCDOT,!,RCDOT
54 I (($Y+5)>IOSL) D HDR(.RCPG) Q
55 W !!
56 Q
57 ;
58PRT(RCTDA,RCTDA1,RCPG,RCSTOP) ; Print data from file 344.4 and 344.41
59 ; RCTDA = ien file 344.4
60 ; RCTDA1 = ien file 344.41
61 ; RCPG = last page extracted
62 ; RCSTOP = returned 1 if passed by ref and process stopped
63 ;
64 N RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,Z
65 D GETS^DIQ(344.4,RCTDA_",","*","IEN","RCDIQ")
66 D TXT0^RCDPEX31(RCTDA,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned fields
67 ;
68 I $O(^RCY(344.4,RCTDA,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**"
69 S Z=0 F S Z=$O(^RCY(344.4,RCTDA,2,Z)) Q:'Z D
70 . D GETS^DIQ(344.42,Z_","_RCTDA_",","*","IEN","RCDIQ2")
71 . D TXT2^RCDPEX31(RCTDA,Z,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs
72 ;
73 D GETS^DIQ(344.41,RCTDA1_","_RCTDA_",","*","IEN","RCDIQ1")
74 D TXT00^RCDPEX31(RCTDA,RCTDA1,.RCDIQ1,.RCXM1,.RC)
75 D DISP^RCDPESR0("^RCY(344.4,"_RCTDA_",1,"_RCTDA1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75) ; Get formatted 'raw' data
76 ;
77 I $D(RCDIQ1(344.41,RCTDA1_","_RCTDA_",",2)) D
78 . S RC=RC+1,RCXM1(RC)=" **RESOLUTION LOG DATA**"
79 . S Z=0 F S Z=$O(RCDIQ1(344.41,RCTDA1_","_RCTDA_",",2,Z)) Q:'Z S RC=RC+1,RCXM1(RC)=RCDIQ1(344.41,RCTDA1_","_RCTDA_",",2,Z)
80 . S RC=RC+1,RCXM1(RC)=" "
81 S (RCSTOP,Z)=0
82 F S Z=$O(RCXM1(Z)) Q:'Z S ^TMP($J,"RC_SUMOUT",Z-999)=RCXM1(Z)
83 S Z=""
84 F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z D Q:RCSTOP
85 . I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q
86 . I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q
87 .. D:RCPG ASK(.RCSTOP) I RCSTOP Q
88 .. D HDR(.RCPG)
89 . W !,$G(^TMP($J,"RC_SUMOUT",Z))
90 ;
91 Q
92 ;
93XFR ; Transfer EOB(s) to other site
94 N RC,RC0,RCCHG,RCOK,RCDOMAIN,RCDEF,RCDA,RCWHY,RCER,RCECT,RCXTO,RCALL,RCCONT,DIR,X,Y,DA,DIE,DR,POP,RCDA,RCXDA,RCXDA1,RCDUZ,XMBODY,XMTO
95 D FULL^VALM1
96 D SEL(.RCDA)
97 ;
98 G:'$O(RCDA(0)) XFRQ
99 S DIR("S")="I +$G(^DIC(4,+Y,6))",DIR(0)="PA^4:AME",DIR("A")="TRANSFER TO WHICH SITE?: " D ^DIR K DIR
100 I $D(DUOUT)!$D(DTOUT) G XFRQ
101 S RCXTO=+Y,RCCHG=0
102 ;
103 S RCDOMAIN=$$EXTERNAL^DILFD(4,60,,+$G(^DIC(4,+RCXTO,6))),RCECT=0
104 I RCDOMAIN="" D G XFRQ
105 . S DIR("A",1)="THERE IS NO VALID DOMAIN SET UP FOR THIS SITE. YOU MUST CHOOSE ANOTHER ONE.",DIR("A")="PRESS RETURN TO CONTINUE",DIR(0)="EA" W ! D ^DIR K DIR
106 ;
107 S RCDEF=$S($P($G(^IBE(350.9,1,2)),U,6)'="":$E("AGENT CASHIER-"_$P(^IBE(350.9,1,2),U,6),1,45),1:"")
108 S DIR("A",1)="ENTER THE CONTACT INFORMATION FOR THE PERSON AT YOUR SITE",DIR("A",2)=" WHO MAY BE CONTACTED BY THE OTHER SITE REGARDING THIS EEOB",DIR("A")=" (1-45 CHARACTERS): "_$S(RCDEF'="":RCDEF_"// ",1:"") ; IA 4049
109 S DIR(0)="FA"_$S(RCDEF'="":"O",1:"")_"^1:45" W ! D ^DIR K DIR
110 I $D(DUOUT)!$D(DTOUT) G XFRQ
111 I Y="" S Y=RCDEF
112 S RCCONT=Y
113 ;
114 S DIR(0)="YA",DIR("A")="DO YOU WANT TO PRINT THE EEOB(s)?: ",DIR("B")="Y"
115 D ^DIR K DIR
116 I $D(DUOUT)!$D(DTOUT) G XFRQ
117 I Y=1 S RCER=0 D I RCER G XFRQ
118 . N %ZIS,ZTRTN,ZTSAVE,ZTDESC
119 . S %ZIS="QM" D ^%ZIS I POP S RCER=1 Q
120 . I $D(IO("Q")) D Q
121 .. S RCALL=0
122 .. S ZTRTN="VPOUT^RCDPEX3",ZTDESC="AR - Print EEOB Data Before Transfer"
123 .. S ZTSAVE("RCDA")="",ZTSAVE("RCALL")="",ZTSAVE("^TMP(""RCDPEX_SUM-EOBDX"",$J)")=""
124 .. D ^%ZTLOAD
125 .. I '$D(ZTSK) S RCER=1
126 .. K ZTSK,IO("Q") D HOME^%ZIS
127 . S RCALL=0
128 . D VPOUT^RCDPEX3
129 ;
130 S RCWHY(1)="Transfer EEOB detail to another site"
131 S RC=0 F S RC=$O(RCDA(RC)) Q:'RC D L -^RCY(344.4,RCXDA,1,RCXDA1,0)
132 . N RCBODY,RCAMT,RCBILL,RCX,XMZ
133 . S RCXDA=+RCDA(RC),RCXDA1=+$P(RCDA(RC),U,2),RCWHY(2)=""
134 . I '$$LOCK^RCDPEX31(RCXDA,RCXDA1,1) D Q
135 .. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" is being edited by another user - ... please try again later"
136 . ;
137 . S RC0=$G(^RCY(344.4,RCXDA,1,RCXDA1,0))
138 . M RCBODY=^RCY(344.4,RCXDA,1,RCXDA1,1)
139 . S RCAMT=$P(RC0,U,3)*100
140 . S RCBILL=$P(RC0,U,5)
141 . S DIR("A",1)="ONCE THIS EEOB HAS BEEN TRANSFERRED, ITS BILL # CANNOT BE EDITED",DIR("A")="ARE YOU SURE THIS IS NOT A CLAIM FOR YOUR SITE?: ",DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR
142 . Q:Y'=1
143 . I $P(RC0,U,11) D Q:'RCOK
144 .. S RCOK=1
145 .. S DIR("A",1)="WARNING: EEOB FOR #"_RC_" ("_RCBILL_") HAS ALREADY BEEN TRANSFERRED",DIR("A",2)=" TO "_$P($G(^DIC(4,+$P(RC0,U,11),0)),U)_" ON: "_$$FMTE^XLFDT($P(RC0,U,12),2)
146 .. S DIR("A")="ARE YOU SURE YOU WANT TO TRANSFER IT AGAIN?: "
147 .. S DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR
148 .. I Y=1 Q
149 .. S RCOK=0
150 .. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" already transferred - "_RCBILL_" NOT transferred again"
151 . K RCBODY(0)
152 . S RCX=$G(RCBODY(1,0))
153 . ;
154 . I $P($G(^RCY(344.4,RCXDA,1,RCXDA1,0)),U,7)'=1 D Q
155 .. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" is not available for transfer - "_RCBILL_" NOT transferred"
156 . ;
157 . I $P(RCX,U)'["835ERA"!'$O(RCBODY(1)) D Q
158 .. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" format is not valid for transfer - "_RCBILL_" NOT transferred"
159 . ;
160 . S $P(RCX,U)="835XFR",$P(RCX,U,10,16)=(RCAMT_"^^^^^^"_RCCONT)
161 . S RCBODY(1,0)=RCX
162 . S RCBODY(+$O(RCBODY(""),-1)+1,0)="99^$"
163 . S RCBODY(+$O(RCBODY(""),-1)+1,0)="NNNN"
164 . S XMTO("S.RCDPE EDI LOCKBOX SERVER@"_RCDOMAIN)=""
165 . S XMBODY="RCBODY",RCDUZ=$G(DUZ),DUZ=.5
166 . D SENDMSG^XMXAPI(.5,"TRANSFER 3RD PARTY EEOB "_RCBILL_"(REF #"_RCXDA_";"_RCXDA1_"#)",XMBODY,.XMTO,,.XMZ)
167 . ;
168 . S DUZ=RCDUZ
169 . I $G(XMZ) D ; Report msg #
170 .. S RCCHG=1
171 .. S RCECT=RCECT+1,RCER(RCECT)="Entry #"_RC_" was successfully transferred - msg # is "_XMZ
172 .. S DA(1)=RCXDA,DA=RCXDA1,DIE="^RCY(344.4,"_DA(1)_",1,",DR=".09////"_XMZ_";.11////"_RCXTO_";.12////"_$E($$NOW^XLFDT(),1,12) D ^DIE
173 .. S RCWHY(2)=" Transfer to "_$P($G(^DIC(4,+RCXTO,0)),U)_" was successful"
174 .. ;
175 . E D ; error - transfer not done
176 .. S RCECT=RCECT+1,RCER(RCECT)="**Entry #"_RC_" was NOT transferred due to a msg build error ("_RCBILL_")"
177 .. S RCWHY(2)=" Transfer to "_$P($G(^DIC(4,+RCXTO,0)),U)_" was UNSUCCESSFUL"
178 .. ;
179 . D STORACT^RCDPEX31(RCXDA,RCXDA1,.RCWHY)
180 ;
181 I $O(RCER(0)) D
182 . ; Write msgs
183 . W !!,"TRANSFER OF EEOB TO "_$P($G(^DIC(4,RCXTO,0)),U)_" RESULTS: ",!
184 . S RCECT=0 F S RCECT=$O(RCER(RCECT)) Q:'RCECT W !," ",RCER(RCECT)
185 . W !
186 ;
187 D PAUSE^VALM1
188 ;
189XFRQ I $G(RCCHG) D BLD^RCDPEX2
190 S VALMBCK="R"
191 Q
192 ;
193SEL(RCDA,ONE) ; Select entry(s) from list
194 ; RCDA = array returned if selections made
195 ; RCDA(n)=ien of bill selected file 344.4
196 ; ONE = if set to 1, only one selection can be made at a time
197 N RC
198 K RCDA
199 D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
200 S RCDA=0 F S RCDA=$O(VALMY(RCDA)) Q:'RCDA S RC=$G(^TMP("RCDPEX_SUM-EOBDX",$J,RCDA)),RCDA(RCDA)=+$P(RC,U,2)_U_+$P(RC,U,3)
201 Q
202 ;
203HDR(RCPG) ;Print report hdr
204 ; RCPG = last page #
205 I RCPG!($E(IOST,1,2)="C-") W @IOF,*13
206 S RCPG=$G(RCPG)+1
207 W !,?5,"EDI LOCKBOX EEOB DATA EXCEPTIONS - EEOB DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=")
208 Q
209 ;
210ASK(RCSTOP) ;
211 I $E(IOST,1,2)'["C-" Q
212 N DIR,DIROUT,DIRUT,DTOUT,DUOUT
213 S DIR(0)="E" W ! D ^DIR
214 I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q
215 Q
216 ; ***
217 ; *** Entrypoints TXT* assume these variable definitions ***
218 ; ***
219 ; FUNCTIONs returns RCXM1 and RC if passed by reference
220 ; RCTDA = ien, file 344.4
221 ; RCXM1 = array returned with text, captioned
222 ; RC = # of lines already in array (optional)
223 ; RCDIQ and RCDIQ1 = arrays returned from GETS^DIQ
224 ; ***
225 ;
226UPD ; Try to update the IB EOB file from exception in 344.41
227 D UPD^RCDPEX31 ; Moved for space
228 Q
229 ;
Note: See TracBrowser for help on using the repository browser.