FBPAID ;WOIFO/SAB - SERVER ROUTINE TO UPDATE PAYMENTS ;2/10/2009
;;3.5;FEE BASIS;**5,61,107,121,135**;JAN 30, 1995;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
;incoming record from AAC will contain the following data
; - Fee Program - from Fee Basis Program (161.8)
; - Activity Code (C - confirmed)
; (B - backout)
; (X - cancelled)
; - Internal Control Number - IEN of payment record
; - Check Number
; - Check Date
; - Interest Amount
; - Cancellation Date
; - Reason Code (File # 162.95)
; - Cancellation Code (R - C - X)
; - Disbursed Amount (this amount minus interest amount = amt pd)
; variable 'FBPAID' is defined and passed to TRAP^FBMRASVR2
;
N FBINV
S U="^",FBPAID=1,FBMCNT=0
S X="TRAP^FBMRASV2" S @^%ZOSF("TRAP")
;K XMY S XMY("G.FEE")="" D ENT1^XMD
K ^TMP("FBPAID",$J),^TMP("FBERR",$J)
D STATION^FBAAUTL I $S($G(FB("ERROR")):1,'$G(FBAASN):1,1:0) Q
K FB
;
;FB*3.5*135 Start changes
N FBDATE,FBIBOK
S FBDATE=DT
S FBIBOK=$$IBALLWD^FBPAID3() ;RETURNS 0 if the site has sent the site parameter ALLOW FB PAID TO IB to NO or if it is blank
;FB*3.5*135 End changes
;
;start to read in message from central fee
;edits are:
; 1. invalid station number
; 2. invalid record length
; 3. unable to locate payment record
; 4. disbursed amount '= amt paid+interest
; 5. cancellations
; XMRG=record received in mail message from Austin
F I=1:1 X XMREC Q:XMER<0 I XMRG]"",$E(XMRG,1,3)=FBAASN D
.S ^TMP("FBREC",$J,I)=XMRG
.K FBERR
.I $L(XMRG)'=82&($L(XMRG)'=138) S FBERR=1,^TMP("FBERR",$J,2,I)=""
.D PARSE^FBPAID1 Q:$G(FBERR) S FBMCNT=FBMCNT+1 D @FBPROG
D ^FBPAID2:$D(^TMP("FBERR",$J))
D BUL^FBPAID1
; if any EDI invoices then add to FPPS queue
I $D(FBINV) D PAIDLOG^FBFHLL(.FBINV)
G END
;
3 ;update outpatient payment record
Q:'$D(^FBAAC(+FBIEN(3),1,+FBIEN(2),1,FBIEN(1),1,FBIEN,0)) S FBAMT=+$P(^(0),U,3) D
.I FBDAMT-FBINAMT'=FBAMT,$G(FBACT)="C" S ^TMP("FBERR",$J,4,I)=""_U_FBPROG_U_+FBIEN(3)_U_+FBIEN(2)_U_+FBIEN(1)_U_+FBIEN
N JJ F JJ=1:1:3 S DA(JJ)=+FBIEN(JJ)
S DA=+FBIEN
S DR=""
I FBACT="C" S DR="12////^S X=$G(FBCKDT);35///^S X=FBCKNUM;40///^S X=FBDAMT;41///^S X=FBINAMT;36///@;37///@"
I I $G(FBBRTG) S DR=DR_";55///^S X=FBBRTG;56///^S X=FBBACC;57///^S X=FBBNAM" ;HIPAA 5010 P121
I FBACT="B" S DR="12///@;35///@;36///@;37///@;40///@;41///@;55///@;56///@;57///@"
I FBACT="X" S DR="12///@;40///@;41///@;36////^S X=FBXDT;37////^S X=$G(FBRCOD);38///^S X=FBXCOD;55///@;56///@;57///@" D
.I FBXCOD'="R" S ^TMP("FBERR",$J,5,I)=""_U_FBPROG_U_+FBIEN(3)_U_+FBIEN(2)_U_+FBIEN(1)_U_+FBIEN
.I FBXCOD="R" S DR=DR_";35///@"
S DIE="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA)
; if EDI then add invoice to list in FBINV(, patch *61
I FBACT'="B",$P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,3)),U)]"" D
. N FBAAIN
. S FBAAIN=$P($G(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,0)),U,16)
. I FBAAIN]"" S FBINV(3,FBAAIN)=""
I FBACT="C" D:FBIBOK ADDONE^FBPAID3(3,.FBIEN,+FBIEN(3),FBDATE) ;FB*3.5*135
D KILL
Q
;
5 ;update pharmacy payment record
Q:'$D(^FBAA(162.1,+FBIEN(1),"RX",+FBIEN,0)) S FBAMT=+$P(^(0),U,16) D
. I FBDAMT-FBINAMT'=FBAMT,$G(FBACT)="C" S ^TMP("FBERR",$J,4,I)=""_U_FBPROG_U_+FBIEN(1)_U_+FBIEN
S DA(1)=+FBIEN(1),DA=+FBIEN
S DR=""
I FBACT="C" S DR="28////^S X=FBCKDT;30///^S X=FBCKNUM;34///^S X=FBDAMT;35///^S X=FBINAMT;31///@;32///@"
I FBACT="B" S DR="28///@;30///@;31///@;32///@;34///@;35///@"
I FBACT="X" S DR="28///@;34///@;35///@;31////^S X=FBXDT;32////^S X=$G(FBRCOD);33///^S X=FBXCOD" D
.I FBXCOD'="R" S ^TMP("FBERR",$J,5,I)=""_U_FBPROG_U_+FBIEN(1)_U_+FBIEN
.I FBXCOD="R" S DR=DR_";30///@"
S DIE="^FBAA(162.1,"_DA(1)_",""RX"","
D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAA(162.1,DA(1),"RX",DA)
; if EDI then add invoice to list in FBINV(, patch *61
I FBACT'="B",$P($G(^FBAA(162.1,DA(1),0)),U,13)]"" D
. N FBAAIN
. S FBAAIN=$P($G(^FBAA(162.1,DA(1),0)),U)
. I FBAAIN]"" S FBINV(5,FBAAIN)=""
D KILL
Q
;
9 ;update inpatient payment record
Q:'$D(^FBAAI(+FBIEN,0)) S FBAMT=+$P(^(0),U,9) D
.I FBDAMT-FBINAMT'=FBAMT,$G(FBACT)="C" S ^TMP("FBERR",$J,4,I)=""_U_FBPROG_U_+FBIEN
S DA=+FBIEN
S DR=""
I FBACT="C" S DR="45////^S X=FBCKDT;48///^S X=FBCKNUM;52///^S X=FBDAMT;53///^S X=FBINAMT;49///@;50///@"
I I $G(FBBRTG) S DR=DR_";61///^S X=FBBRTG;62///^S X=FBBACC;63///^S X=FBBNAM" ;HIPAA 5010 P121
I FBACT="B" S DR="45///@;48///@;49///@;50///@;52///@;53///@;61///@;62///@;63///@"
I FBACT="X" S DR="45///@;52///@;53///@;49////^S X=FBXDT;50////^S X=$G(FBRCOD);51///^S X=FBXCOD;61///@;62///@;63///@" D
.I FBXCOD'="R" S ^TMP("FBERR",$J,5,I)=""_U_FBPROG_U_+FBIEN
.I FBXCOD="R" S DR=DR_";48///@"
S DIE="^FBAAI("
D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAAI(DA)
; if EDI then add invoice to list in FBINV(, patch *61
I FBACT'="B",$P($G(^FBAAI(DA,3)),U)]"" D
. N FBAAIN
. S FBAAIN=$P($G(^FBAAI(DA,0)),U)
. I FBAAIN]"" S FBINV(9,FBAAIN)=""
I FBACT="C" D:FBIBOK ADDONE^FBPAID3(9,+FBIEN,$P(^FBAAI(+FBIEN,0),U,4),FBDATE) ;FB*3.5*135
D KILL
Q
;
T ;update travel payment record
Q:'$D(^FBAAC(+FBIEN(1),3,+FBIEN,0)) S FBAMT=+$P(^(0),U,3) D
. I FBDAMT-FBINAMT'=FBAMT,$G(FBACT)="C" S ^TMP("FBERR",$J,4,I)=""_U_FBPROG_U_+FBIEN(1)_U_+FBIEN
S DA(1)=+FBIEN(1),DA=+FBIEN
S DR=""
I FBACT="C" S DR="8////^S X=FBCKDT;9///^S X=FBCKNUM;13///^S X=FBDAMT;14///^S X=FBINAMT;10///@;11///@"
I FBACT="B" S DR="8///@;9///@;10///@;11///@;13///@;14///@"
I FBACT="X" S DR="8///@;13///@;14///@;10////^S X=FBXDT;11////^S X=$G(FBRCOD);12///^S X=FBXCOD" D
.I FBXCOD'="R" S ^TMP("FBERR",$J,5,I)=""_U_FBPROG_U_+FBIEN(1)_U_+FBIEN
.I FBXCOD="R" S DR=DR_";9///@"
S DIE="^FBAAC("_+FBIEN(1)_",3,"
D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAAC(DA(1),3,DA)
D KILL
Q
;
END ;clean and exit
N XMSER,XMZ S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C
K FB,FBPAID,FBSITE,FBAASN,FBSN,FBMCNT,I,XMER,XMREC,XMRG,XMY,^TMP("FBERR",$J),^TMP("FBPAID",$J),^TMP("FBREC",$J),X
KILL K FBLOCK,DIE,DA,DR,FBIEN,FBACT,FBCKNUM,FBRCOD,FBPROG,FBCKDT,FBXDT,FBXCOD,FBINAMT,FBDAMT,FBAMT,FBERR,FBBRTG,FBBACC,FBBNAM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPAID 6327 printed Apr 09, 2024@21:01:39 Page 2
FBPAID ;WOIFO/SAB - SERVER ROUTINE TO UPDATE PAYMENTS ;2/10/2009
+1 ;;3.5;FEE BASIS;**5,61,107,121,135**;JAN 30, 1995;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;incoming record from AAC will contain the following data
+4 ; - Fee Program - from Fee Basis Program (161.8)
+5 ; - Activity Code (C - confirmed)
+6 ; (B - backout)
+7 ; (X - cancelled)
+8 ; - Internal Control Number - IEN of payment record
+9 ; - Check Number
+10 ; - Check Date
+11 ; - Interest Amount
+12 ; - Cancellation Date
+13 ; - Reason Code (File # 162.95)
+14 ; - Cancellation Code (R - C - X)
+15 ; - Disbursed Amount (this amount minus interest amount = amt pd)
+16 ; variable 'FBPAID' is defined and passed to TRAP^FBMRASVR2
+17 ;
+18 NEW FBINV
+19 SET U="^"
SET FBPAID=1
SET FBMCNT=0
+20 SET X="TRAP^FBMRASV2"
SET @^%ZOSF("TRAP")
+21 ;K XMY S XMY("G.FEE")="" D ENT1^XMD
+22 KILL ^TMP("FBPAID",$JOB),^TMP("FBERR",$JOB)
+23 DO STATION^FBAAUTL
IF $SELECT($GET(FB("ERROR")):1,'$GET(FBAASN):1,1:0)
QUIT
+24 KILL FB
+25 ;
+26 ;FB*3.5*135 Start changes
+27 NEW FBDATE,FBIBOK
+28 SET FBDATE=DT
+29 ;RETURNS 0 if the site has sent the site parameter ALLOW FB PAID TO IB to NO or if it is blank
SET FBIBOK=$$IBALLWD^FBPAID3()
+30 ;FB*3.5*135 End changes
+31 ;
+32 ;start to read in message from central fee
+33 ;edits are:
+34 ; 1. invalid station number
+35 ; 2. invalid record length
+36 ; 3. unable to locate payment record
+37 ; 4. disbursed amount '= amt paid+interest
+38 ; 5. cancellations
+39 ; XMRG=record received in mail message from Austin
+40 FOR I=1:1
XECUTE XMREC
if XMER<0
QUIT
IF XMRG]""
IF $EXTRACT(XMRG,1,3)=FBAASN
Begin DoDot:1
+41 SET ^TMP("FBREC",$JOB,I)=XMRG
+42 KILL FBERR
+43 IF $LENGTH(XMRG)'=82&($LENGTH(XMRG)'=138)
SET FBERR=1
SET ^TMP("FBERR",$JOB,2,I)=""
+44 DO PARSE^FBPAID1
if $GET(FBERR)
QUIT
SET FBMCNT=FBMCNT+1
DO @FBPROG
End DoDot:1
+45 if $DATA(^TMP("FBERR",$JOB))
DO ^FBPAID2
+46 DO BUL^FBPAID1
+47 ; if any EDI invoices then add to FPPS queue
+48 IF $DATA(FBINV)
DO PAIDLOG^FBFHLL(.FBINV)
+49 GOTO END
+50 ;
3 ;update outpatient payment record
+1 if '$DATA(^FBAAC(+FBIEN(3),1,+FBIEN(2),1,FBIEN(1),1,FBIEN,0))
QUIT
SET FBAMT=+$PIECE(^(0),U,3)
Begin DoDot:1
+2 IF FBDAMT-FBINAMT'=FBAMT
IF $GET(FBACT)="C"
SET ^TMP("FBERR",$JOB,4,I)=""_U_FBPROG_U_+FBIEN(3)_U_+FBIEN(2)_U_+FBIEN(1)_U_+FBIEN
End DoDot:1
+3 NEW JJ
FOR JJ=1:1:3
SET DA(JJ)=+FBIEN(JJ)
+4 SET DA=+FBIEN
+5 SET DR=""
+6 IF FBACT="C"
SET DR="12////^S X=$G(FBCKDT);35///^S X=FBCKNUM;40///^S X=FBDAMT;41///^S X=FBINAMT;36///@;37///@"
+7 ;HIPAA 5010 P121
IF $TEST
IF $GET(FBBRTG)
SET DR=DR_";55///^S X=FBBRTG;56///^S X=FBBACC;57///^S X=FBBNAM"
+8 IF FBACT="B"
SET DR="12///@;35///@;36///@;37///@;40///@;41///@;55///@;56///@;57///@"
+9 IF FBACT="X"
SET DR="12///@;40///@;41///@;36////^S X=FBXDT;37////^S X=$G(FBRCOD);38///^S X=FBXCOD;55///@;56///@;57///@"
Begin DoDot:1
+10 IF FBXCOD'="R"
SET ^TMP("FBERR",$JOB,5,I)=""_U_FBPROG_U_+FBIEN(3)_U_+FBIEN(2)_U_+FBIEN(1)_U_+FBIEN
+11 IF FBXCOD="R"
SET DR=DR_";35///@"
End DoDot:1
+12 SET DIE="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
+13 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA)
+14 ; if EDI then add invoice to list in FBINV(, patch *61
+15 IF FBACT'="B"
IF $PIECE($GET(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,3)),U)]""
Begin DoDot:1
+16 NEW FBAAIN
+17 SET FBAAIN=$PIECE($GET(^FBAAC(DA(3),1,DA(2),1,DA(1),1,DA,0)),U,16)
+18 IF FBAAIN]""
SET FBINV(3,FBAAIN)=""
End DoDot:1
+19 ;FB*3.5*135
IF FBACT="C"
if FBIBOK
DO ADDONE^FBPAID3(3,.FBIEN,+FBIEN(3),FBDATE)
+20 DO KILL
+21 QUIT
+22 ;
5 ;update pharmacy payment record
+1 if '$DATA(^FBAA(162.1,+FBIEN(1),"RX",+FBIEN,0))
QUIT
SET FBAMT=+$PIECE(^(0),U,16)
Begin DoDot:1
+2 IF FBDAMT-FBINAMT'=FBAMT
IF $GET(FBACT)="C"
SET ^TMP("FBERR",$JOB,4,I)=""_U_FBPROG_U_+FBIEN(1)_U_+FBIEN
End DoDot:1
+3 SET DA(1)=+FBIEN(1)
SET DA=+FBIEN
+4 SET DR=""
+5 IF FBACT="C"
SET DR="28////^S X=FBCKDT;30///^S X=FBCKNUM;34///^S X=FBDAMT;35///^S X=FBINAMT;31///@;32///@"
+6 IF FBACT="B"
SET DR="28///@;30///@;31///@;32///@;34///@;35///@"
+7 IF FBACT="X"
SET DR="28///@;34///@;35///@;31////^S X=FBXDT;32////^S X=$G(FBRCOD);33///^S X=FBXCOD"
Begin DoDot:1
+8 IF FBXCOD'="R"
SET ^TMP("FBERR",$JOB,5,I)=""_U_FBPROG_U_+FBIEN(1)_U_+FBIEN
+9 IF FBXCOD="R"
SET DR=DR_";30///@"
End DoDot:1
+10 SET DIE="^FBAA(162.1,"_DA(1)_",""RX"","
+11 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAA(162.1,DA(1),"RX",DA)
+12 ; if EDI then add invoice to list in FBINV(, patch *61
+13 IF FBACT'="B"
IF $PIECE($GET(^FBAA(162.1,DA(1),0)),U,13)]""
Begin DoDot:1
+14 NEW FBAAIN
+15 SET FBAAIN=$PIECE($GET(^FBAA(162.1,DA(1),0)),U)
+16 IF FBAAIN]""
SET FBINV(5,FBAAIN)=""
End DoDot:1
+17 DO KILL
+18 QUIT
+19 ;
9 ;update inpatient payment record
+1 if '$DATA(^FBAAI(+FBIEN,0))
QUIT
SET FBAMT=+$PIECE(^(0),U,9)
Begin DoDot:1
+2 IF FBDAMT-FBINAMT'=FBAMT
IF $GET(FBACT)="C"
SET ^TMP("FBERR",$JOB,4,I)=""_U_FBPROG_U_+FBIEN
End DoDot:1
+3 SET DA=+FBIEN
+4 SET DR=""
+5 IF FBACT="C"
SET DR="45////^S X=FBCKDT;48///^S X=FBCKNUM;52///^S X=FBDAMT;53///^S X=FBINAMT;49///@;50///@"
+6 ;HIPAA 5010 P121
IF $TEST
IF $GET(FBBRTG)
SET DR=DR_";61///^S X=FBBRTG;62///^S X=FBBACC;63///^S X=FBBNAM"
+7 IF FBACT="B"
SET DR="45///@;48///@;49///@;50///@;52///@;53///@;61///@;62///@;63///@"
+8 IF FBACT="X"
SET DR="45///@;52///@;53///@;49////^S X=FBXDT;50////^S X=$G(FBRCOD);51///^S X=FBXCOD;61///@;62///@;63///@"
Begin DoDot:1
+9 IF FBXCOD'="R"
SET ^TMP("FBERR",$JOB,5,I)=""_U_FBPROG_U_+FBIEN
+10 IF FBXCOD="R"
SET DR=DR_";48///@"
End DoDot:1
+11 SET DIE="^FBAAI("
+12 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAAI(DA)
+13 ; if EDI then add invoice to list in FBINV(, patch *61
+14 IF FBACT'="B"
IF $PIECE($GET(^FBAAI(DA,3)),U)]""
Begin DoDot:1
+15 NEW FBAAIN
+16 SET FBAAIN=$PIECE($GET(^FBAAI(DA,0)),U)
+17 IF FBAAIN]""
SET FBINV(9,FBAAIN)=""
End DoDot:1
+18 ;FB*3.5*135
IF FBACT="C"
if FBIBOK
DO ADDONE^FBPAID3(9,+FBIEN,$PIECE(^FBAAI(+FBIEN,0),U,4),FBDATE)
+19 DO KILL
+20 QUIT
+21 ;
T ;update travel payment record
+1 if '$DATA(^FBAAC(+FBIEN(1),3,+FBIEN,0))
QUIT
SET FBAMT=+$PIECE(^(0),U,3)
Begin DoDot:1
+2 IF FBDAMT-FBINAMT'=FBAMT
IF $GET(FBACT)="C"
SET ^TMP("FBERR",$JOB,4,I)=""_U_FBPROG_U_+FBIEN(1)_U_+FBIEN
End DoDot:1
+3 SET DA(1)=+FBIEN(1)
SET DA=+FBIEN
+4 SET DR=""
+5 IF FBACT="C"
SET DR="8////^S X=FBCKDT;9///^S X=FBCKNUM;13///^S X=FBDAMT;14///^S X=FBINAMT;10///@;11///@"
+6 IF FBACT="B"
SET DR="8///@;9///@;10///@;11///@;13///@;14///@"
+7 IF FBACT="X"
SET DR="8///@;13///@;14///@;10////^S X=FBXDT;11////^S X=$G(FBRCOD);12///^S X=FBXCOD"
Begin DoDot:1
+8 IF FBXCOD'="R"
SET ^TMP("FBERR",$JOB,5,I)=""_U_FBPROG_U_+FBIEN(1)_U_+FBIEN
+9 IF FBXCOD="R"
SET DR=DR_";9///@"
End DoDot:1
+10 SET DIE="^FBAAC("_+FBIEN(1)_",3,"
+11 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAAC(DA(1),3,DA)
+12 DO KILL
+13 QUIT
+14 ;
END ;clean and exit
+1 NEW XMSER,XMZ
SET XMSER="S."_XQSOP
SET XMZ=XQMSG
DO REMSBMSG^XMA1C
+2 KILL FB,FBPAID,FBSITE,FBAASN,FBSN,FBMCNT,I,XMER,XMREC,XMRG,XMY,^TMP("FBERR",$JOB),^TMP("FBPAID",$JOB),^TMP("FBREC",$JOB),X
KILL KILL FBLOCK,DIE,DA,DR,FBIEN,FBACT,FBCKNUM,FBRCOD,FBPROG,FBCKDT,FBXDT,FBXCOD,FBINAMT,FBDAMT,FBAMT,FBERR,FBBRTG,FBBACC,FBBNAM
+1 QUIT
