source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCARFD1.m@ 1154

PRCARFD1 ;WASH-ISC@ALTOONA,PA/LDB-APPROVE REFUND AND GENERATE FMS DOC ;2/14/96  9:13 AM
 ;;4.5;Accounts Receivable;**21,36,90,104,141,190,204,203,207,220,238**;Mar 20, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
APPRV ;Enter Elec sig for CFO
 N ADD,DA,ENT,ERROR,PRCABN0,PRCANM,RA,TIME,X,Y
 F X=1:1:5 S RA=+$G(RA)+$P($G(^PRCA(430,PRCABN,7)),U,X)
 I +$G(RA)'=$P($G(^PRCA(430,PRCABN,7)),U,18) W !!,"REFUND AMOUNT OUT-OF-BALANCE!" Q
 S DA=+PRCABN D SIG^PRCASIG I $G(PRCANM)']"" W !!,"DID NOT APPROVE REFUND" Q
 L +^PRCA(430,PRCABN):1 Q:'$T  S $P(^PRCA(430,PRCABN,9),U,2)=PRCANM,$P(^(9),U,1)=DUZ,$P(^(9),U,3)=$G(DT) L -^PRCA(430,PRCABN) W !," <APPROVED BY CERTIFYING OFFICER>"
 I $G(^PRCA(430,PRCABN,7))'>0 W !!,*7,"This Accounts Receivable doesn't have an excess payment !" D CANC^PRCARFD(PRCABN) W !!,"Status Changed to 'CANCELLATION'",! Q
 W *7,!!,"No other transactions may be made to the bill now."
 ;
FMSDOC ;Create FMS overcollection payment voucher document
 ;
 N %,ADD,GECSFMS,DATE,DEBT,DY,MO,PRCA,PRCANM,STAT,YR,DOC
 I '$D(^PRCA(430,+$G(PRCABN),0)) W !,"THIS BILL NUMBER ENTRY IN FILE 430 IS CORRUPTED",!,"NO PROCESSING CAN CONTINUE - SEE IRM" Q
 S PRCABN0=$G(^PRCA(430,+PRCABN,0)),PRCANM=$P(PRCABN0,"^")
 S STAT=$$GSTAT^RCFMFN02(PRCANM)
 I STAT>0&(STAT<3) W !!,*7,"THIS DOCUMENT SEEMS TO HAVE ALREADY BEEN SENT TO FMS-",!,"IT CANNOT BE RESENT UNLESS FMS REJECTS IT." Q
FMS W !!,"Creating an FMS Overcollection Payment Voucher . . .",!
 S PRCA("STN")=$P($P(PRCABN0,U),"-")
 S DEBT=+$P(PRCABN0,U,9),DEBT=$P($G(^RCD(340,DEBT,0)),U)
 S PRCA("VNAME")=$$NAM^RCFN01(DEBT) I PRCA("VNAME")="" S ADD=0
 S PRCA("VNAME")=$P(PRCA("VNAME"),",",2)_" "_$P(PRCA("VNAME"),",")
 S PRCA("VCODE")=$$SSN^RCFN01(DEBT)
 S ADD=1
 S PRCA("ADD")=$$DADD^RCAMADD(DEBT,1)
 S PRCA("VADD1")=$P(PRCA("ADD"),U) I PRCA("VADD1")="" S ADD=0
 S PRCA("VADD2")=$P(PRCA("ADD"),U,2)
 S PRCA("VCITY")=$P(PRCA("ADD"),U,4) I PRCA("VCITY")="" S ADD=0
 S PRCA("VSTATE")=$P(PRCA("ADD"),U,5) I PRCA("VSTATE")="" S ADD=0
 S PRCA("VZIP")=$P(PRCA("ADD"),U,6) I PRCA("VZIP")="" S ADD=0
 S PRCA("LAMT")=$P($G(^PRCA(430,+PRCABN,7)),U,18)
 S PRCANM=$P($G(^PRCA(430,+PRCABN,0)),U)
 I 'ADD D  Q
 .W *7,!,"THIS PATIENT DOES NOT HAVE A VALID ADDRESS."
 .W !,"AN FMS DOCUMENT CANNOT BE CREATED WITHOUT A VALID ADDRESS."
 .Q
 I '$G(REFMS)&(DT>$$LDATE^RCRJR(DT)) S Y=$E($$FPS^RCAMFN01(DT,1),1,5)_"01" D DD^%DT W !!,"   * * * * Transmission will be held until "_Y_" * * * *",!
 D NOW^%DTC S YR=$E(%,2,3),MO=$E(%,4,5),DY=$E(%,6,7)
 S Y=$P(%,".") X ^DD("DD") S DATE=$P(Y,",",2)_MO_DY
 S TIME=$P(%,".",2)
 S PRCA("FY")=$$FY^RCFN01($P(%,"."))
 S PRCA("LAMT")=$J(PRCA("LAMT"),0,2)
 D CONTROL^GECSUFMS("A",PRCA("STN"),PRCANM,"OP",10,0,"","")
 ;S FMSTRING("CTL")="CTL^FMS^"_PRCA("STN")^DOC^OP^10^^"_PRCA("STN")_PRCA("FY")_SEQ_U_YYYYMMDD_U_TIME_U_SEQ_U_PRCANM_"^ARS"_PRCA("STN")_U_VER
 I '$D(GECSFMS("DA")) W !,"AN ENTRY WAS NOT MADE IN THE STACKER FILE.",!,"PLEASE RE-SELECT THE BILL IN THE APPROVE OPTION." Q
 S DOC=$S($G(GECSFMS("DOC"))]"":$P(GECSFMS("DOC"),"^",3)_"-"_$P(GECSFMS("DOC"),"^",4),1:PRCANM)
 D OPEN^RCFMDRV1(DOC,5,"B"_PRCABN,.ENT,.ERROR,PRCABN)
 I ERROR]"" W !!,*7,"AN AR DOC REF CANNOT BE CREATED BECAUSE THE FOLLOWING ERROR HAS OCCURRED -",!?10,ERROR,!
 N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
 S ^TMP($J,"PRCA",1)="PV2^"_$E(FMSDT,4,5)_U_$E(FMSDT,6,7)_U_$E(FMSDT,2,3)_"^^^^^E^01^^^^^^^^^^MISCVET^^"_PRCA("LAMT")_"^"
 S ^TMP($J,"PRCA",2)=PRCA("VNAME")_U_$E(PRCA("VADD1"),1,30)_U_$E(PRCA("VADD2"),1,30)_U_PRCA("VCITY")_U_PRCA("VSTATE")_U_PRCA("VZIP")_"^~"
 D
 . N PRCAPT
 . S PRCAPT=$S(DT<3030926:5287,$G(REFMS)&(DT<3031001):5287,DT'<3030926&(DT<$$ADDPTEDT^PRCAACC()):5287.3,1:528703)
 .S:$E(PRCAPT,1,4)=5287 PRCA("FY")="05" ; FY
 .S ^TMP($J,"PRCA",3)="LIN^~PVA^001^^^^^^^^^^^"_PRCA("FY")_"^^"_PRCAPT_"^"_PRCA("STN")_"^^^^^^^^^^^"_$$CALCRSC^RCXFMSUR(+PRCABN)_"^^^^^^"_PRCA("LAMT")_"^I^~"
 .;S ^TMP($J,"PRCA",3)="LIN^~PVA^001^^^^^^^^^^^"_PRCA("FY")_"^^"_$S(DT<3030926:5287,$G(REFMS)&(DT<3031001):5287,1:528703)_"^"_PRCA("STN")_"^^^^^^^^^^^"_$$CALCRSC^RCXFMSUR(+PRCABN)_"^^^^^^"_PRCA("LAMT")_"^I^~"
 S DA=0 F  S DA=$O(^TMP($J,"PRCA",DA)) Q:'DA  D
 .D SETCS^GECSSTAA(GECSFMS("DA"),^TMP($J,"PRCA",DA))
 D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
 D SSTAT^RCFMFN02("B"_+$G(PRCABN),1)
 Q:$P($G(^PRCA(430,+$G(PRCABN),0)),U,8)=$O(^PRCA(430.3,"AC",41,0))
 K ^TMP($J)
 ;Pass to FMS
 ;Call generic interface to setup document if completed flag proceed
 ;change date if resent to FMS
 ;
TREF ;Create REFUNDED transaction and set to REFUNDED status
 N DIE,DR,DA,PRCASVC,PRCAA2,PRCAEN,PRCAMT,X,Y,DIR,DEBTOR,CLYRRF
 S U="^"
 I $P($G(^PRCA(430,+PRCABN,0)),U,8)=$O(^PRCA(430.3,"AC",120,0)) Q
 D SETTR^PRCAUTL I '$G(PRCAEN) W !!,"COULD NOT SET UP A REFUND TRANSACTION!" Q
 W !!,"Creating a REFUNDED transaction for bill number: ",$P(^PRCA(430,PRCABN,0),"^")," . . .",!
 D PATTR^PRCAUTL S PRCA("ADJ")=$O(^PRCA(430.3,"AC",120,0)),PRCASV("BDT")=$G(DT),PRCASV("APR")=DUZ,PRCASV("FY")="^"_+$P($G(^PRCA(430,PRCABN,7)),U,18)
 S DIE="^PRCA(433,",DR="[PRCA FY ADJ2 BATCH]",DA=PRCAEN D ^DIE
 S PRCAMT=-$G(PRCAMT),PRCAA2=$P(^PRCA(433,PRCAEN,4,0),U,3)
 D UPFY^PRCADJ,TRANUP^PRCAUTL
 S $P(^PRCA(430,PRCABN,7),U,1)=$G(^PRCA(430,PRCABN,7))+PRCAMT,PRCA("STATUS")=$O(^PRCA(430.3,"AC",120,0)) D UPSTATS^PRCAUT2
 W !,"Bill is now in REFUNDED status.",!
 ;CHECK TO SEE IF TOP REFUND AND SET UP FIELDS TO SEND WITH NEXT
 ;TOP TRANSMISSION
 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Is this a TOP Refund",DIR("??")="Enter 'YES' only if this is a refund of a payment from TOP"
 D ^DIR Q:'Y
 S DEBTOR=$P(^PRCA(430,PRCABN,0),U,9) Q:'DEBTOR
 S TRACE=$P($G(^RCD(340,DEBTOR,6)),U,7)
 I $L(TRACE)'=10 W !,*7,"There is no valid trace number entered for this debtor",!,"Cannot process as TOP refund." Q
 S CLYRRF=$E(DT,1,3)+1700,DA=PRCABN
 S DIE="^PRCA(430,",DR="144//^S X=CLYRRF;142////1;143///^S X=TRACE"
 S DA=PRCABN,DIE("NO^")=1 D ^DIE
 W !,"TOP REFUND DOCUMENT WILL BE SENT WITH NEXT TOP TRANSMISSION"
 Q
 ;