- 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 Jan 18, 2025@02:47:11 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 ;