FBAAV01 ;AISC/GRR - ELECTRONICALLY TRANSMIT FEE DATA CONTINUED ;6/15/2009
;;3.5;FEE BASIS;**89,98,108,123,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
NEWMSG ;get new message number, reset line counter
;FBLN=line counter, FBFEE=FEE message counter, FBNVP=NVP message counter
;FBOKTX=1 if message pending, 0 otherwise
S FBXMZ=0,FBJ=$G(J),FBK=$G(K) S:'$D(FBFEE) FBFEE=1 S:'$D(FBNVP) FBNVP=1
S XMSUB=$S('$D(FBFLAG):"FEE BASIS MESSAGE # "_FBFEE,1:"FEE NON-VA HOSP TO PRICER MESSAGE # "_FBNVP),XMDUZ=DUZ
S FBOKTX=0
D XMZ^XMA2
I '$D(XMZ)!(XMZ'>0) G NEWMSG
S FBXMZ=XMZ,FBLN=0,FBOKTX=1,J=FBJ,K=FBK K XMZ
Q
;
XMIT ;send message, increment message counter
;FBLN=line counter, FBFEE=FEE message counter, FBNVP=NVP message counter
;FBXMFEE(=FEE recipient array, FBXMNVP(=NVP recipient array
S FBJ=J,FBK=K K XMY D ROUT
S XMZ=FBXMZ,^XMB(3.9,XMZ,2,0)="^3.92A^"_FBLN_"^"_FBLN_"^"_DT
S XMDUN=$P(^VA(200,DUZ,0),U) D ENT1^XMD
S FBLN=0,FBOKTX=0
D INCRM ;increment message counter
S J=FBJ,K=FBK
Q
;
ROUT ;set up recipients for message
I $D(FBFLAG) S FBI=0 F S FBI=$O(FBXMNVP(FBI)) Q:'FBI S X=FBXMNVP(FBI),XMN=0,XMDF="" D INST^XMA21 K XMN,XMDF
I '$D(FBFLAG) S FBI=0 F S FBI=$O(FBXMFEE(FBI)) Q:'FBI S X=FBXMFEE(FBI),XMN=0,XMDF="" D INST^XMA21 K XMN,XMDF
S XMY(DUZ)="",XMDUZ=DUZ Q
;
INCRM ;increment message counter
I $D(FBFLAG) S FBNVP=FBNVP+1
E S FBFEE=FBFEE+1
Q
;
INCRL ;increment line counter
S FBLN=FBLN+1 Q
;
STORE ;set message string
D INCRL S ^XMB(3.9,FBXMZ,2,FBLN,0)=FBSTR
Q
;
ADDRESS ;set up recipient array, FBXMFEE( for FEE router, FBXMNVP( for NVP router
F VATNAME="FEE","NVP" D ^VATRAN G:VATERR ADDQ S FBI=0 F S FBI=$O(VAT(FBI)) Q:'FBI S FBVAR="FBXM"_VATNAME_"("_FBI_")" S @FBVAR=VAT(FBI)
ADDQ Q
;Following checks for Austin Name Field in Vendor file in order to continue transmitting that batch.
CKB3V F FB1=0:0 S FB1=$O(^FBAAC("AC",J,FB1)) Q:'FB1!($G(FBERR)) F FB2=0:0 S FB2=$O(^FBAAC("AC",J,FB1,FB2)) Q:FB2'>0!($G(FBERR)) D CHKV
Q
CKB5V F FB1=0:0 S FB1=$O(^FBAA(162.1,"AE",J,FB1)) Q:'FB1!($G(FBERR)) I $G(^FBAA(162.1,FB1,0)) S FB2=+$P(^(0),"^",4) D CHKV
Q
CKB9V F FB1=0:0 S FB1=$O(^FBAAI("AC",J,FB1)) Q:'FB1!($G(FBERR)) I $G(^FBAAI(FB1,0)) S FB2=+$P(^(0),"^",3) D CHKV
Q
CHKV I $$CKVEN^FBAADV(FB2) W !!,*7,"VENDOR: ",$$VNAME^FBNHEXP(FB2)," Not approved in Austin yet.",!,"Batch # ",FBAABN," CANNOT BE TRANSMITTED!!!" S FBERR=1
Q
;
STRING ; called from FBAAV0 to build 'B3' payment record; also called by DSIFPAY5 (FBCS) with DBIA# 5093
;
S FBPICN=$$PADZ(FBPICN,30)
;
; build 1st line
S FBSTR=3_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_" "_FBAP_FBAAON_FBSUSP
S FBSTR=FBSTR_FBPOV_FBPATT_FBTD_FBTT_FBDIN_FBINVN
S FBSTR=FBSTR_$E(PAD,1,33)_FBST_FBCTY_FBZIP ; reserved for foreign addr
S FBSTR=FBSTR_$E(FBPSA,1,3)_FBCPT_FBPOS_FBHCFA_FBVTOS_FBPD
S FBSTR=FBSTR_+$P($G(FBY),U,2)_$E(PAD,1,8)_FBPICN ;Internal Control Number
S FBSTR=FBSTR_$S(+FBY:$$AUSDT^FBAAV3(+FBY),1:FBDIN)_FBADMIT_FBDOB_"~"
D STORE
;
; build 2nd line
S FBSTR=FBUNITS_FBAUTHF_FBMOD1_FBMOD2_FBMOD3_FBMOD4
S FBADJR1=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,2),1:""),FBADJR1=$$RJ^XLFSTR(FBADJR1,5," ")
S FBADJR2=$S($D(FBCRARC(2)):$P(FBCRARC(2),U,2),1:""),FBADJR2=$$RJ^XLFSTR(FBADJR2,5," ")
S FBSTR=FBSTR_FBADJR1_FBADJR2
S FBADJA1=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,3),1:0),FBADJA1=$$AUSAMT^FBAAV3(FBADJA1,9,1)
S FBADJA2=$S($D(FBCRARC(2)):$P(FBCRARC(2),U,3),1:0),FBADJA2=$$AUSAMT^FBAAV3(FBADJA2,9,1)
S FBSTR=FBSTR_FBADJA1_FBADJA2
S FBSTR=FBSTR_FBNPI_FBCSID_FBEDIF_FBCNTRN
;
; FB*3.5*123 - esg - Check to make sure IPAC variables are defined
I '$D(FBIA)!'$D(FBDODINV) D IPAC(K,L,M,N,.FBIA,.FBDODINV) ; set and format the IPAC variables if coming from FBCS
;
S FBSTR=FBSTR_FBIA_FBDODINV_"~" ; FB*3.5*123 - IPAC data formatted in FBAAV0 or below in IPAC
D STORE
;
; 3rd line
S FBSTR=FBFPPSID ; FPPS Claim Number
S FBSTR=FBSTR_FBAUTHNUM ;AUTHORIZATION NUMBER
S FBLNITM=$$RJ^XLFSTR(FBLNITM,3,0) ;fpps line item
S FBSTR=FBSTR_FBLNITM
S FBSTR=FBSTR_FBAMTC ;Service Line Billed Amount = Claimed Amount
;
S FBADJG=$S($D(FBCRARC(1)):$P(FBCRARC(1),U),1:""),FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
S FBRRC1=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,4),1:""),FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
S FBRRC2=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,5),1:""),FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
S FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
;
S FBADJG=$S($D(FBCRARC(2)):$P(FBCRARC(2),U),1:""),FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
S FBRRC1=$S($D(FBCRARC(2)):$P(FBCRARC(2),U,4),1:""),FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
S FBRRC2=$S($D(FBCRARC(2)):$P(FBCRARC(2),U,5),1:""),FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
S FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
;
F FBI=3:1:5 D
. S FBADJG=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U),1:""),FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
. S FBADJR=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U,2),1:""),FBADJR=$$RJ^XLFSTR(FBADJR,5," ")
. S FBRRC1=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U,4),1:""),FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
. S FBRRC2=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U,5),1:""),FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
. S FBADJA=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U,3),1:0),FBADJA=$$AUSAMT^FBAAV3(FBADJA,9,1)
. S FBSTR=FBSTR_FBADJG_FBADJR_FBRRC1_FBRRC2_FBADJA
;
S FBSTR=FBSTR_$$RJ^XLFSTR(FBPYMTH,1," ")
S FBSTR=FBSTR_" " ;Additional Payment Indicator
S FBSTR=FBSTR_" " ;Additional Payment Type
S FBSTR=FBSTR_$$PADZ(0,30) ;Parent Internal Control Number
;
S FBSTR=FBSTR_"~$"
D STORE
;
K FBPICN,FBY
K FBIA,FBDODINV ; FB*3.5*123 kill IPAC variables after using them. They will get rebuilt by the next claim.
Q
;
PADZ(X,Y) ;call to pad 'X' with leading zeros' to a field length of 'Y'
;
I $S('$L(X):1,'Y:1,Y<$L(X):1,1:0) Q ""
N Z S Z=0,$P(Z,0,Y)=0
Q $E(Z,$L(X)+1,Y)_X
;
IPAC(K,L,M,N,FBIA,FBDODINV) ; set IPAC variables if being called from FBCS
; K - 162.03 subscript#1 - DFN
; L - 162.03 subscript#2 - vendor ien
; M - 162.03 subscript#3 - treatment date subfile ien
; N - 162.03 subscript#4 - service provided subfile ien
; Output:
; FBIA - formatted IPAC agreement ID# (pass by reference) - will be 10 characters in length
; FBDODINV - formatted DoD invoice# (pass by reference) - will be 22 characters in length
;
N FBY2,FBY3,FBIPIEN
S (FBIA,FBDODINV)=""
I '$$IPACREQD^FBAAMP(L) G IPACX ; IPAC data is not required so get out
;
S FBY2=$G(^FBAAC(K,1,L,1,M,1,N,2)) ; 2 node of file 162.03
S FBY3=$G(^FBAAC(K,1,L,1,M,1,N,3)) ; 3 node of file 162.03
S FBIA=+$P(FBY3,U,6) ; .05 field IPAC agreement ien
S FBIA=$S(FBIA:$P($G(^FBAA(161.95,FBIA,0)),U,1),1:"") ; IPAC agreement ID# or ""
S FBDODINV=$P(FBY3,U,7) ; IPAC DoD invoice#
;
; if IPAC agreement is not on file, but there is only one active IPAC on file for the vendor, then save it/use it
I FBIA="" S FBIA=$$IPACID^FBAAMP(L,.FBIPIEN) I FBIA'="",FBIPIEN D
. N FBIENS,FBIAFDA
. S FBIENS=N_","_M_","_L_","_K_","
. S FBIAFDA(162.03,FBIENS,.05)=FBIPIEN ; ipac agreement ien
. D FILE^DIE("","FBIAFDA") ; update the database
. Q
;
; if IPAC agreement is still not found, then report an error condition to Central Fee
I FBIA="" S FBIA="9999999999" ; error value to be sent to Central Fee so they reject it back to VistA
;
; if DoD invoice# is not on file, then attempt to use field# 49 PATIENT ACCOUNT NUMBER. use it/save it if it exists
I FBDODINV="" S FBDODINV=$P(FBY2,U,16) I FBDODINV'="" D
. N FBIENS,FBIAFDA
. S FBIENS=N_","_M_","_L_","_K_","
. S FBIAFDA(162.03,FBIENS,.055)=FBDODINV ; DoD invoice#
. D FILE^DIE("","FBIAFDA") ; update the database
. Q
;
; if DoD invoice# is still not found, then report an error condition to Central Fee
I FBDODINV="" S FBDODINV="9999999999999999999999" ; error value to be sent to Central Fee
;
IPACX ;
S FBIA=$$LJ^XLFSTR(FBIA,"10T") ; IPAC agreement id#
S FBDODINV=$$LJ^XLFSTR(FBDODINV,"22T") ; DoD invoice#
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAV01 8079 printed Sep 23, 2025@19:32:59 Page 2
FBAAV01 ;AISC/GRR - ELECTRONICALLY TRANSMIT FEE DATA CONTINUED ;6/15/2009
+1 ;;3.5;FEE BASIS;**89,98,108,123,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
NEWMSG ;get new message number, reset line counter
+1 ;FBLN=line counter, FBFEE=FEE message counter, FBNVP=NVP message counter
+2 ;FBOKTX=1 if message pending, 0 otherwise
+3 SET FBXMZ=0
SET FBJ=$GET(J)
SET FBK=$GET(K)
if '$DATA(FBFEE)
SET FBFEE=1
if '$DATA(FBNVP)
SET FBNVP=1
+4 SET XMSUB=$SELECT('$DATA(FBFLAG):"FEE BASIS MESSAGE # "_FBFEE,1:"FEE NON-VA HOSP TO PRICER MESSAGE # "_FBNVP)
SET XMDUZ=DUZ
+5 SET FBOKTX=0
+6 DO XMZ^XMA2
+7 IF '$DATA(XMZ)!(XMZ'>0)
GOTO NEWMSG
+8 SET FBXMZ=XMZ
SET FBLN=0
SET FBOKTX=1
SET J=FBJ
SET K=FBK
KILL XMZ
+9 QUIT
+10 ;
XMIT ;send message, increment message counter
+1 ;FBLN=line counter, FBFEE=FEE message counter, FBNVP=NVP message counter
+2 ;FBXMFEE(=FEE recipient array, FBXMNVP(=NVP recipient array
+3 SET FBJ=J
SET FBK=K
KILL XMY
DO ROUT
+4 SET XMZ=FBXMZ
SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_FBLN_"^"_FBLN_"^"_DT
+5 SET XMDUN=$PIECE(^VA(200,DUZ,0),U)
DO ENT1^XMD
+6 SET FBLN=0
SET FBOKTX=0
+7 ;increment message counter
DO INCRM
+8 SET J=FBJ
SET K=FBK
+9 QUIT
+10 ;
ROUT ;set up recipients for message
+1 IF $DATA(FBFLAG)
SET FBI=0
FOR
SET FBI=$ORDER(FBXMNVP(FBI))
if 'FBI
QUIT
SET X=FBXMNVP(FBI)
SET XMN=0
SET XMDF=""
DO INST^XMA21
KILL XMN,XMDF
+2 IF '$DATA(FBFLAG)
SET FBI=0
FOR
SET FBI=$ORDER(FBXMFEE(FBI))
if 'FBI
QUIT
SET X=FBXMFEE(FBI)
SET XMN=0
SET XMDF=""
DO INST^XMA21
KILL XMN,XMDF
+3 SET XMY(DUZ)=""
SET XMDUZ=DUZ
QUIT
+4 ;
INCRM ;increment message counter
+1 IF $DATA(FBFLAG)
SET FBNVP=FBNVP+1
+2 IF '$TEST
SET FBFEE=FBFEE+1
+3 QUIT
+4 ;
INCRL ;increment line counter
+1 SET FBLN=FBLN+1
QUIT
+2 ;
STORE ;set message string
+1 DO INCRL
SET ^XMB(3.9,FBXMZ,2,FBLN,0)=FBSTR
+2 QUIT
+3 ;
ADDRESS ;set up recipient array, FBXMFEE( for FEE router, FBXMNVP( for NVP router
+1 FOR VATNAME="FEE","NVP"
DO ^VATRAN
if VATERR
GOTO ADDQ
SET FBI=0
FOR
SET FBI=$ORDER(VAT(FBI))
if 'FBI
QUIT
SET FBVAR="FBXM"_VATNAME_"("_FBI_")"
SET @FBVAR=VAT(FBI)
ADDQ QUIT
+1 ;Following checks for Austin Name Field in Vendor file in order to continue transmitting that batch.
CKB3V FOR FB1=0:0
SET FB1=$ORDER(^FBAAC("AC",J,FB1))
if 'FB1!($GET(FBERR))
QUIT
FOR FB2=0:0
SET FB2=$ORDER(^FBAAC("AC",J,FB1,FB2))
if FB2'>0!($GET(FBERR))
QUIT
DO CHKV
+1 QUIT
CKB5V FOR FB1=0:0
SET FB1=$ORDER(^FBAA(162.1,"AE",J,FB1))
if 'FB1!($GET(FBERR))
QUIT
IF $GET(^FBAA(162.1,FB1,0))
SET FB2=+$PIECE(^(0),"^",4)
DO CHKV
+1 QUIT
CKB9V FOR FB1=0:0
SET FB1=$ORDER(^FBAAI("AC",J,FB1))
if 'FB1!($GET(FBERR))
QUIT
IF $GET(^FBAAI(FB1,0))
SET FB2=+$PIECE(^(0),"^",3)
DO CHKV
+1 QUIT
CHKV IF $$CKVEN^FBAADV(FB2)
WRITE !!,*7,"VENDOR: ",$$VNAME^FBNHEXP(FB2)," Not approved in Austin yet.",!,"Batch # ",FBAABN," CANNOT BE TRANSMITTED!!!"
SET FBERR=1
+1 QUIT
+2 ;
STRING ; called from FBAAV0 to build 'B3' payment record; also called by DSIFPAY5 (FBCS) with DBIA# 5093
+1 ;
+2 SET FBPICN=$$PADZ(FBPICN,30)
+3 ;
+4 ; build 1st line
+5 SET FBSTR=3_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_" "_FBAP_FBAAON_FBSUSP
+6 SET FBSTR=FBSTR_FBPOV_FBPATT_FBTD_FBTT_FBDIN_FBINVN
+7 ; reserved for foreign addr
SET FBSTR=FBSTR_$EXTRACT(PAD,1,33)_FBST_FBCTY_FBZIP
+8 SET FBSTR=FBSTR_$EXTRACT(FBPSA,1,3)_FBCPT_FBPOS_FBHCFA_FBVTOS_FBPD
+9 ;Internal Control Number
SET FBSTR=FBSTR_+$PIECE($GET(FBY),U,2)_$EXTRACT(PAD,1,8)_FBPICN
+10 SET FBSTR=FBSTR_$SELECT(+FBY:$$AUSDT^FBAAV3(+FBY),1:FBDIN)_FBADMIT_FBDOB_"~"
+11 DO STORE
+12 ;
+13 ; build 2nd line
+14 SET FBSTR=FBUNITS_FBAUTHF_FBMOD1_FBMOD2_FBMOD3_FBMOD4
+15 SET FBADJR1=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,2),1:"")
SET FBADJR1=$$RJ^XLFSTR(FBADJR1,5," ")
+16 SET FBADJR2=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U,2),1:"")
SET FBADJR2=$$RJ^XLFSTR(FBADJR2,5," ")
+17 SET FBSTR=FBSTR_FBADJR1_FBADJR2
+18 SET FBADJA1=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,3),1:0)
SET FBADJA1=$$AUSAMT^FBAAV3(FBADJA1,9,1)
+19 SET FBADJA2=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U,3),1:0)
SET FBADJA2=$$AUSAMT^FBAAV3(FBADJA2,9,1)
+20 SET FBSTR=FBSTR_FBADJA1_FBADJA2
+21 SET FBSTR=FBSTR_FBNPI_FBCSID_FBEDIF_FBCNTRN
+22 ;
+23 ; FB*3.5*123 - esg - Check to make sure IPAC variables are defined
+24 ; set and format the IPAC variables if coming from FBCS
IF '$DATA(FBIA)!'$DATA(FBDODINV)
DO IPAC(K,L,M,N,.FBIA,.FBDODINV)
+25 ;
+26 ; FB*3.5*123 - IPAC data formatted in FBAAV0 or below in IPAC
SET FBSTR=FBSTR_FBIA_FBDODINV_"~"
+27 DO STORE
+28 ;
+29 ; 3rd line
+30 ; FPPS Claim Number
SET FBSTR=FBFPPSID
+31 ;AUTHORIZATION NUMBER
SET FBSTR=FBSTR_FBAUTHNUM
+32 ;fpps line item
SET FBLNITM=$$RJ^XLFSTR(FBLNITM,3,0)
+33 SET FBSTR=FBSTR_FBLNITM
+34 ;Service Line Billed Amount = Claimed Amount
SET FBSTR=FBSTR_FBAMTC
+35 ;
+36 SET FBADJG=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U),1:"")
SET FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
+37 SET FBRRC1=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,4),1:"")
SET FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
+38 SET FBRRC2=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,5),1:"")
SET FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
+39 SET FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
+40 ;
+41 SET FBADJG=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U),1:"")
SET FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
+42 SET FBRRC1=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U,4),1:"")
SET FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
+43 SET FBRRC2=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U,5),1:"")
SET FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
+44 SET FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
+45 ;
+46 FOR FBI=3:1:5
Begin DoDot:1
+47 SET FBADJG=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U),1:"")
SET FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
+48 SET FBADJR=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,2),1:"")
SET FBADJR=$$RJ^XLFSTR(FBADJR,5," ")
+49 SET FBRRC1=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,4),1:"")
SET FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
+50 SET FBRRC2=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,5),1:"")
SET FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
+51 SET FBADJA=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,3),1:0)
SET FBADJA=$$AUSAMT^FBAAV3(FBADJA,9,1)
+52 SET FBSTR=FBSTR_FBADJG_FBADJR_FBRRC1_FBRRC2_FBADJA
End DoDot:1
+53 ;
+54 SET FBSTR=FBSTR_$$RJ^XLFSTR(FBPYMTH,1," ")
+55 ;Additional Payment Indicator
SET FBSTR=FBSTR_" "
+56 ;Additional Payment Type
SET FBSTR=FBSTR_" "
+57 ;Parent Internal Control Number
SET FBSTR=FBSTR_$$PADZ(0,30)
+58 ;
+59 SET FBSTR=FBSTR_"~$"
+60 DO STORE
+61 ;
+62 KILL FBPICN,FBY
+63 ; FB*3.5*123 kill IPAC variables after using them. They will get rebuilt by the next claim.
KILL FBIA,FBDODINV
+64 QUIT
+65 ;
PADZ(X,Y) ;call to pad 'X' with leading zeros' to a field length of 'Y'
+1 ;
+2 IF $SELECT('$LENGTH(X):1,'Y:1,Y<$LENGTH(X):1,1:0)
QUIT ""
+3 NEW Z
SET Z=0
SET $PIECE(Z,0,Y)=0
+4 QUIT $EXTRACT(Z,$LENGTH(X)+1,Y)_X
+5 ;
IPAC(K,L,M,N,FBIA,FBDODINV) ; set IPAC variables if being called from FBCS
+1 ; K - 162.03 subscript#1 - DFN
+2 ; L - 162.03 subscript#2 - vendor ien
+3 ; M - 162.03 subscript#3 - treatment date subfile ien
+4 ; N - 162.03 subscript#4 - service provided subfile ien
+5 ; Output:
+6 ; FBIA - formatted IPAC agreement ID# (pass by reference) - will be 10 characters in length
+7 ; FBDODINV - formatted DoD invoice# (pass by reference) - will be 22 characters in length
+8 ;
+9 NEW FBY2,FBY3,FBIPIEN
+10 SET (FBIA,FBDODINV)=""
+11 ; IPAC data is not required so get out
IF '$$IPACREQD^FBAAMP(L)
GOTO IPACX
+12 ;
+13 ; 2 node of file 162.03
SET FBY2=$GET(^FBAAC(K,1,L,1,M,1,N,2))
+14 ; 3 node of file 162.03
SET FBY3=$GET(^FBAAC(K,1,L,1,M,1,N,3))
+15 ; .05 field IPAC agreement ien
SET FBIA=+$PIECE(FBY3,U,6)
+16 ; IPAC agreement ID# or ""
SET FBIA=$SELECT(FBIA:$PIECE($GET(^FBAA(161.95,FBIA,0)),U,1),1:"")
+17 ; IPAC DoD invoice#
SET FBDODINV=$PIECE(FBY3,U,7)
+18 ;
+19 ; if IPAC agreement is not on file, but there is only one active IPAC on file for the vendor, then save it/use it
+20 IF FBIA=""
SET FBIA=$$IPACID^FBAAMP(L,.FBIPIEN)
IF FBIA'=""
IF FBIPIEN
Begin DoDot:1
+21 NEW FBIENS,FBIAFDA
+22 SET FBIENS=N_","_M_","_L_","_K_","
+23 ; ipac agreement ien
SET FBIAFDA(162.03,FBIENS,.05)=FBIPIEN
+24 ; update the database
DO FILE^DIE("","FBIAFDA")
+25 QUIT
End DoDot:1
+26 ;
+27 ; if IPAC agreement is still not found, then report an error condition to Central Fee
+28 ; error value to be sent to Central Fee so they reject it back to VistA
IF FBIA=""
SET FBIA="9999999999"
+29 ;
+30 ; if DoD invoice# is not on file, then attempt to use field# 49 PATIENT ACCOUNT NUMBER. use it/save it if it exists
+31 IF FBDODINV=""
SET FBDODINV=$PIECE(FBY2,U,16)
IF FBDODINV'=""
Begin DoDot:1
+32 NEW FBIENS,FBIAFDA
+33 SET FBIENS=N_","_M_","_L_","_K_","
+34 ; DoD invoice#
SET FBIAFDA(162.03,FBIENS,.055)=FBDODINV
+35 ; update the database
DO FILE^DIE("","FBIAFDA")
+36 QUIT
End DoDot:1
+37 ;
+38 ; if DoD invoice# is still not found, then report an error condition to Central Fee
+39 ; error value to be sent to Central Fee
IF FBDODINV=""
SET FBDODINV="9999999999999999999999"
+40 ;
IPACX ;
+1 ; IPAC agreement id#
SET FBIA=$$LJ^XLFSTR(FBIA,"10T")
+2 ; DoD invoice#
SET FBDODINV=$$LJ^XLFSTR(FBDODINV,"22T")
+3 QUIT
+4 ;
