FBAAV1 ;AISC/GRR-ELECTRONICALLY TRANSMIT FEE (VENDOR MRA'S) PART 2 ;07/18/06
;;3.5;FEE BASIS;**10,36,39,98,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
S (ZMCNT,ZPCNT,FB("M"),FB("P"))=0
;D STATION^FBAAUTL,HD^FBAAUTL Q:$D(FB("ERROR"))
S FBTXT=0
F J="O","P" I $D(^FBAA(161.25,"AE",J)) F K=0:0 S K=$O(^FBAA(161.25,"AE",J,K)) Q:K'>0 S FBTC=$G(^FBAA(161.25,K,0)),FBTC=$S(FBTC']"":"N",J="P":$P(FBTC,U,2),J="O":$P(FBTC,U,3),1:"N") S Y(0)=$G(^FBAAV(K,0)) I Y(0)]"" D
.S Y(1)=$G(^FBAAV(K,"ADEL")),Y(2)=$G(^FBAAV(K,"AMS")),Y(3)=$G(^FBAAV(K,1)) D GETGRP^FBAAUTL6(K,5)
.I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01
.D GOT
D:+$G(FBOKTX) XMIT^FBAAV01 Q
GOT S FBNAME=$P(Y(0),"^",1),FBNAME=$S(FBNAME[",":$E($P(FBNAME,",",2),1)_" "_$E($P(FBNAME,",",2),$F($P(FBNAME,",",2)," "))_$S($F($P(FBNAME,",",2)," "):" ",1:" ")_$P(FBNAME,",",1),1:FBNAME)
S FBNAME=$S($L(FBNAME)<30:FBNAME_$E(PAD,$L(FBNAME)+1,30),1:$E(FBNAME,1,30)),FBID=$P(Y(0),"^",2),FBID=FBID_$E(PAD,$L(FBID)+1,11),FBPART=$P(Y(0),"^",7),FBSN=FBSN_$E(" ",$L(FBSN)+1,6)
S FBSC=$S($P(Y(0),"^",8)]"":$P(Y(0),"^",8),1:" "),FBSC=$S(FBSC=" ":FBSC,$D(^FBAA(161.6,FBSC,0)):$P(^(0),"^",2),1:" "),FBTC=$S(FBTC]"":FBTC,1:"N"),OCDT=$S(Y(1)]"":$P(Y(1),"^",2),1:"")
S FBPC=$S($P(Y(0),"^",9)]"":$P(Y(0),"^",9),1:" "),FBPC=$S(FBPC=" ":FBPC,$D(^FBAA(161.81,FBPC,0)):$P(^(0),"^",2),1:" ")
S FBTC=$S(FBTC="N":"A",1:FBTC),FBAD=$P(Y(0),"^",3),FBAD=FBAD_$E(PAD,$L(FBAD)+1,30),FBAD1=$P(Y(0),"^",14),FBAD1=FBAD1_$E(PAD,$L(FBAD1)+1,30),FBCITY=$E($P(Y(0),"^",4),1,19),FBCITY=FBCITY_$E(PAD,$L(FBCITY)+1,19)
S FBSTCD=$P(Y(0),"^",5),FBSTATE=$S(FBSTCD']"":" ",$D(^DIC(5,FBSTCD,0)):$P(^(0),"^",2),1:" "),FBSTATE=$S($L(FBSTATE)'=2:" ",1:FBSTATE),FBZIP=$P(Y(0),"^",6),FBZIP=$TR(FBZIP,"-","")_$E("000000000",$L(FBZIP)+1,9)
S FBMRC=$P(Y(0),"^",18),FBMRC=$S(FBMRC]"":FBMRC,1:" "),FBCHAIN=$P(Y(0),"^",10),FBCHAIN=$E("0000",$L(FBCHAIN)+1,4)_FBCHAIN
S STCC=$P(Y(0),"^",13),FBCC="000" I STCC]"",FBSTCD]"" S FBCC=$S($D(^DIC(5,FBSTCD,1,STCC,0)):$P(^(0),"^",3),1:"000")
S FBCC=$E("000",$L(FBCC)+1,3)_FBCC,FBRT=$S(J="P":4,1:1),FBICN=$E(FBSN,1,3)_K,FBICN=$E("000000000000000",$L(FBICN)+1,15)_FBICN,FBTID=$P(Y(2),"^",6),FBTID=$S(FBTID]"":FBTID,1:"T"),FBFMST=$P(Y(2),"^",4),FBFMST=$S(FBFMST]"":FBFMST,1:"C")
S FBNPI=$$EN^FBNPILK(K)
; pad FPDS data
S FBBT=$S($P(Y(3),U,10)]"":$P(Y(3),U,10),1:" ")_" "
F I=1:1:5 S FBSG(I)=$G(FBSG(I))_$E(" ",1,2-$L($G(FBSG(I))))
;
D SETP:J="P",SETM:J="O",UPDT
;S ^FBAA(161.25,"AD","T",K)="",$P(^FBAA(161.25,K,0),"^",3)="T" K ^FBAA(161.25,"AD",J,K)
D STORE Q
SETM S ZMCNT=ZMCNT+1 D:FB("M")=0!(ZMCNT>100) BHEDM S FBSTR=FBRT_FBTC_FBSN_FBID_" "
I FBTC="D"!(FBTC="R") S FBSTR=FBSTR_"$" Q
S FBSTR=FBSTR_"1"_FBSC_FBPC_FBNAME_FBAD_FBAD1_FBCITY_FBSTATE_FBZIP_FBMRC_FBCC_"B"_FBTID_"Y"_FBFMST_FBICN_FBBT_FBSG(1)_FBSG(2)_FBSG(3)_FBSG(4)_FBSG(5)_FBNPI_"$"
Q
SETP S ZPCNT=ZPCNT+1 D:FB("P")=0!(ZPCNT>100) BHEDP S FBSTR=FBRT_FBTC_FBSN_$E(FBID,1,9)_FBCHAIN
I FBTC="D"!(FBTC="R") S FBSTR=FBSTR_"$" Q
S FBSTR=FBSTR_"1"_FBNAME_FBAD_FBAD1_FBCITY_FBSTATE_FBZIP_FBMRC_FBCC_"B"_FBTID_"Y"_FBFMST_FBICN_FBBT_FBSG(1)_FBSG(2)_FBSG(3)_FBSG(4)_FBSG(5)_FBNPI_"$"
Q
BHEDM S BTYPE="M" D GETB S FB("M")=1,FBSTR=FBHD_"C1"_$E(DT,4,7)_$E(DT,2,3)_FBSN_FBZBNM_"$" D STORE S ZMCNT=1 Q
BHEDP S BTYPE="P" D GETB S FB("P")=1,FBSTR=FBHD_"C4"_$E(DT,4,7)_$E(DT,2,3)_FBSN_FBZBNP_"$" D STORE S ZPCNT=1 Q
UPDT L +^FBAA(161.25,K):5 K ^FBAA(161.25,"AE",J,K)
;I $D(^FBAA(161.25,"AE",$S(J="P":"O",1:"P"),K)) S $P(^FBAA(161.25,K,0),"^",3)="N" L -^FBAA(161.25,K) Q ;commented out since don't know why it is set
;K:OCDT]"" ^FBAAV("AC",OCDT,K) S $P(^FBAAV(K,0),"^",15)=DT,^FBAAV("AC",DT,K)="" L -^FBAA(161.25,K)
S DA=K,(DIC,DIE)="^FBAA(161.25,",DR="4///^S X=DT" D ^DIE L -^FBAA(161.25,K)
S DIE="^FBAAV(",DA=K,DR="12///^S X=DT" D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FBAAV(DA)
K DA,DIE,DR,FBLOCK Q
GETB D GETNXB^FBAAUTL
I BTYPE="M" S FBZBNM=$E("0000000",$L(FBBN)+1,7)_FBBN Q
I BTYPE="P" S FBZBNP=$E("0000000",$L(FBBN)+1,7)_FBBN
Q
STORE I TOTSTR+$L(FBSTR)>13900!(ZMCNT>100)!(ZPCNT>100) S TOTSTR=0 D XMIT^FBAAV01,NEWMSG^FBAAV01 S FBTMP=FBSTR D BHEDM:J="O",BHEDP:J="P" S FBSTR=FBTMP K FBTMP
S TOTSTR=TOTSTR+$L(FBSTR) D STORE^FBAAV01
Q
KILL K FBATCH,FBCHB,J,K,L,M,N,FBAABN,FBAAON,FBAASN,FBAACP,FBAACD,FBAABT,FBAAAP,FBSTR,PAD,PAD1,FBPAYT,FBVID,FBPOV,FBTT,FBPATT,FBTD,FBSUSP,FBAP,FBEXMPT,FBFNI,FBFNY,^TMP($J)
K A,FBTYPE,DO,DI,DIC,DIE,DOD,DQ,ER,FBADD,FBAUTH,FBBD,FBBN,FBCHAIN,FBFDC,FBFLNAM,FBFR,FBLNAM,FBMST,FBRECT,FBRT,FBSEX,FBSTAT,FBSTCD,FBTC,FBTO,BTYPE,POS,POV,POW,STCC,STCD,T,TOTSTR,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,XMZ,ZMCNT,ZPCNT
K FBINVN,FBDIN,FBSSN,FBNAME,FBLNAME,FBFI,FBMI,XMDUZ,DA,DR,X,Y,FBPART,FBC,FBSN,FBID,FEEO,FBSC,FBPC,FBAD,FBCITY,FBSTATE,FBZIP,FBCC,FBZBN,FBZBNM,FBZBNP,FB,D,Z,Q,VAT,VATERR,VATNAME,FBSDI
K FBCTY,FBDX,FBFTD,FBPRC,FBPSA,FBST,OCDT,X1,X2,FB7078,FBBILL,FBCLAIM,FBCTY,FBDISP,FBDOB,FBFDT,FBJ,FBLOS,FBMED,FBPART1,FBSTABR,FBTDT,FBTTD,FBVEN,PAD,VAPA,FBSITE,FBK,FBNPI
K FB0,FBFEE,FBHD,FBI,FBLN,FBNVP,FBOKTX,FBTXT,FBVAR,FBXMFEE,FBXMNVP,FBXMZ,XMDUN,FBRESUB,FBAD1,FBFMST,FBICN,FBMRC,FBTID,FBPOP,FBCPT,FBHCFA,FBPD,FBPOS,FBVTOS,FBAC,FBCSN,FBRX,FBVFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAV1 5192 printed Sep 23, 2025@19:33 Page 2
FBAAV1 ;AISC/GRR-ELECTRONICALLY TRANSMIT FEE (VENDOR MRA'S) PART 2 ;07/18/06
+1 ;;3.5;FEE BASIS;**10,36,39,98,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 SET (ZMCNT,ZPCNT,FB("M"),FB("P"))=0
+4 ;D STATION^FBAAUTL,HD^FBAAUTL Q:$D(FB("ERROR"))
+5 SET FBTXT=0
+6 FOR J="O","P"
IF $DATA(^FBAA(161.25,"AE",J))
FOR K=0:0
SET K=$ORDER(^FBAA(161.25,"AE",J,K))
if K'>0
QUIT
SET FBTC=$GET(^FBAA(161.25,K,0))
SET FBTC=$SELECT(FBTC']"":"N",J="P":$PIECE(FBTC,U,2),J="O":$PIECE(FBTC,U,3),1:"N")
SET Y(0)=$GET(^FBAAV(K,0))
IF Y(0)]""
Begin DoDot:1
+7 SET Y(1)=$GET(^FBAAV(K,"ADEL"))
SET Y(2)=$GET(^FBAAV(K,"AMS"))
SET Y(3)=$GET(^FBAAV(K,1))
DO GETGRP^FBAAUTL6(K,5)
+8 IF 'FBTXT
SET FBTXT=1
DO NEWMSG^FBAAV01
+9 DO GOT
End DoDot:1
+10 if +$GET(FBOKTX)
DO XMIT^FBAAV01
QUIT
GOT SET FBNAME=$PIECE(Y(0),"^",1)
SET FBNAME=$SELECT(FBNAME[",":$EXTRACT($PIECE(FBNAME,",",2),1)_" "_$EXTRACT($PIECE(FBNAME,",",2),$FIND($PIECE(FBNAME,",",2)," "))_$SELECT($FIND($PIECE(FBNAME,",",2)," "):" ",1:" ")_$PIECE(FBNAME,",",1),1:FBNAME)
+1 SET FBNAME=$SELECT($LENGTH(FBNAME)<30:FBNAME_$EXTRACT(PAD,$LENGTH(FBNAME)+1,30),1:$EXTRACT(FBNAME,1,30))
SET FBID=$PIECE(Y(0),"^",2)
SET FBID=FBID_$EXTRACT(PAD,$LENGTH(FBID)+1,11)
SET FBPART=$PIECE(Y(0),"^",7)
SET FBSN=FBSN_$EXTRACT(" ",$LENGTH(FBSN)+1,6)
+2 SET FBSC=$SELECT($PIECE(Y(0),"^",8)]"":$PIECE(Y(0),"^",8),1:" ")
SET FBSC=$SELECT(FBSC=" ":FBSC,$DATA(^FBAA(161.6,FBSC,0)):$PIECE(^(0),"^",2),1:" ")
SET FBTC=$SELECT(FBTC]"":FBTC,1:"N")
SET OCDT=$SELECT(Y(1)]"":$PIECE(Y(1),"^",2),1:"")
+3 SET FBPC=$SELECT($PIECE(Y(0),"^",9)]"":$PIECE(Y(0),"^",9),1:" ")
SET FBPC=$SELECT(FBPC=" ":FBPC,$DATA(^FBAA(161.81,FBPC,0)):$PIECE(^(0),"^",2),1:" ")
+4 SET FBTC=$SELECT(FBTC="N":"A",1:FBTC)
SET FBAD=$PIECE(Y(0),"^",3)
SET FBAD=FBAD_$EXTRACT(PAD,$LENGTH(FBAD)+1,30)
SET FBAD1=$PIECE(Y(0),"^",14)
SET FBAD1=FBAD1_$EXTRACT(PAD,$LENGTH(FBAD1)+1,30)
SET FBCITY=$EXTRACT($PIECE(Y(0),"^",4),1,19)
SET FBCITY=FBCITY_$EXTRACT(PAD,$LENGTH(FBCITY)+1,19)
+5 SET FBSTCD=$PIECE(Y(0),"^",5)
SET FBSTATE=$SELECT(FBSTCD']"":" ",$DATA(^DIC(5,FBSTCD,0)):$PIECE(^(0),"^",2),1:" ")
SET FBSTATE=$SELECT($LENGTH(FBSTATE)'=2:" ",1:FBSTATE)
SET FBZIP=$PIECE(Y(0),"^",6)
SET FBZIP=$TRANSLATE(FBZIP,"-","")_$EXTRACT("000000000",$LENGTH(FBZIP)+1,9)
+6 SET FBMRC=$PIECE(Y(0),"^",18)
SET FBMRC=$SELECT(FBMRC]"":FBMRC,1:" ")
SET FBCHAIN=$PIECE(Y(0),"^",10)
SET FBCHAIN=$EXTRACT("0000",$LENGTH(FBCHAIN)+1,4)_FBCHAIN
+7 SET STCC=$PIECE(Y(0),"^",13)
SET FBCC="000"
IF STCC]""
IF FBSTCD]""
SET FBCC=$SELECT($DATA(^DIC(5,FBSTCD,1,STCC,0)):$PIECE(^(0),"^",3),1:"000")
+8 SET FBCC=$EXTRACT("000",$LENGTH(FBCC)+1,3)_FBCC
SET FBRT=$SELECT(J="P":4,1:1)
SET FBICN=$EXTRACT(FBSN,1,3)_K
SET FBICN=$EXTRACT("000000000000000",$LENGTH(FBICN)+1,15)_FBICN
SET FBTID=$PIECE(Y(2),"^",6)
SET FBTID=$SELECT(FBTID]"":FBTID,1:"T")
SET FBFMST=$PIECE(Y(2),"^",4)
SET FBFMST=$SELECT(FBFMST]"":FBFMST,1:"C")
+9 SET FBNPI=$$EN^FBNPILK(K)
+10 ; pad FPDS data
+11 SET FBBT=$SELECT($PIECE(Y(3),U,10)]"":$PIECE(Y(3),U,10),1:" ")_" "
+12 FOR I=1:1:5
SET FBSG(I)=$GET(FBSG(I))_$EXTRACT(" ",1,2-$LENGTH($GET(FBSG(I))))
+13 ;
+14 if J="P"
DO SETP
if J="O"
DO SETM
DO UPDT
+15 ;S ^FBAA(161.25,"AD","T",K)="",$P(^FBAA(161.25,K,0),"^",3)="T" K ^FBAA(161.25,"AD",J,K)
+16 DO STORE
QUIT
SETM SET ZMCNT=ZMCNT+1
if FB("M")=0!(ZMCNT>100)
DO BHEDM
SET FBSTR=FBRT_FBTC_FBSN_FBID_" "
+1 IF FBTC="D"!(FBTC="R")
SET FBSTR=FBSTR_"$"
QUIT
+2 SET FBSTR=FBSTR_"1"_FBSC_FBPC_FBNAME_FBAD_FBAD1_FBCITY_FBSTATE_FBZIP_FBMRC_FBCC_"B"_FBTID_"Y"_FBFMST_FBICN_FBBT_FBSG(1)_FBSG(2)_FBSG(3)_FBSG(4)_FBSG(5)_FBNPI_"$"
+3 QUIT
SETP SET ZPCNT=ZPCNT+1
if FB("P")=0!(ZPCNT>100)
DO BHEDP
SET FBSTR=FBRT_FBTC_FBSN_$EXTRACT(FBID,1,9)_FBCHAIN
+1 IF FBTC="D"!(FBTC="R")
SET FBSTR=FBSTR_"$"
QUIT
+2 SET FBSTR=FBSTR_"1"_FBNAME_FBAD_FBAD1_FBCITY_FBSTATE_FBZIP_FBMRC_FBCC_"B"_FBTID_"Y"_FBFMST_FBICN_FBBT_FBSG(1)_FBSG(2)_FBSG(3)_FBSG(4)_FBSG(5)_FBNPI_"$"
+3 QUIT
BHEDM SET BTYPE="M"
DO GETB
SET FB("M")=1
SET FBSTR=FBHD_"C1"_$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)_FBSN_FBZBNM_"$"
DO STORE
SET ZMCNT=1
QUIT
BHEDP SET BTYPE="P"
DO GETB
SET FB("P")=1
SET FBSTR=FBHD_"C4"_$EXTRACT(DT,4,7)_$EXTRACT(DT,2,3)_FBSN_FBZBNP_"$"
DO STORE
SET ZPCNT=1
QUIT
UPDT LOCK +^FBAA(161.25,K):5
KILL ^FBAA(161.25,"AE",J,K)
+1 ;I $D(^FBAA(161.25,"AE",$S(J="P":"O",1:"P"),K)) S $P(^FBAA(161.25,K,0),"^",3)="N" L -^FBAA(161.25,K) Q ;commented out since don't know why it is set
+2 ;K:OCDT]"" ^FBAAV("AC",OCDT,K) S $P(^FBAAV(K,0),"^",15)=DT,^FBAAV("AC",DT,K)="" L -^FBAA(161.25,K)
+3 SET DA=K
SET (DIC,DIE)="^FBAA(161.25,"
SET DR="4///^S X=DT"
DO ^DIE
LOCK -^FBAA(161.25,K)
+4 SET DIE="^FBAAV("
SET DA=K
SET DR="12///^S X=DT"
DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FBAAV(DA)
+5 KILL DA,DIE,DR,FBLOCK
QUIT
GETB DO GETNXB^FBAAUTL
+1 IF BTYPE="M"
SET FBZBNM=$EXTRACT("0000000",$LENGTH(FBBN)+1,7)_FBBN
QUIT
+2 IF BTYPE="P"
SET FBZBNP=$EXTRACT("0000000",$LENGTH(FBBN)+1,7)_FBBN
+3 QUIT
STORE IF TOTSTR+$LENGTH(FBSTR)>13900!(ZMCNT>100)!(ZPCNT>100)
SET TOTSTR=0
DO XMIT^FBAAV01
DO NEWMSG^FBAAV01
SET FBTMP=FBSTR
if J="O"
DO BHEDM
if J="P"
DO BHEDP
SET FBSTR=FBTMP
KILL FBTMP
+1 SET TOTSTR=TOTSTR+$LENGTH(FBSTR)
DO STORE^FBAAV01
+2 QUIT
KILL KILL FBATCH,FBCHB,J,K,L,M,N,FBAABN,FBAAON,FBAASN,FBAACP,FBAACD,FBAABT,FBAAAP,FBSTR,PAD,PAD1,FBPAYT,FBVID,FBPOV,FBTT,FBPATT,FBTD,FBSUSP,FBAP,FBEXMPT,FBFNI,FBFNY,^TMP($JOB)
+1 KILL A,FBTYPE,DO,DI,DIC,DIE,DOD,DQ,ER,FBADD,FBAUTH,FBBD,FBBN,FBCHAIN,FBFDC,FBFLNAM,FBFR,FBLNAM,FBMST,FBRECT,FBRT,FBSEX,FBSTAT,FBSTCD,FBTC,FBTO,BTYPE,POS,POV,POW,STCC,STCD,T,TOTSTR,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,XMZ,ZMCNT,ZPCNT
+2 KILL FBINVN,FBDIN,FBSSN,FBNAME,FBLNAME,FBFI,FBMI,XMDUZ,DA,DR,X,Y,FBPART,FBC,FBSN,FBID,FEEO,FBSC,FBPC,FBAD,FBCITY,FBSTATE,FBZIP,FBCC,FBZBN,FBZBNM,FBZBNP,FB,D,Z,Q,VAT,VATERR,VATNAME,FBSDI
+3 KILL FBCTY,FBDX,FBFTD,FBPRC,FBPSA,FBST,OCDT,X1,X2,FB7078,FBBILL,FBCLAIM,FBCTY,FBDISP,FBDOB,FBFDT,FBJ,FBLOS,FBMED,FBPART1,FBSTABR,FBTDT,FBTTD,FBVEN,PAD,VAPA,FBSITE,FBK,FBNPI
+4 KILL FB0,FBFEE,FBHD,FBI,FBLN,FBNVP,FBOKTX,FBTXT,FBVAR,FBXMFEE,FBXMNVP,FBXMZ,XMDUN,FBRESUB,FBAD1,FBFMST,FBICN,FBMRC,FBTID,FBPOP,FBCPT,FBHCFA,FBPD,FBPOS,FBVTOS,FBAC,FBCSN,FBRX,FBVFN
+5 QUIT
