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,371**;Mar 20, 1995;Build 29
;;Per VHA Directive 6402, 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,PRCFDA
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
; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
S PRCFDA(430,PRCABN_",",71)=$G(^PRCA(430,PRCABN,7))+PRCAMT,PRCA("STATUS")=$O(^PRCA(430.3,"AC",120,0)) D FILE^DIE(,"PRCFDA"),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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCARFD1 6216 printed Sep 11, 2024@02:01:19 Page 2
PRCARFD1 ;WASH-ISC@ALTOONA,PA/LDB-APPROVE REFUND AND GENERATE FMS DOC ;2/14/96 9:13 AM
+1 ;;4.5;Accounts Receivable;**21,36,90,104,141,190,204,203,207,220,238,371**;Mar 20, 1995;Build 29
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
APPRV ;Enter Elec sig for CFO
+1 NEW ADD,DA,ENT,ERROR,PRCABN0,PRCANM,RA,TIME,X,Y
+2 FOR X=1:1:5
SET RA=+$GET(RA)+$PIECE($GET(^PRCA(430,PRCABN,7)),U,X)
+3 IF +$GET(RA)'=$PIECE($GET(^PRCA(430,PRCABN,7)),U,18)
WRITE !!,"REFUND AMOUNT OUT-OF-BALANCE!"
QUIT
+4 SET DA=+PRCABN
DO SIG^PRCASIG
IF $GET(PRCANM)']""
WRITE !!,"DID NOT APPROVE REFUND"
QUIT
+5 LOCK +^PRCA(430,PRCABN):1
if '$TEST
QUIT
SET $PIECE(^PRCA(430,PRCABN,9),U,2)=PRCANM
SET $PIECE(^(9),U,1)=DUZ
SET $PIECE(^(9),U,3)=$GET(DT)
LOCK -^PRCA(430,PRCABN)
WRITE !," <APPROVED BY CERTIFYING OFFICER>"
+6 IF $GET(^PRCA(430,PRCABN,7))'>0
WRITE !!,*7,"This Accounts Receivable doesn't have an excess payment !"
DO CANC^PRCARFD(PRCABN)
WRITE !!,"Status Changed to 'CANCELLATION'",!
QUIT
+7 WRITE *7,!!,"No other transactions may be made to the bill now."
+8 ;
FMSDOC ;Create FMS overcollection payment voucher document
+1 ;
+2 NEW %,ADD,GECSFMS,DATE,DEBT,DY,MO,PRCA,PRCANM,STAT,YR,DOC
+3 IF '$DATA(^PRCA(430,+$GET(PRCABN),0))
WRITE !,"THIS BILL NUMBER ENTRY IN FILE 430 IS CORRUPTED",!,"NO PROCESSING CAN CONTINUE - SEE IRM"
QUIT
+4 SET PRCABN0=$GET(^PRCA(430,+PRCABN,0))
SET PRCANM=$PIECE(PRCABN0,"^")
+5 SET STAT=$$GSTAT^RCFMFN02(PRCANM)
+6 IF STAT>0&(STAT<3)
WRITE !!,*7,"THIS DOCUMENT SEEMS TO HAVE ALREADY BEEN SENT TO FMS-",!,"IT CANNOT BE RESENT UNLESS FMS REJECTS IT."
QUIT
FMS WRITE !!,"Creating an FMS Overcollection Payment Voucher . . .",!
+1 SET PRCA("STN")=$PIECE($PIECE(PRCABN0,U),"-")
+2 SET DEBT=+$PIECE(PRCABN0,U,9)
SET DEBT=$PIECE($GET(^RCD(340,DEBT,0)),U)
+3 SET PRCA("VNAME")=$$NAM^RCFN01(DEBT)
IF PRCA("VNAME")=""
SET ADD=0
+4 SET PRCA("VNAME")=$PIECE(PRCA("VNAME"),",",2)_" "_$PIECE(PRCA("VNAME"),",")
+5 SET PRCA("VCODE")=$$SSN^RCFN01(DEBT)
+6 SET ADD=1
+7 SET PRCA("ADD")=$$DADD^RCAMADD(DEBT,1)
+8 SET PRCA("VADD1")=$PIECE(PRCA("ADD"),U)
IF PRCA("VADD1")=""
SET ADD=0
+9 SET PRCA("VADD2")=$PIECE(PRCA("ADD"),U,2)
+10 SET PRCA("VCITY")=$PIECE(PRCA("ADD"),U,4)
IF PRCA("VCITY")=""
SET ADD=0
+11 SET PRCA("VSTATE")=$PIECE(PRCA("ADD"),U,5)
IF PRCA("VSTATE")=""
SET ADD=0
+12 SET PRCA("VZIP")=$PIECE(PRCA("ADD"),U,6)
IF PRCA("VZIP")=""
SET ADD=0
+13 SET PRCA("LAMT")=$PIECE($GET(^PRCA(430,+PRCABN,7)),U,18)
+14 SET PRCANM=$PIECE($GET(^PRCA(430,+PRCABN,0)),U)
+15 IF 'ADD
Begin DoDot:1
+16 WRITE *7,!,"THIS PATIENT DOES NOT HAVE A VALID ADDRESS."
+17 WRITE !,"AN FMS DOCUMENT CANNOT BE CREATED WITHOUT A VALID ADDRESS."
+18 QUIT
End DoDot:1
QUIT
+19 IF '$GET(REFMS)&(DT>$$LDATE^RCRJR(DT))
SET Y=$EXTRACT($$FPS^RCAMFN01(DT,1),1,5)_"01"
DO DD^%DT
WRITE !!," * * * * Transmission will be held until "_Y_" * * * *",!
+20 DO NOW^%DTC
SET YR=$EXTRACT(%,2,3)
SET MO=$EXTRACT(%,4,5)
SET DY=$EXTRACT(%,6,7)
+21 SET Y=$PIECE(%,".")
XECUTE ^DD("DD")
SET DATE=$PIECE(Y,",",2)_MO_DY
+22 SET TIME=$PIECE(%,".",2)
+23 SET PRCA("FY")=$$FY^RCFN01($PIECE(%,"."))
+24 SET PRCA("LAMT")=$JUSTIFY(PRCA("LAMT"),0,2)
+25 DO CONTROL^GECSUFMS("A",PRCA("STN"),PRCANM,"OP",10,0,"","")
+26 ;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
+27 IF '$DATA(GECSFMS("DA"))
WRITE !,"AN ENTRY WAS NOT MADE IN THE STACKER FILE.",!,"PLEASE RE-SELECT THE BILL IN THE APPROVE OPTION."
QUIT
+28 SET DOC=$SELECT($GET(GECSFMS("DOC"))]"":$PIECE(GECSFMS("DOC"),"^",3)_"-"_$PIECE(GECSFMS("DOC"),"^",4),1:PRCANM)
+29 DO OPEN^RCFMDRV1(DOC,5,"B"_PRCABN,.ENT,.ERROR,PRCABN)
+30 IF ERROR]""
WRITE !!,*7,"AN AR DOC REF CANNOT BE CREATED BECAUSE THE FOLLOWING ERROR HAS OCCURRED -",!?10,ERROR,!
+31 NEW FMSDT
SET FMSDT=$$FMSDATE^RCBEUTRA(DT)
+32 SET ^TMP($JOB,"PRCA",1)="PV2^"_$EXTRACT(FMSDT,4,5)_U_$EXTRACT(FMSDT,6,7)_U_$EXTRACT(FMSDT,2,3)_"^^^^^E^01^^^^^^^^^^MISCVET^^"_PRCA("LAMT")_"^"
+33 SET ^TMP($JOB,"PRCA",2)=PRCA("VNAME")_U_$EXTRACT(PRCA("VADD1"),1,30)_U_$EXTRACT(PRCA("VADD2"),1,30)_U_PRCA("VCITY")_U_PRCA("VSTATE")_U_PRCA("VZIP")_"^~"
+34 Begin DoDot:1
+35 NEW PRCAPT
+36 SET PRCAPT=$SELECT(DT<3030926:5287,$GET(REFMS)&(DT<3031001):5287,DT'<3030926&(DT<$$ADDPTEDT^PRCAACC()):5287.3,1:528703)
+37 ; FY
if $EXTRACT(PRCAPT,1,4)=5287
SET PRCA("FY")="05"
+38 SET ^TMP($JOB,"PRCA",3)="LIN^~PVA^001^^^^^^^^^^^"_PRCA("FY")_"^^"_PRCAPT_"^"_PRCA("STN")_"^^^^^^^^^^^"_$$CALCRSC^RCXFMSUR(+PRCABN)_"^^^^^^"_PRCA("LAMT")_"^I^~"
+39 ;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^~"
End DoDot:1
+40 SET DA=0
FOR
SET DA=$ORDER(^TMP($JOB,"PRCA",DA))
if 'DA
QUIT
Begin DoDot:1
+41 DO SETCS^GECSSTAA(GECSFMS("DA"),^TMP($JOB,"PRCA",DA))
End DoDot:1
+42 DO SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
+43 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+44 DO SSTAT^RCFMFN02("B"_+$GET(PRCABN),1)
+45 if $PIECE($GET(^PRCA(430,+$GET(PRCABN),0)),U,8)=$ORDER(^PRCA(430.3,"AC",41,0))
QUIT
+46 KILL ^TMP($JOB)
+47 ;Pass to FMS
+48 ;Call generic interface to setup document if completed flag proceed
+49 ;change date if resent to FMS
+50 ;
TREF ;Create REFUNDED transaction and set to REFUNDED status
+1 NEW DIE,DR,DA,PRCASVC,PRCAA2,PRCAEN,PRCAMT,X,Y,DIR,DEBTOR,CLYRRF,PRCFDA
+2 SET U="^"
+3 IF $PIECE($GET(^PRCA(430,+PRCABN,0)),U,8)=$ORDER(^PRCA(430.3,"AC",120,0))
QUIT
+4 DO SETTR^PRCAUTL
IF '$GET(PRCAEN)
WRITE !!,"COULD NOT SET UP A REFUND TRANSACTION!"
QUIT
+5 WRITE !!,"Creating a REFUNDED transaction for bill number: ",$PIECE(^PRCA(430,PRCABN,0),"^")," . . .",!
+6 DO PATTR^PRCAUTL
SET PRCA("ADJ")=$ORDER(^PRCA(430.3,"AC",120,0))
SET PRCASV("BDT")=$GET(DT)
SET PRCASV("APR")=DUZ
SET PRCASV("FY")="^"_+$PIECE($GET(^PRCA(430,PRCABN,7)),U,18)
+7 SET DIE="^PRCA(433,"
SET DR="[PRCA FY ADJ2 BATCH]"
SET DA=PRCAEN
DO ^DIE
+8 SET PRCAMT=-$GET(PRCAMT)
SET PRCAA2=$PIECE(^PRCA(433,PRCAEN,4,0),U,3)
+9 DO UPFY^PRCADJ
DO TRANUP^PRCAUTL
+10 ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
+11 SET PRCFDA(430,PRCABN_",",71)=$GET(^PRCA(430,PRCABN,7))+PRCAMT
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",120,0))
DO FILE^DIE(,"PRCFDA")
DO UPSTATS^PRCAUT2
+12 WRITE !,"Bill is now in REFUNDED status.",!
+13 ;CHECK TO SEE IF TOP REFUND AND SET UP FIELDS TO SEND WITH NEXT
+14 ;TOP TRANSMISSION
+15 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Is this a TOP Refund"
SET DIR("??")="Enter 'YES' only if this is a refund of a payment from TOP"
+16 DO ^DIR
if 'Y
QUIT
+17 SET DEBTOR=$PIECE(^PRCA(430,PRCABN,0),U,9)
if 'DEBTOR
QUIT
+18 SET TRACE=$PIECE($GET(^RCD(340,DEBTOR,6)),U,7)
+19 IF $LENGTH(TRACE)'=10
WRITE !,*7,"There is no valid trace number entered for this debtor",!,"Cannot process as TOP refund."
QUIT
+20 SET CLYRRF=$EXTRACT(DT,1,3)+1700
SET DA=PRCABN
+21 SET DIE="^PRCA(430,"
SET DR="144//^S X=CLYRRF;142////1;143///^S X=TRACE"
+22 SET DA=PRCABN
SET DIE("NO^")=1
DO ^DIE
+23 WRITE !,"TOP REFUND DOCUMENT WILL BE SENT WITH NEXT TOP TRANSMISSION"
+24 QUIT
+25 ;
