Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCDPEX3

RCDPEX3.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ; IA# 5286 for call to $$PRVPHONE^IBJPS3()
  1. Q
  1. ;
  1. VP ; View/Print ERA Msgs - File 344.4
  1. N X,Y,RCDA,RCTDA,RCALL,DIR,POP
  1. D FULL^VALM1
  1. S DIR(0)="SA^A:ALL;S:SELECTED",DIR("A")="PRINT (A)LL or (S)ELECTED RECORDS?: "
  1. S DIR("B")="ALL"
  1. D ^DIR K DIR
  1. G:$D(DUOUT)!$D(DTOUT) VPQ
  1. S RCALL=(Y="A")
  1. ;
  1. I 'RCALL D G:'$O(RCDA("")) VPQ
  1. . D SEL(.RCDA)
  1. ;
  1. ; device
  1. N %ZIS,ZTRTN,ZTSAVE,ZTDESC
  1. S %ZIS="QM" D ^%ZIS G:POP VPQ
  1. I $D(IO("Q")) D G VPQ
  1. . S ZTRTN="VPOUT^RCDPEX3",ZTDESC="AR - Print ERA/EEOB Data With Exceptions"
  1. . S ZTSAVE("RCDA")="",ZTSAVE("RCALL")="",ZTSAVE("^TMP(""RCDPEX_SUM-EOBDX"",$J,")=""
  1. . D ^%ZTLOAD
  1. . W !!,$S($D(ZTSK):"Your task number"_ZTSK_" has been queued.",1:"Unable to queue this job.")
  1. . K ZTSK,IO("Q") D HOME^%ZIS
  1. U IO
  1. ;
  1. VPOUT ; Entrypoint queued job
  1. ; RCDA, RCALL must be defined
  1. N Z,RCSTOP,RCZ,RCPG,RCDOT,RCTDA1
  1. K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT")
  1. S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)=""
  1. I RCALL D
  1. . 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
  1. .. D PRT(RCTDA,RCTDA1,.RCPG,.RCSTOP)
  1. .. I $O(^TMP("RCDPEX_SUM-EOBDX",$J,RCZ)) D WRTSEP(RCDOT,RCPG)
  1. I 'RCALL D
  1. . S RCZ=0 F S RCZ=$O(RCDA(RCZ)) Q:'RCZ D
  1. .. S RCTDA1=+$P(RCDA(RCZ),U,2),RCTDA=+RCDA(RCZ) D PRT(RCTDA,RCTDA1,.RCPG,.RCSTOP) I $O(RCDA(RCZ)) D WRTSEP(RCDOT,RCPG)
  1. ;
  1. I '$D(ZTQUEUED),'RCSTOP,RCPG D ASK(.RCSTOP)
  1. ;
  1. I $D(ZTQUEUED) S ZTREQ="@"
  1. I '$D(ZTQUEUED) D ^%ZISC
  1. ;
  1. VPQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT")
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. WRTSEP(RCDOT,RCPG) ; Separating lines if more records to print
  1. W !,RCDOT,!,RCDOT
  1. I (($Y+5)>IOSL) D HDR(.RCPG) Q
  1. W !!
  1. Q
  1. ;
  1. PRT(RCTDA,RCTDA1,RCPG,RCSTOP) ; Print data from file 344.4 and 344.41
  1. ; RCTDA = ien file 344.4
  1. ; RCTDA1 = ien file 344.41
  1. ; RCPG = last page extracted
  1. ; RCSTOP = returned 1 if passed by ref and process stopped
  1. ;
  1. N RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,Z
  1. D GETS^DIQ(344.4,RCTDA_",","*","IEN","RCDIQ")
  1. D TXT0^RCDPEX31(RCTDA,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned fields
  1. ;
  1. I $O(^RCY(344.4,RCTDA,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**"
  1. S Z=0 F S Z=$O(^RCY(344.4,RCTDA,2,Z)) Q:'Z D
  1. . D GETS^DIQ(344.42,Z_","_RCTDA_",","*","IEN","RCDIQ2")
  1. . D TXT2^RCDPEX31(RCTDA,Z,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs
  1. ;
  1. D GETS^DIQ(344.41,RCTDA1_","_RCTDA_",","*","IEN","RCDIQ1")
  1. D TXT00^RCDPEX31(RCTDA,RCTDA1,.RCDIQ1,.RCXM1,.RC)
  1. D DISP^RCDPESR0("^RCY(344.4,"_RCTDA_",1,"_RCTDA1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75) ; Get formatted 'raw' data
  1. ;
  1. I $D(RCDIQ1(344.41,RCTDA1_","_RCTDA_",",2)) D
  1. . S RC=RC+1,RCXM1(RC)=" **RESOLUTION LOG DATA**"
  1. . 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)
  1. . S RC=RC+1,RCXM1(RC)=" "
  1. S (RCSTOP,Z)=0
  1. F S Z=$O(RCXM1(Z)) Q:'Z S ^TMP($J,"RC_SUMOUT",Z-999)=RCXM1(Z)
  1. S Z=""
  1. F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z D Q:RCSTOP
  1. . I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q
  1. . I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q
  1. .. D:RCPG ASK(.RCSTOP) I RCSTOP Q
  1. .. D HDR(.RCPG)
  1. . W !,$G(^TMP($J,"RC_SUMOUT",Z))
  1. ;
  1. K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT") ; Clear arrays before next exception - PRCA*4.5*321
  1. Q
  1. ;
  1. XFR ; Transfer EOB(s) to other site
  1. 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
  1. D FULL^VALM1
  1. D SEL(.RCDA)
  1. ;
  1. G:'$O(RCDA(0)) XFRQ
  1. S DIR("S")="I +$G(^DIC(4,+Y,6))",DIR(0)="PA^4:AME",DIR("A")="TRANSFER TO WHICH SITE?: " D ^DIR K DIR
  1. I $D(DUOUT)!$D(DTOUT) G XFRQ
  1. S RCXTO=+Y,RCCHG=0
  1. ;
  1. S RCDOMAIN=$$EXTERNAL^DILFD(4,60,,+$G(^DIC(4,+RCXTO,6))),RCECT=0
  1. I RCDOMAIN="" D G XFRQ
  1. . 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
  1. ;
  1. S RCDEF=$$PRVPHONE^IBJPS3() ; IA 5286
  1. I RCDEF'="" S RCDEF="AGENT CASHIER-"_RCDEF
  1. ;
  1. S DIR("A",1)="ENTER THE CONTACT INFORMATION FOR THE PERSON AT YOUR SITE"
  1. S DIR("A",2)=" WHO MAY BE CONTACTED BY THE OTHER SITE REGARDING THIS EEOB"
  1. S DIR("A")=" (1-45 CHARACTERS): "_$S(RCDEF'="":RCDEF_"// ",1:"")
  1. S DIR(0)="FA"_$S(RCDEF'="":"O",1:"")_"^1:45" W ! D ^DIR K DIR
  1. I $D(DUOUT)!$D(DTOUT) G XFRQ
  1. I Y="" S Y=RCDEF
  1. S RCCONT=Y
  1. ;
  1. S DIR(0)="YA",DIR("A")="DO YOU WANT TO PRINT THE EEOB(s)?: ",DIR("B")="Y"
  1. D ^DIR K DIR
  1. I $D(DUOUT)!$D(DTOUT) G XFRQ
  1. I Y=1 S RCER=0 D I RCER G XFRQ
  1. . N %ZIS,ZTRTN,ZTSAVE,ZTDESC
  1. . S %ZIS="QM" D ^%ZIS I POP S RCER=1 Q
  1. . I $D(IO("Q")) D Q
  1. .. S RCALL=0
  1. .. S ZTRTN="VPOUT^RCDPEX3",ZTDESC="AR - Print EEOB Data Before Transfer"
  1. .. S ZTSAVE("RCDA")="",ZTSAVE("RCALL")="",ZTSAVE("^TMP(""RCDPEX_SUM-EOBDX"",$J)")=""
  1. .. D ^%ZTLOAD
  1. .. I '$D(ZTSK) S RCER=1
  1. .. K ZTSK,IO("Q") D HOME^%ZIS
  1. . S RCALL=0
  1. . D VPOUT^RCDPEX3
  1. ;
  1. S RCWHY(1)="Transfer EEOB detail to another site"
  1. S RC=0 F S RC=$O(RCDA(RC)) Q:'RC D L -^RCY(344.4,RCXDA,1,RCXDA1,0)
  1. . N RCBODY,RCAMT,RCBILL,RCX,XMZ
  1. . S RCXDA=+RCDA(RC),RCXDA1=+$P(RCDA(RC),U,2),RCWHY(2)=""
  1. . I '$$LOCK^RCDPEX31(RCXDA,RCXDA1,1) D Q
  1. .. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" is being edited by another user - ... please try again later"
  1. . ;
  1. . S RC0=$G(^RCY(344.4,RCXDA,1,RCXDA1,0))
  1. . M RCBODY=^RCY(344.4,RCXDA,1,RCXDA1,1)
  1. . S RCAMT=$P(RC0,U,3)*100
  1. . S RCBILL=$P(RC0,U,5)
  1. . 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
  1. . Q:Y'=1
  1. . I $P(RC0,U,11) D Q:'RCOK
  1. .. S RCOK=1
  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)
  1. .. S DIR("A")="ARE YOU SURE YOU WANT TO TRANSFER IT AGAIN?: "
  1. .. S DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR
  1. .. I Y=1 Q
  1. .. S RCOK=0
  1. .. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" already transferred - "_RCBILL_" NOT transferred again"
  1. . K RCBODY(0)
  1. . S RCX=$G(RCBODY(1,0))
  1. . ;
  1. . I $P($G(^RCY(344.4,RCXDA,1,RCXDA1,0)),U,7)'=1 D Q
  1. .. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" is not available for transfer - "_RCBILL_" NOT transferred"
  1. . ;
  1. . I $P(RCX,U)'["835ERA"!'$O(RCBODY(1)) D Q
  1. .. S RCECT=RCECT+1,RCER(RCECT)="**Selection #"_RC_" format is not valid for transfer - "_RCBILL_" NOT transferred"
  1. . ;
  1. . S $P(RCX,U)="835XFR",$P(RCX,U,10,15)=(RCAMT_"^^^^^")
  1. . S $P(RCX,U,19)=RCCONT
  1. . S RCBODY(1,0)=RCX
  1. . S RCBODY(+$O(RCBODY(""),-1)+1,0)="99^$"
  1. . S RCBODY(+$O(RCBODY(""),-1)+1,0)="NNNN"
  1. . S XMTO("S.RCDPE EDI LOCKBOX SERVER@"_RCDOMAIN)=""
  1. . S XMBODY="RCBODY",RCDUZ=$G(DUZ),DUZ=.5
  1. . D SENDMSG^XMXAPI(.5,"TRANSFER 3RD PARTY EEOB "_RCBILL_"(REF #"_RCXDA_";"_RCXDA1_"#)",XMBODY,.XMTO,,.XMZ)
  1. . ;
  1. . S DUZ=RCDUZ
  1. . I $G(XMZ) D ; Report msg #
  1. .. S RCCHG=1
  1. .. S RCECT=RCECT+1,RCER(RCECT)="Entry #"_RC_" was successfully transferred - msg # is "_XMZ
  1. .. 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
  1. .. S RCWHY(2)=" Transfer to "_$P($G(^DIC(4,+RCXTO,0)),U)_" was successful"
  1. .. ;
  1. . E D ; error - transfer not done
  1. .. S RCECT=RCECT+1,RCER(RCECT)="**Entry #"_RC_" was NOT transferred due to a msg build error ("_RCBILL_")"
  1. .. S RCWHY(2)=" Transfer to "_$P($G(^DIC(4,+RCXTO,0)),U)_" was UNSUCCESSFUL"
  1. .. ;
  1. . D STORACT^RCDPEX31(RCXDA,RCXDA1,.RCWHY)
  1. ;
  1. I $O(RCER(0)) D
  1. . ; Write msgs
  1. . W !!,"TRANSFER OF EEOB TO "_$P($G(^DIC(4,RCXTO,0)),U)_" RESULTS: ",!
  1. . S RCECT=0 F S RCECT=$O(RCER(RCECT)) Q:'RCECT W !," ",RCER(RCECT)
  1. . W !
  1. ;
  1. D PAUSE^VALM1
  1. ;
  1. XFRQ I $G(RCCHG) D BLD^RCDPEX2
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. SEL(RCDA,ONE) ; Select entry(s) from list
  1. ; RCDA = array returned if selections made
  1. ; RCDA(n)=ien of bill selected file 344.4
  1. ; ONE = if set to 1, only one selection can be made at a time
  1. N RC
  1. K RCDA
  1. D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S"))
  1. 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)
  1. Q
  1. ;
  1. HDR(RCPG) ;Print report hdr
  1. ; RCPG = last page #
  1. I RCPG!($E(IOST,1,2)="C-") W @IOF,*13
  1. S RCPG=$G(RCPG)+1
  1. W !,?5,"EDI LOCKBOX EEOB DATA EXCEPTIONS - EEOB DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=")
  1. Q
  1. ;
  1. ASK(RCSTOP) ;
  1. I $E(IOST,1,2)'["C-" Q
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="E" W ! D ^DIR
  1. I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q
  1. Q
  1. ; ***
  1. ; *** Entrypoints TXT* assume these variable definitions ***
  1. ; ***
  1. ; FUNCTIONs returns RCXM1 and RC if passed by reference
  1. ; RCTDA = ien, file 344.4
  1. ; RCXM1 = array returned with text, captioned
  1. ; RC = # of lines already in array (optional)
  1. ; RCDIQ and RCDIQ1 = arrays returned from GETS^DIQ
  1. ; ***
  1. ;
  1. UPD ; Try to update the IB EOB file from exception in 344.41
  1. D UPD^RCDPEX31 ; Moved for space
  1. Q
  1. ;