RCDPEX3 ;ALB/TMK/PJH - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ; 3/30/11 7:19pm
;;4.5;Accounts Receivable;**173,208,258,269,321**;Mar 20, 1995;Build 48
;;Per VHA Directive 2004-038, this routine should not be modified.
; IA# 5286 for call to $$PRVPHONE^IBJPS3()
Q
;
VP ; View/Print ERA Msgs - File 344.4
N X,Y,RCDA,RCTDA,RCALL,DIR,POP
D FULL^VALM1
S DIR(0)="SA^A:ALL;S:SELECTED",DIR("A")="PRINT (A)LL or (S)ELECTED RECORDS?: "
S DIR("B")="ALL"
D ^DIR K DIR
G:$D(DUOUT)!$D(DTOUT) VPQ
S RCALL=(Y="A")
;
I 'RCALL D G:'$O(RCDA("")) VPQ
. D SEL(.RCDA)
;
; device
N %ZIS,ZTRTN,ZTSAVE,ZTDESC
S %ZIS="QM" D ^%ZIS G:POP VPQ
I $D(IO("Q")) D G VPQ
. S ZTRTN="VPOUT^RCDPEX3",ZTDESC="AR - Print ERA/EEOB Data With Exceptions"
. S ZTSAVE("RCDA")="",ZTSAVE("RCALL")="",ZTSAVE("^TMP(""RCDPEX_SUM-EOBDX"",$J,")=""
. D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
. K ZTSK,IO("Q") D HOME^%ZIS
U IO
;
VPOUT ; Entrypoint queued job
; RCDA, RCALL must be defined
N Z,RCSTOP,RCZ,RCPG,RCDOT,RCTDA1
K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT")
S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)=""
I RCALL D
. 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
.. D PRT(RCTDA,RCTDA1,.RCPG,.RCSTOP)
.. I $O(^TMP("RCDPEX_SUM-EOBDX",$J,RCZ)) D WRTSEP(RCDOT,RCPG)
I 'RCALL D
. S RCZ=0 F S RCZ=$O(RCDA(RCZ)) Q:'RCZ D
.. S RCTDA1=+$P(RCDA(RCZ),U,2),RCTDA=+RCDA(RCZ) D PRT(RCTDA,RCTDA1,.RCPG,.RCSTOP) I $O(RCDA(RCZ)) D WRTSEP(RCDOT,RCPG)
;
I '$D(ZTQUEUED),'RCSTOP,RCPG D ASK(.RCSTOP)
;
I $D(ZTQUEUED) S ZTREQ="@"
I '$D(ZTQUEUED) D ^%ZISC
;
VPQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT")
S VALMBCK="R"
Q
;
WRTSEP(RCDOT,RCPG) ; Separating lines if more records to print
W !,RCDOT,!,RCDOT
I (($Y+5)>IOSL) D HDR(.RCPG) Q
W !!
Q
;
PRT(RCTDA,RCTDA1,RCPG,RCSTOP) ; Print data from file 344.4 and 344.41
; RCTDA = ien file 344.4
; RCTDA1 = ien file 344.41
; RCPG = last page extracted
; RCSTOP = returned 1 if passed by ref and process stopped
;
N RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,Z
D GETS^DIQ(344.4,RCTDA_",","*","IEN","RCDIQ")
D TXT0^RCDPEX31(RCTDA,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned fields
;
I $O(^RCY(344.4,RCTDA,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**"
S Z=0 F S Z=$O(^RCY(344.4,RCTDA,2,Z)) Q:'Z D
. D GETS^DIQ(344.42,Z_","_RCTDA_",","*","IEN","RCDIQ2")
. D TXT2^RCDPEX31(RCTDA,Z,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs
;
D GETS^DIQ(344.41,RCTDA1_","_RCTDA_",","*","IEN","RCDIQ1")
D TXT00^RCDPEX31(RCTDA,RCTDA1,.RCDIQ1,.RCXM1,.RC)
D DISP^RCDPESR0("^RCY(344.4,"_RCTDA_",1,"_RCTDA1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75) ; Get formatted 'raw' data
;
I $D(RCDIQ1(344.41,RCTDA1_","_RCTDA_",",2)) D
. S RC=RC+1,RCXM1(RC)=" **RESOLUTION LOG DATA**"
. 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)
. S RC=RC+1,RCXM1(RC)=" "
S (RCSTOP,Z)=0
F S Z=$O(RCXM1(Z)) Q:'Z S ^TMP($J,"RC_SUMOUT",Z-999)=RCXM1(Z)
S Z=""
F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z D Q:RCSTOP
. I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q
. I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q
.. D:RCPG ASK(.RCSTOP) I RCSTOP Q
.. D HDR(.RCPG)
. W !,$G(^TMP($J,"RC_SUMOUT",Z))
;
K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT") ; Clear arrays before next exception - PRCA*4.5*321
Q
;
XFR ; Transfer EOB(s) to other site
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
D FULL^VALM1
D SEL(.RCDA)
;
G:'$O(RCDA(0)) XFRQ
S DIR("S")="I +$G(^DIC(4,+Y,6))",DIR(0)="PA^4:AME",DIR("A")="TRANSFER TO WHICH SITE?: " D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G XFRQ
S RCXTO=+Y,RCCHG=0
;
S RCDOMAIN=$$EXTERNAL^DILFD(4,60,,+$G(^DIC(4,+RCXTO,6))),RCECT=0
I RCDOMAIN="" D G XFRQ
. 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
;
S RCDEF=$$PRVPHONE^IBJPS3() ; IA 5286
I RCDEF'="" S RCDEF="AGENT CASHIER-"_RCDEF
;
S DIR("A",1)="ENTER THE CONTACT INFORMATION FOR THE PERSON AT YOUR SITE"
S DIR("A",2)=" WHO MAY BE CONTACTED BY THE OTHER SITE REGARDING THIS EEOB"
S DIR("A")=" (1-45 CHARACTERS): "_$S(RCDEF'="":RCDEF_"// ",1:"")
S DIR(0)="FA"_$S(RCDEF'="":"O",1:"")_"^1:45" W ! D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G XFRQ
I Y="" S Y=RCDEF
S RCCONT=Y
;
S DIR(0)="YA",DIR("A")="DO YOU WANT TO PRINT THE EEOB(s)?: ",DIR("B")="Y"
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) G XFRQ
I Y=1 S RCER=0 D I RCER G XFRQ
. N %ZIS,ZTRTN,ZTSAVE,ZTDESC
. S %ZIS="QM" D ^%ZIS I POP S RCER=1 Q
. I $D(IO("Q")) D Q
.. S RCALL=0
.. S ZTRTN="VPOUT^RCDPEX3",ZTDESC="AR - Print EEOB Data Before Transfer"
.. S ZTSAVE("RCDA")="",ZTSAVE("RCALL")="",ZTSAVE("^TMP(""RCDPEX_SUM-EOBDX"",$J)")=""
.. D ^%ZTLOAD
.. I '$D(ZTSK) S RCER=1
.. K ZTSK,IO("Q") D HOME^%ZIS
. S RCALL=0
. D VPOUT^RCDPEX3
;
S RCWHY(1)="Transfer EEOB detail to another site"
S RC=0 F S RC=$O(RCDA(RC)) Q:'RC D L -^RCY(344.4,RCXDA,1,RCXDA1,0)
. N RCBODY,RCAMT,RCBILL,RCX,XMZ
. S RCXDA=+RCDA(RC),RCXDA1=+$P(RCDA(RC),U,2),RCWHY(2)=""
. I '$$LOCK^RCDPEX31(RCXDA,RCXDA1,1) D Q
.. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" is being edited by another user - ... please try again later"
. ;
. S RC0=$G(^RCY(344.4,RCXDA,1,RCXDA1,0))
. M RCBODY=^RCY(344.4,RCXDA,1,RCXDA1,1)
. S RCAMT=$P(RC0,U,3)*100
. S RCBILL=$P(RC0,U,5)
. 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
. Q:Y'=1
. I $P(RC0,U,11) D Q:'RCOK
.. S RCOK=1
.. 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)
.. S DIR("A")="ARE YOU SURE YOU WANT TO TRANSFER IT AGAIN?: "
.. S DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR
.. I Y=1 Q
.. S RCOK=0
.. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" already transferred - "_RCBILL_" NOT transferred again"
. K RCBODY(0)
. S RCX=$G(RCBODY(1,0))
. ;
. I $P($G(^RCY(344.4,RCXDA,1,RCXDA1,0)),U,7)'=1 D Q
.. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" is not available for transfer - "_RCBILL_" NOT transferred"
. ;
. I $P(RCX,U)'["835ERA"!'$O(RCBODY(1)) D Q
.. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" format is not valid for transfer - "_RCBILL_" NOT transferred"
. ;
. S $P(RCX,U)="835XFR",$P(RCX,U,10,15)=(RCAMT_"^^^^^")
. S $P(RCX,U,19)=RCCONT
. S RCBODY(1,0)=RCX
. S RCBODY(+$O(RCBODY(""),-1)+1,0)="99^$"
. S RCBODY(+$O(RCBODY(""),-1)+1,0)="NNNN"
. S XMTO("S.RCDPE EDI LOCKBOX SERVER@"_RCDOMAIN)=""
. S XMBODY="RCBODY",RCDUZ=$G(DUZ),DUZ=.5
. D SENDMSG^XMXAPI(.5,"TRANSFER 3RD PARTY EEOB "_RCBILL_"(REF #"_RCXDA_";"_RCXDA1_"#)",XMBODY,.XMTO,,.XMZ)
. ;
. S DUZ=RCDUZ
. I $G(XMZ) D ; Report msg #
.. S RCCHG=1
.. S RCECT=RCECT+1,RCER(RCECT)="Entry #"_RC_" was successfully transferred - msg # is "_XMZ
.. 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
.. S RCWHY(2)=" Transfer to "_$P($G(^DIC(4,+RCXTO,0)),U)_" was successful"
.. ;
. E D ; error - transfer not done
.. S RCECT=RCECT+1,RCER(RCECT)="**Entry #"_RC_" was NOT transferred due to a msg build error ("_RCBILL_")"
.. S RCWHY(2)=" Transfer to "_$P($G(^DIC(4,+RCXTO,0)),U)_" was UNSUCCESSFUL"
.. ;
. D STORACT^RCDPEX31(RCXDA,RCXDA1,.RCWHY)
;
I $O(RCER(0)) D
. ; Write msgs
. W !!,"TRANSFER OF EEOB TO "_$P($G(^DIC(4,RCXTO,0)),U)_" RESULTS: ",!
. S RCECT=0 F S RCECT=$O(RCER(RCECT)) Q:'RCECT W !," ",RCER(RCECT)
. W !
;
D PAUSE^VALM1
;
XFRQ I $G(RCCHG) D BLD^RCDPEX2
S VALMBCK="R"
Q
;
SEL(RCDA,ONE) ; Select entry(s) from list
; RCDA = array returned if selections made
; RCDA(n)=ien of bill selected file 344.4
; ONE = if set to 1, only one selection can be made at a time
N RC
K RCDA
D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
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)
Q
;
HDR(RCPG) ;Print report hdr
; RCPG = last page #
I RCPG!($E(IOST,1,2)="C-") W @IOF,*13
S RCPG=$G(RCPG)+1
W !,?5,"EDI LOCKBOX EEOB DATA EXCEPTIONS - EEOB DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=")
Q
;
ASK(RCSTOP) ;
I $E(IOST,1,2)'["C-" Q
N DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="E" W ! D ^DIR
I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q
Q
; ***
; *** Entrypoints TXT* assume these variable definitions ***
; ***
; FUNCTIONs returns RCXM1 and RC if passed by reference
; RCTDA = ien, file 344.4
; RCXM1 = array returned with text, captioned
; RC = # of lines already in array (optional)
; RCDIQ and RCDIQ1 = arrays returned from GETS^DIQ
; ***
;
UPD ; Try to update the IB EOB file from exception in 344.41
D UPD^RCDPEX31 ; Moved for space
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDPEX3 9395 printed Sep 02, 2024@18:31:20 Page 2
RCDPEX3 ;ALB/TMK/PJH - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ; 3/30/11 7:19pm
+1 ;;4.5;Accounts Receivable;**173,208,258,269,321**;Mar 20, 1995;Build 48
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; IA# 5286 for call to $$PRVPHONE^IBJPS3()
+4 QUIT
+5 ;
VP ; View/Print ERA Msgs - File 344.4
+1 NEW X,Y,RCDA,RCTDA,RCALL,DIR,POP
+2 DO FULL^VALM1
+3 SET DIR(0)="SA^A:ALL;S:SELECTED"
SET DIR("A")="PRINT (A)LL or (S)ELECTED RECORDS?: "
+4 SET DIR("B")="ALL"
+5 DO ^DIR
KILL DIR
+6 if $DATA(DUOUT)!$DATA(DTOUT)
GOTO VPQ
+7 SET RCALL=(Y="A")
+8 ;
+9 IF 'RCALL
Begin DoDot:1
+10 DO SEL(.RCDA)
End DoDot:1
if '$ORDER(RCDA(""))
GOTO VPQ
+11 ;
+12 ; device
+13 NEW %ZIS,ZTRTN,ZTSAVE,ZTDESC
+14 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO VPQ
+15 IF $DATA(IO("Q"))
Begin DoDot:1
+16 SET ZTRTN="VPOUT^RCDPEX3"
SET ZTDESC="AR - Print ERA/EEOB Data With Exceptions"
+17 SET ZTSAVE("RCDA")=""
SET ZTSAVE("RCALL")=""
SET ZTSAVE("^TMP(""RCDPEX_SUM-EOBDX"",$J,")=""
+18 DO ^%ZTLOAD
+19 WRITE !!,$SELECT($DATA(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
+20 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:1
GOTO VPQ
+21 USE IO
+22 ;
VPOUT ; Entrypoint queued job
+1 ; RCDA, RCALL must be defined
+2 NEW Z,RCSTOP,RCZ,RCPG,RCDOT,RCTDA1
+3 KILL ^TMP($JOB,"RC_SUMRAW"),^TMP($JOB,"RC_SUMOUT")
+4 SET (RCSTOP,RCPG)=0
SET RCDOT=""
SET $PIECE(RCDOT,".",79)=""
+5 IF RCALL
Begin DoDot:1
+6 SET RCZ=0
FOR
SET RCZ=$ORDER(^TMP("RCDPEX_SUM-EOBDX",$JOB,RCZ))
if 'RCZ
QUIT
SET RCTDA=$GET(^(RCZ))
SET RCTDA1=+$PIECE(RCTDA,U,3)
SET RCTDA=+$PIECE(RCTDA,U,2)
Begin DoDot:2
+7 DO PRT(RCTDA,RCTDA1,.RCPG,.RCSTOP)
+8 IF $ORDER(^TMP("RCDPEX_SUM-EOBDX",$JOB,RCZ))
DO WRTSEP(RCDOT,RCPG)
End DoDot:2
if RCSTOP
QUIT
End DoDot:1
+9 IF 'RCALL
Begin DoDot:1
+10 SET RCZ=0
FOR
SET RCZ=$ORDER(RCDA(RCZ))
if 'RCZ
QUIT
Begin DoDot:2
+11 SET RCTDA1=+$PIECE(RCDA(RCZ),U,2)
SET RCTDA=+RCDA(RCZ)
DO PRT(RCTDA,RCTDA1,.RCPG,.RCSTOP)
IF $ORDER(RCDA(RCZ))
DO WRTSEP(RCDOT,RCPG)
End DoDot:2
End DoDot:1
+12 ;
+13 IF '$DATA(ZTQUEUED)
IF 'RCSTOP
IF RCPG
DO ASK(.RCSTOP)
+14 ;
+15 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+16 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+17 ;
VPQ KILL ^TMP($JOB,"RC_SUMRAW"),^TMP($JOB,"RC_SUMOUT")
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
WRTSEP(RCDOT,RCPG) ; Separating lines if more records to print
+1 WRITE !,RCDOT,!,RCDOT
+2 IF (($Y+5)>IOSL)
DO HDR(.RCPG)
QUIT
+3 WRITE !!
+4 QUIT
+5 ;
PRT(RCTDA,RCTDA1,RCPG,RCSTOP) ; Print data from file 344.4 and 344.41
+1 ; RCTDA = ien file 344.4
+2 ; RCTDA1 = ien file 344.41
+3 ; RCPG = last page extracted
+4 ; RCSTOP = returned 1 if passed by ref and process stopped
+5 ;
+6 NEW RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,Z
+7 DO GETS^DIQ(344.4,RCTDA_",","*","IEN","RCDIQ")
+8 ; Get top level 0-node captioned fields
DO TXT0^RCDPEX31(RCTDA,.RCDIQ,.RCXM1,.RC)
+9 ;
+10 IF $ORDER(^RCY(344.4,RCTDA,2,0))
SET RC=RC+1
SET RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**"
+11 SET Z=0
FOR
SET Z=$ORDER(^RCY(344.4,RCTDA,2,Z))
if 'Z
QUIT
Begin DoDot:1
+12 DO GETS^DIQ(344.42,Z_","_RCTDA_",","*","IEN","RCDIQ2")
+13 ; Get top level ERA adjs
DO TXT2^RCDPEX31(RCTDA,Z,.RCDIQ2,.RCXM1,.RC)
End DoDot:1
+14 ;
+15 DO GETS^DIQ(344.41,RCTDA1_","_RCTDA_",","*","IEN","RCDIQ1")
+16 DO TXT00^RCDPEX31(RCTDA,RCTDA1,.RCDIQ1,.RCXM1,.RC)
+17 ; Get formatted 'raw' data
DO DISP^RCDPESR0("^RCY(344.4,"_RCTDA_",1,"_RCTDA1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75)
+18 ;
+19 IF $DATA(RCDIQ1(344.41,RCTDA1_","_RCTDA_",",2))
Begin DoDot:1
+20 SET RC=RC+1
SET RCXM1(RC)=" **RESOLUTION LOG DATA**"
+21 SET Z=0
FOR
SET Z=$ORDER(RCDIQ1(344.41,RCTDA1_","_RCTDA_",",2,Z))
if 'Z
QUIT
SET RC=RC+1
SET RCXM1(RC)=RCDIQ1(344.41,RCTDA1_","_RCTDA_",",2,Z)
+22 SET RC=RC+1
SET RCXM1(RC)=" "
End DoDot:1
+23 SET (RCSTOP,Z)=0
+24 FOR
SET Z=$ORDER(RCXM1(Z))
if 'Z
QUIT
SET ^TMP($JOB,"RC_SUMOUT",Z-999)=RCXM1(Z)
+25 SET Z=""
+26 FOR
SET Z=$ORDER(^TMP($JOB,"RC_SUMOUT",Z))
if 'Z
QUIT
Begin DoDot:1
+27 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (RCSTOP,ZTSTOP)=1
KILL ZTREQ
IF +$GET(RCPG)
WRITE !!,"***TASK STOPPED BY USER***"
QUIT
+28 IF 'RCPG!(($Y+5)>IOSL)
Begin DoDot:2
+29 if RCPG
DO ASK(.RCSTOP)
IF RCSTOP
QUIT
+30 DO HDR(.RCPG)
End DoDot:2
IF RCSTOP
QUIT
+31 WRITE !,$GET(^TMP($JOB,"RC_SUMOUT",Z))
End DoDot:1
if RCSTOP
QUIT
+32 ;
+33 ; Clear arrays before next exception - PRCA*4.5*321
KILL ^TMP($JOB,"RC_SUMRAW"),^TMP($JOB,"RC_SUMOUT")
+34 QUIT
+35 ;
XFR ; Transfer EOB(s) to other site
+1 NEW 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
+2 DO FULL^VALM1
+3 DO SEL(.RCDA)
+4 ;
+5 if '$ORDER(RCDA(0))
GOTO XFRQ
+6 SET DIR("S")="I +$G(^DIC(4,+Y,6))"
SET DIR(0)="PA^4:AME"
SET DIR("A")="TRANSFER TO WHICH SITE?: "
DO ^DIR
KILL DIR
+7 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO XFRQ
+8 SET RCXTO=+Y
SET RCCHG=0
+9 ;
+10 SET RCDOMAIN=$$EXTERNAL^DILFD(4,60,,+$GET(^DIC(4,+RCXTO,6)))
SET RCECT=0
+11 IF RCDOMAIN=""
Begin DoDot:1
+12 SET DIR("A",1)="THERE IS NO VALID DOMAIN SET UP FOR THIS SITE. YOU MUST CHOOSE ANOTHER ONE."
SET DIR("A")="PRESS RETURN TO CONTINUE"
SET DIR(0)="EA"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
GOTO XFRQ
+13 ;
+14 ; IA 5286
SET RCDEF=$$PRVPHONE^IBJPS3()
+15 IF RCDEF'=""
SET RCDEF="AGENT CASHIER-"_RCDEF
+16 ;
+17 SET DIR("A",1)="ENTER THE CONTACT INFORMATION FOR THE PERSON AT YOUR SITE"
+18 SET DIR("A",2)=" WHO MAY BE CONTACTED BY THE OTHER SITE REGARDING THIS EEOB"
+19 SET DIR("A")=" (1-45 CHARACTERS): "_$SELECT(RCDEF'="":RCDEF_"// ",1:"")
+20 SET DIR(0)="FA"_$SELECT(RCDEF'="":"O",1:"")_"^1:45"
WRITE !
DO ^DIR
KILL DIR
+21 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO XFRQ
+22 IF Y=""
SET Y=RCDEF
+23 SET RCCONT=Y
+24 ;
+25 SET DIR(0)="YA"
SET DIR("A")="DO YOU WANT TO PRINT THE EEOB(s)?: "
SET DIR("B")="Y"
+26 DO ^DIR
KILL DIR
+27 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO XFRQ
+28 IF Y=1
SET RCER=0
Begin DoDot:1
+29 NEW %ZIS,ZTRTN,ZTSAVE,ZTDESC
+30 SET %ZIS="QM"
DO ^%ZIS
IF POP
SET RCER=1
QUIT
+31 IF $DATA(IO("Q"))
Begin DoDot:2
+32 SET RCALL=0
+33 SET ZTRTN="VPOUT^RCDPEX3"
SET ZTDESC="AR - Print EEOB Data Before Transfer"
+34 SET ZTSAVE("RCDA")=""
SET ZTSAVE("RCALL")=""
SET ZTSAVE("^TMP(""RCDPEX_SUM-EOBDX"",$J)")=""
+35 DO ^%ZTLOAD
+36 IF '$DATA(ZTSK)
SET RCER=1
+37 KILL ZTSK,IO("Q")
DO HOME^%ZIS
End DoDot:2
QUIT
+38 SET RCALL=0
+39 DO VPOUT^RCDPEX3
End DoDot:1
IF RCER
GOTO XFRQ
+40 ;
+41 SET RCWHY(1)="Transfer EEOB detail to another site"
+42 SET RC=0
FOR
SET RC=$ORDER(RCDA(RC))
if 'RC
QUIT
Begin DoDot:1
+43 NEW RCBODY,RCAMT,RCBILL,RCX,XMZ
+44 SET RCXDA=+RCDA(RC)
SET RCXDA1=+$PIECE(RCDA(RC),U,2)
SET RCWHY(2)=""
+45 IF '$$LOCK^RCDPEX31(RCXDA,RCXDA1,1)
Begin DoDot:2
+46 SET RCECT=RCECT+1
SET RCER(RCECT)="**Selection #"_RC_" is being edited by another user - ... please try again later"
End DoDot:2
QUIT
+47 ;
+48 SET RC0=$GET(^RCY(344.4,RCXDA,1,RCXDA1,0))
+49 MERGE RCBODY=^RCY(344.4,RCXDA,1,RCXDA1,1)
+50 SET RCAMT=$PIECE(RC0,U,3)*100
+51 SET RCBILL=$PIECE(RC0,U,5)
+52 SET DIR("A",1)="ONCE THIS EEOB HAS BEEN TRANSFERRED, ITS BILL # CANNOT BE EDITED"
SET DIR("A")="ARE YOU SURE THIS IS NOT A CLAIM FOR YOUR SITE?: "
SET DIR(0)="YA"
SET DIR("B")="NO"
WRITE !
DO ^DIR
KILL DIR
+53 if Y'=1
QUIT
+54 IF $PIECE(RC0,U,11)
Begin DoDot:2
+55 SET RCOK=1
+56 SET DIR("A",1)="WARNING: EEOB FOR #"_RC_" ("_RCBILL_") HAS ALREADY BEEN TRANSFERRED"
SET DIR("A",2)=" TO "_$PIECE($GET(^DIC(4,+$PIECE(RC0,U,11),0)),U)_" ON: "_$$FMTE^XLFDT($PIECE(RC0,U,12),2)
+57 SET DIR("A")="ARE YOU SURE YOU WANT TO TRANSFER IT AGAIN?: "
+58 SET DIR(0)="YA"
SET DIR("B")="NO"
WRITE !
DO ^DIR
KILL DIR
+59 IF Y=1
QUIT
+60 SET RCOK=0
+61 SET RCECT=RCECT+1
SET RCER(RCECT)="**Selection #"_RC_" already transferred - "_RCBILL_" NOT transferred again"
End DoDot:2
if 'RCOK
QUIT
+62 KILL RCBODY(0)
+63 SET RCX=$GET(RCBODY(1,0))
+64 ;
+65 IF $PIECE($GET(^RCY(344.4,RCXDA,1,RCXDA1,0)),U,7)'=1
Begin DoDot:2
+66 SET RCECT=RCECT+1
SET RCER(RCECT)="**Selection #"_RC_" is not available for transfer - "_RCBILL_" NOT transferred"
End DoDot:2
QUIT
+67 ;
+68 IF $PIECE(RCX,U)'["835ERA"!'$ORDER(RCBODY(1))
Begin DoDot:2
+69 SET RCECT=RCECT+1
SET RCER(RCECT)="**Selection #"_RC_" format is not valid for transfer - "_RCBILL_" NOT transferred"
End DoDot:2
QUIT
+70 ;
+71 SET $PIECE(RCX,U)="835XFR"
SET $PIECE(RCX,U,10,15)=(RCAMT_"^^^^^")
+72 SET $PIECE(RCX,U,19)=RCCONT
+73 SET RCBODY(1,0)=RCX
+74 SET RCBODY(+$ORDER(RCBODY(""),-1)+1,0)="99^$"
+75 SET RCBODY(+$ORDER(RCBODY(""),-1)+1,0)="NNNN"
+76 SET XMTO("S.RCDPE EDI LOCKBOX SERVER@"_RCDOMAIN)=""
+77 SET XMBODY="RCBODY"
SET RCDUZ=$GET(DUZ)
SET DUZ=.5
+78 DO SENDMSG^XMXAPI(.5,"TRANSFER 3RD PARTY EEOB "_RCBILL_"(REF #"_RCXDA_";"_RCXDA1_"#)",XMBODY,.XMTO,,.XMZ)
+79 ;
+80 SET DUZ=RCDUZ
+81 ; Report msg #
IF $GET(XMZ)
Begin DoDot:2
+82 SET RCCHG=1
+83 SET RCECT=RCECT+1
SET RCER(RCECT)="Entry #"_RC_" was successfully transferred - msg # is "_XMZ
+84 SET DA(1)=RCXDA
SET DA=RCXDA1
SET DIE="^RCY(344.4,"_DA(1)_",1,"
SET DR=".09////"_XMZ_";.11////"_RCXTO_";.12////"_$EXTRACT($$NOW^XLFDT(),1,12)
DO ^DIE
+85 SET RCWHY(2)=" Transfer to "_$PIECE($GET(^DIC(4,+RCXTO,0)),U)_" was successful"
+86 ;
End DoDot:2
+87 ; error - transfer not done
IF '$TEST
Begin DoDot:2
+88 SET RCECT=RCECT+1
SET RCER(RCECT)="**Entry #"_RC_" was NOT transferred due to a msg build error ("_RCBILL_")"
+89 SET RCWHY(2)=" Transfer to "_$PIECE($GET(^DIC(4,+RCXTO,0)),U)_" was UNSUCCESSFUL"
+90 ;
End DoDot:2
+91 DO STORACT^RCDPEX31(RCXDA,RCXDA1,.RCWHY)
End DoDot:1
LOCK -^RCY(344.4,RCXDA,1,RCXDA1,0)
+92 ;
+93 IF $ORDER(RCER(0))
Begin DoDot:1
+94 ; Write msgs
+95 WRITE !!,"TRANSFER OF EEOB TO "_$PIECE($GET(^DIC(4,RCXTO,0)),U)_" RESULTS: ",!
+96 SET RCECT=0
FOR
SET RCECT=$ORDER(RCER(RCECT))
if 'RCECT
QUIT
WRITE !," ",RCER(RCECT)
+97 WRITE !
End DoDot:1
+98 ;
+99 DO PAUSE^VALM1
+100 ;
XFRQ IF $GET(RCCHG)
DO BLD^RCDPEX2
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
SEL(RCDA,ONE) ; Select entry(s) from list
+1 ; RCDA = array returned if selections made
+2 ; RCDA(n)=ien of bill selected file 344.4
+3 ; ONE = if set to 1, only one selection can be made at a time
+4 NEW RC
+5 KILL RCDA
+6 DO EN^VALM2($GET(XQORNOD(0)),$SELECT('$GET(ONE):"",1:"S"))
+7 SET RCDA=0
FOR
SET RCDA=$ORDER(VALMY(RCDA))
if 'RCDA
QUIT
SET RC=$GET(^TMP("RCDPEX_SUM-EOBDX",$JOB,RCDA))
SET RCDA(RCDA)=+$PIECE(RC,U,2)_U_+$PIECE(RC,U,3)
+8 QUIT
+9 ;
HDR(RCPG) ;Print report hdr
+1 ; RCPG = last page #
+2 IF RCPG!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF,*13
+3 SET RCPG=$GET(RCPG)+1
+4 WRITE !,?5,"EDI LOCKBOX EEOB DATA EXCEPTIONS - EEOB DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TRANSLATE($JUSTIFY("",IOM)," ","=")
+5 QUIT
+6 ;
ASK(RCSTOP) ;
+1 IF $EXTRACT(IOST,1,2)'["C-"
QUIT
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
+4 IF ($DATA(DIRUT))!($DATA(DUOUT))
SET RCSTOP=1
QUIT
+5 QUIT
+6 ; ***
+7 ; *** Entrypoints TXT* assume these variable definitions ***
+8 ; ***
+9 ; FUNCTIONs returns RCXM1 and RC if passed by reference
+10 ; RCTDA = ien, file 344.4
+11 ; RCXM1 = array returned with text, captioned
+12 ; RC = # of lines already in array (optional)
+13 ; RCDIQ and RCDIQ1 = arrays returned from GETS^DIQ
+14 ; ***
+15 ;
UPD ; Try to update the IB EOB file from exception in 344.41
+1 ; Moved for space
DO UPD^RCDPEX31
+2 QUIT
+3 ;
