- 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 Feb 18, 2025@23:23:21 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 ;