FBAAV2 ;AISC/GRR-ELECTRONICALLY TRANSMIT PHARMACY PAYMENTS ;11 Apr 2006 2:52 PM
;;3.5;FEE BASIS;**3,89,98,116,108,123,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
DETP ; ENTRY FROM FBAAV0
S FBTXT=0
D CKB5V^FBAAV01 I $G(FBERR) K FBERR Q
; HIPAA 5010 - line items that have 0.00 amount paid are now required togo to Central Fee
F K=0:0 S K=$O(^FBAA(162.1,"AE",J,K)) Q:K'>0 F L=0:0 S L=$O(^FBAA(162.1,"AE",J,K,L)) Q:L'>0 S Y(0)=$G(^FBAA(162.1,K,"RX",L,0)),Y(2)=$G(^(2)),Y=$G(^FBAA(162.1,K,0)) I Y(0)]"",Y]"" D
.S Y(6)=$G(^FBAA(162.1,K,"RX",L,6)) ; FB*3.5*123
.S Y(3)=$G(^FBAA(162.1,K,"RX",L,3)) ; FB*3.5*158
.N FBPICN,FBY
.S FBPICN=K_U_L
.S FBY=$S($P(Y,U,12):$P(Y,U,12),1:$P(Y,U,2))_U_+$P(Y(2),U,9)
.I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01,STORE^FBAAV01,UPD^FBAAV0
.D GOTP
D:FBTXT XMIT^FBAAV01
Q
;
GOTP ; process a B5 line item
N DFN,FBADJ,FBADJA1,FBADJA2,FBADJR1,FBADJR2,FBIENS,FBPNAMX,FBVY0,FBX
N FBNPI,FBEDIF,FBIA,FBDODINV,FBCRARC,FBFPPSID,FBAUTHNUM,FBAMTCLM,FBQNTY
;
S FBLNITM=+$P(Y(3),U) ;FPPS line item
S FBIENS=$P(FBPICN,U,2)_","_$P(FBPICN,U,1)_","
S FBPAYT=$P(Y(0),"^",20),FBPAYT=$S(FBPAYT]"":FBPAYT,1:"V")
S FBINVN=$P(Y,"^"),FBINVN=$E("000000000",$L(FBINVN)+1,9)_FBINVN
S FBEDIF=$S($P(Y,"^",13)]"":"Y",1:" ") ; EDI flag
S FBFPPSID=$E($P(Y,U,13),1,12),FBFPPSID=$$RJ^XLFSTR(FBFPPSID,12,0) ;FPPS Claim Number
S FBAUTHNUM=$P(Y(3),U,2) ;AUTHORIZATION NUMBER
I FBAUTHNUM']"" S FBAUTHNUM=$$AUTHRX(FBIENS)
S FBAUTHNUM=$$LJ^XLFSTR(FBAUTHNUM,"29T"," ")
S FBAMTCLM=$P(Y(0),U,4) ;Amount Claimed = Service Line Billed Amount
S FBDIN=$$AUSDT^FBAAV3($P(Y,"^",2))
;
S FBVFN=$P(Y,"^",4)
S FBNPI=$$EN^FBNPILK(FBVFN)
S FBVY0=$G(^FBAAV(FBVFN,0)) ; vendor 0 node
;
S FBIA=+$P(Y,U,23) ; IPAC agreement ptr
S FBIA=$S(FBIA:$P($G(^FBAA(161.95,FBIA,0)),U,1),1:"") ; IPAC external agreement ID# or ""
S FBIA=$$LJ^XLFSTR(FBIA,"10T") ; format to 10 characters
S FBDODINV=$P(Y(6),U,1) ; DoD invoice#
S FBDODINV=$$LJ^XLFSTR(FBDODINV,"22T") ; format to 22 characters
;
S FBVID=$P(FBVY0,U,2),FBVID=$E(FBVID,1,9)_$E(PAD,$L(FBVID)+1,9)
S FBCSN=$S($P(FBVY0,U,2)]"":$P(FBVY0,U,10),1:"")
S FBCSN=$E("0000",$L(FBCSN)+1,4)_FBCSN
I FBPAYT="R" S FBVID=$E(PAD,1,9),FBCSN=$E(PAD,1,4)
K FBVY0
;
S FBRX=$P(Y(0),"^",1),FBRX=$E("00000000",$L(FBRX)+1,8)_FBRX
I '$L($G(FBAASN)) D STATION^FBAAUTL
S FBPSA=$$PSA^FBAAV5(+$P(Y(2),U,5),+FBAASN) I $L(+FBPSA)'=3 S FBPSA=999
S FBTD=$$AUSDT^FBAAV3($P(Y(0),"^",3))
S FBSUSP=$P(Y(0),"^",8),FBSUSP=$S(FBSUSP="":" ",$D(^FBAA(161.27,+FBSUSP,0)):$P(^(0),"^"),1:" ")
S FBAC=$$AUSAMT^FBAAV3($P(Y(0),"^",4),8)
S FBAP=$$AUSAMT^FBAAV3($P(Y(0),"^",16),8)
I FBAC=FBAP S FBAP=" "
;
S FBQNTY=+$P(Y(0),U,13) ;Quantity/Units 162.11,1.6
S FBQNTY=$S((FBQNTY>0)&(FBQNTY<10000000):FBQNTY,1:0)
S FBQNTY=$$AUSNUM^FBAAV3(FBQNTY,5,12)
;
S DFN=$P(Y(0),"^",5)
Q:'DFN
Q:'$D(^DPT(DFN,0))
; Note: Prior to the following line Y(0) = the 0 node of subfile 161.11
;After the line Y(0) will be the 0 node of file #2
S VAPA("P")="",Y(0)=^DPT(DFN,0) D PAT^FBAAUTL2,ADD^VADPT
S FBPNAMX=$$HL7NAME^FBAAV2(DFN)
S FBST=$S($P(VAPA(5),"^")="":" ",$D(^DIC(5,$P(VAPA(5),"^"),0)):$P(^(0),"^",2),1:" ")
I $L(FBST)>2 S FBST="**"
S:$L(FBST)'=2 FBST=$E(PAD,$L(FBST)+1,2)_FBST
S FBCTY=$S($P(VAPA(7),"^")="":" ",FBST=" ":" ",$D(^DIC(5,$P(VAPA(5),"^"),1,$P(VAPA(7),"^"),0)):$P(^(0),"^",3),1:" ")
I $L(FBCTY)'=3 S FBCTY=$E("000",$L(FBCTY)+1,3)_FBCTY
S FBZIP=$S('+$G(VAPA(11)):VAPA(6),+VAPA(11):$P(VAPA(11),U),1:VAPA(6)),FBZIP=$TR(FBZIP,"-","")_$E("000000000",$L(FBZIP)+1,9)
;
; get and format CARCs and RARCs
D CRARC(FBIENS,.FBCRARC) ; FB*3.5*158
;
; build 1st line
S FBSTR=5_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_FBCSN_FBAC_FBAP_FBAAON
S FBSTR=FBSTR_FBSUSP_FBTD_FBRX_FBDIN_FBINVN
S FBSTR=FBSTR_$E(PAD,1,33)_FBST_FBCTY_FBZIP ; reserved for foreign addr
S FBSTR=FBSTR_$E(FBPSA,1,3)_$P(FBY,U,2)_$E(PAD,1,8)
S FBSTR=FBSTR_$$PADZ^FBAAV01(FBPICN,30)_$$AUSDT^FBAAV3(+FBY)_"~"
D STORE^FBAAV01
;
; build 2nd line
; FB*3.5*158
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=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_FBEDIF
S FBSTR=FBSTR_FBIA_FBDODINV ; IPAC data from FB*3.5*123
; FB*3.5*158
S FBSTR=FBSTR_FBFPPSID
S FBSTR=FBSTR_FBAUTHNUM ;Authorization Number
S FBSTR=FBSTR_$$RJ^XLFSTR(FBLNITM,3,0) ;FPPS line item
S FBSTR=FBSTR_$$AUSAMT^FBAAV3(FBAMTCLM,12) ;Service Line Billed 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_FBQNTY
;
S FBSTR=FBSTR_"~$"
D STORE^FBAAV01
Q
;
AUTHRX(IENS) ; returns REFERENCE NUMBER from ^FB7078
;
N REFNUM
S REFNUM=""
D GETS^DIQ(162.11,IENS,"26","I","FB")
I $D(FB),FB(162.11,IENS,26,"I")["FB7078" D
. S FB7078=$P(FB(162.11,IENS,26,"I"),";")
. S:$D(^FB7078(FB7078,0)) REFNUM=$P(^FB7078(FB7078,0),U)
Q REFNUM
;
HL7NAME(FBDFN) ; return patient name formatted in a 35 character length string
N FBAR,FBNM
S FBAR("FILE")=2,FBAR("IENS")=FBDFN,FBAR("FIELD")=.01
S FBNM=$$HLNAME^XLFNAME(.FBAR,"L35","|")
Q $$LRJ^FBAAV4(FBNM,35)
;
CRARC(FBIENS,FBCRARC) ; load CARCs and RARCs
;
N FBADJ,FBRRMK
D LOADADJ^FBRXFA(FBIENS,.FBADJ)
D LOADRR^FBRXFR(FBIENS,.FBRRMK)
D CRARC^FBAAUTL(.FBADJ,.FBRRMK,.FBCRARC)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAV2 6887 printed Dec 13, 2024@01:56:57 Page 2
FBAAV2 ;AISC/GRR-ELECTRONICALLY TRANSMIT PHARMACY PAYMENTS ;11 Apr 2006 2:52 PM
+1 ;;3.5;FEE BASIS;**3,89,98,116,108,123,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
DETP ; ENTRY FROM FBAAV0
+1 SET FBTXT=0
+2 DO CKB5V^FBAAV01
IF $GET(FBERR)
KILL FBERR
QUIT
+3 ; HIPAA 5010 - line items that have 0.00 amount paid are now required togo to Central Fee
+4 FOR K=0:0
SET K=$ORDER(^FBAA(162.1,"AE",J,K))
if K'>0
QUIT
FOR L=0:0
SET L=$ORDER(^FBAA(162.1,"AE",J,K,L))
if L'>0
QUIT
SET Y(0)=$GET(^FBAA(162.1,K,"RX",L,0))
SET Y(2)=$GET(^(2))
SET Y=$GET(^FBAA(162.1,K,0))
IF Y(0)]""
IF Y]""
Begin DoDot:1
+5 ; FB*3.5*123
SET Y(6)=$GET(^FBAA(162.1,K,"RX",L,6))
+6 ; FB*3.5*158
SET Y(3)=$GET(^FBAA(162.1,K,"RX",L,3))
+7 NEW FBPICN,FBY
+8 SET FBPICN=K_U_L
+9 SET FBY=$SELECT($PIECE(Y,U,12):$PIECE(Y,U,12),1:$PIECE(Y,U,2))_U_+$PIECE(Y(2),U,9)
+10 IF 'FBTXT
SET FBTXT=1
DO NEWMSG^FBAAV01
DO STORE^FBAAV01
DO UPD^FBAAV0
+11 DO GOTP
End DoDot:1
+12 if FBTXT
DO XMIT^FBAAV01
+13 QUIT
+14 ;
GOTP ; process a B5 line item
+1 NEW DFN,FBADJ,FBADJA1,FBADJA2,FBADJR1,FBADJR2,FBIENS,FBPNAMX,FBVY0,FBX
+2 NEW FBNPI,FBEDIF,FBIA,FBDODINV,FBCRARC,FBFPPSID,FBAUTHNUM,FBAMTCLM,FBQNTY
+3 ;
+4 ;FPPS line item
SET FBLNITM=+$PIECE(Y(3),U)
+5 SET FBIENS=$PIECE(FBPICN,U,2)_","_$PIECE(FBPICN,U,1)_","
+6 SET FBPAYT=$PIECE(Y(0),"^",20)
SET FBPAYT=$SELECT(FBPAYT]"":FBPAYT,1:"V")
+7 SET FBINVN=$PIECE(Y,"^")
SET FBINVN=$EXTRACT("000000000",$LENGTH(FBINVN)+1,9)_FBINVN
+8 ; EDI flag
SET FBEDIF=$SELECT($PIECE(Y,"^",13)]"":"Y",1:" ")
+9 ;FPPS Claim Number
SET FBFPPSID=$EXTRACT($PIECE(Y,U,13),1,12)
SET FBFPPSID=$$RJ^XLFSTR(FBFPPSID,12,0)
+10 ;AUTHORIZATION NUMBER
SET FBAUTHNUM=$PIECE(Y(3),U,2)
+11 IF FBAUTHNUM']""
SET FBAUTHNUM=$$AUTHRX(FBIENS)
+12 SET FBAUTHNUM=$$LJ^XLFSTR(FBAUTHNUM,"29T"," ")
+13 ;Amount Claimed = Service Line Billed Amount
SET FBAMTCLM=$PIECE(Y(0),U,4)
+14 SET FBDIN=$$AUSDT^FBAAV3($PIECE(Y,"^",2))
+15 ;
+16 SET FBVFN=$PIECE(Y,"^",4)
+17 SET FBNPI=$$EN^FBNPILK(FBVFN)
+18 ; vendor 0 node
SET FBVY0=$GET(^FBAAV(FBVFN,0))
+19 ;
+20 ; IPAC agreement ptr
SET FBIA=+$PIECE(Y,U,23)
+21 ; IPAC external agreement ID# or ""
SET FBIA=$SELECT(FBIA:$PIECE($GET(^FBAA(161.95,FBIA,0)),U,1),1:"")
+22 ; format to 10 characters
SET FBIA=$$LJ^XLFSTR(FBIA,"10T")
+23 ; DoD invoice#
SET FBDODINV=$PIECE(Y(6),U,1)
+24 ; format to 22 characters
SET FBDODINV=$$LJ^XLFSTR(FBDODINV,"22T")
+25 ;
+26 SET FBVID=$PIECE(FBVY0,U,2)
SET FBVID=$EXTRACT(FBVID,1,9)_$EXTRACT(PAD,$LENGTH(FBVID)+1,9)
+27 SET FBCSN=$SELECT($PIECE(FBVY0,U,2)]"":$PIECE(FBVY0,U,10),1:"")
+28 SET FBCSN=$EXTRACT("0000",$LENGTH(FBCSN)+1,4)_FBCSN
+29 IF FBPAYT="R"
SET FBVID=$EXTRACT(PAD,1,9)
SET FBCSN=$EXTRACT(PAD,1,4)
+30 KILL FBVY0
+31 ;
+32 SET FBRX=$PIECE(Y(0),"^",1)
SET FBRX=$EXTRACT("00000000",$LENGTH(FBRX)+1,8)_FBRX
+33 IF '$LENGTH($GET(FBAASN))
DO STATION^FBAAUTL
+34 SET FBPSA=$$PSA^FBAAV5(+$PIECE(Y(2),U,5),+FBAASN)
IF $LENGTH(+FBPSA)'=3
SET FBPSA=999
+35 SET FBTD=$$AUSDT^FBAAV3($PIECE(Y(0),"^",3))
+36 SET FBSUSP=$PIECE(Y(0),"^",8)
SET FBSUSP=$SELECT(FBSUSP="":" ",$DATA(^FBAA(161.27,+FBSUSP,0)):$PIECE(^(0),"^"),1:" ")
+37 SET FBAC=$$AUSAMT^FBAAV3($PIECE(Y(0),"^",4),8)
+38 SET FBAP=$$AUSAMT^FBAAV3($PIECE(Y(0),"^",16),8)
+39 IF FBAC=FBAP
SET FBAP=" "
+40 ;
+41 ;Quantity/Units 162.11,1.6
SET FBQNTY=+$PIECE(Y(0),U,13)
+42 SET FBQNTY=$SELECT((FBQNTY>0)&(FBQNTY<10000000):FBQNTY,1:0)
+43 SET FBQNTY=$$AUSNUM^FBAAV3(FBQNTY,5,12)
+44 ;
+45 SET DFN=$PIECE(Y(0),"^",5)
+46 if 'DFN
QUIT
+47 if '$DATA(^DPT(DFN,0))
QUIT
+48 ; Note: Prior to the following line Y(0) = the 0 node of subfile 161.11
+49 ;After the line Y(0) will be the 0 node of file #2
+50 SET VAPA("P")=""
SET Y(0)=^DPT(DFN,0)
DO PAT^FBAAUTL2
DO ADD^VADPT
+51 SET FBPNAMX=$$HL7NAME^FBAAV2(DFN)
+52 SET FBST=$SELECT($PIECE(VAPA(5),"^")="":" ",$DATA(^DIC(5,$PIECE(VAPA(5),"^"),0)):$PIECE(^(0),"^",2),1:" ")
+53 IF $LENGTH(FBST)>2
SET FBST="**"
+54 if $LENGTH(FBST)'=2
SET FBST=$EXTRACT(PAD,$LENGTH(FBST)+1,2)_FBST
+55 SET FBCTY=$SELECT($PIECE(VAPA(7),"^")="":" ",FBST=" ":" ",$DATA(^DIC(5,$PIECE(VAPA(5),"^"),1,$PIECE(VAPA(7),"^"),0)):$PIECE(^(0),"^",3),1:" ")
+56 IF $LENGTH(FBCTY)'=3
SET FBCTY=$EXTRACT("000",$LENGTH(FBCTY)+1,3)_FBCTY
+57 SET FBZIP=$SELECT('+$GET(VAPA(11)):VAPA(6),+VAPA(11):$PIECE(VAPA(11),U),1:VAPA(6))
SET FBZIP=$TRANSLATE(FBZIP,"-","")_$EXTRACT("000000000",$LENGTH(FBZIP)+1,9)
+58 ;
+59 ; get and format CARCs and RARCs
+60 ; FB*3.5*158
DO CRARC(FBIENS,.FBCRARC)
+61 ;
+62 ; build 1st line
+63 SET FBSTR=5_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_FBCSN_FBAC_FBAP_FBAAON
+64 SET FBSTR=FBSTR_FBSUSP_FBTD_FBRX_FBDIN_FBINVN
+65 ; reserved for foreign addr
SET FBSTR=FBSTR_$EXTRACT(PAD,1,33)_FBST_FBCTY_FBZIP
+66 SET FBSTR=FBSTR_$EXTRACT(FBPSA,1,3)_$PIECE(FBY,U,2)_$EXTRACT(PAD,1,8)
+67 SET FBSTR=FBSTR_$$PADZ^FBAAV01(FBPICN,30)_$$AUSDT^FBAAV3(+FBY)_"~"
+68 DO STORE^FBAAV01
+69 ;
+70 ; build 2nd line
+71 ; FB*3.5*158
+72 SET FBADJR1=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,2),1:"")
SET FBADJR1=$$RJ^XLFSTR(FBADJR1,5," ")
+73 SET FBADJR2=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U,2),1:"")
SET FBADJR2=$$RJ^XLFSTR(FBADJR2,5," ")
+74 SET FBSTR=FBADJR1_FBADJR2
+75 SET FBADJA1=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,3),1:0)
SET FBADJA1=$$AUSAMT^FBAAV3(FBADJA1,9,1)
+76 SET FBADJA2=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U,3),1:0)
SET FBADJA2=$$AUSAMT^FBAAV3(FBADJA2,9,1)
+77 SET FBSTR=FBSTR_FBADJA1_FBADJA2
+78 ;
+79 SET FBSTR=FBSTR_FBNPI_FBEDIF
+80 ; IPAC data from FB*3.5*123
SET FBSTR=FBSTR_FBIA_FBDODINV
+81 ; FB*3.5*158
+82 SET FBSTR=FBSTR_FBFPPSID
+83 ;Authorization Number
SET FBSTR=FBSTR_FBAUTHNUM
+84 ;FPPS line item
SET FBSTR=FBSTR_$$RJ^XLFSTR(FBLNITM,3,0)
+85 ;Service Line Billed Amount
SET FBSTR=FBSTR_$$AUSAMT^FBAAV3(FBAMTCLM,12)
+86 ;
+87 SET FBADJG=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U),1:"")
SET FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
+88 SET FBRRC1=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,4),1:"")
SET FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
+89 SET FBRRC2=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,5),1:"")
SET FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
+90 SET FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
+91 ;
+92 SET FBADJG=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U),1:"")
SET FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
+93 SET FBRRC1=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U,4),1:"")
SET FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
+94 SET FBRRC2=$SELECT($DATA(FBCRARC(2)):$PIECE(FBCRARC(2),U,5),1:"")
SET FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
+95 SET FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
+96 ;
+97 FOR FBI=3:1:5
Begin DoDot:1
+98 SET FBADJG=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U),1:"")
SET FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
+99 SET FBADJR=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,2),1:"")
SET FBADJR=$$RJ^XLFSTR(FBADJR,5," ")
+100 SET FBRRC1=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,4),1:"")
SET FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
+101 SET FBRRC2=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,5),1:"")
SET FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
+102 SET FBADJA=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,3),1:0)
SET FBADJA=$$AUSAMT^FBAAV3(FBADJA,9,1)
+103 SET FBSTR=FBSTR_FBADJG_FBADJR_FBRRC1_FBRRC2_FBADJA
End DoDot:1
+104 ;
+105 SET FBSTR=FBSTR_FBQNTY
+106 ;
+107 SET FBSTR=FBSTR_"~$"
+108 DO STORE^FBAAV01
+109 QUIT
+110 ;
AUTHRX(IENS) ; returns REFERENCE NUMBER from ^FB7078
+1 ;
+2 NEW REFNUM
+3 SET REFNUM=""
+4 DO GETS^DIQ(162.11,IENS,"26","I","FB")
+5 IF $DATA(FB)
IF FB(162.11,IENS,26,"I")["FB7078"
Begin DoDot:1
+6 SET FB7078=$PIECE(FB(162.11,IENS,26,"I"),";")
+7 if $DATA(^FB7078(FB7078,0))
SET REFNUM=$PIECE(^FB7078(FB7078,0),U)
End DoDot:1
+8 QUIT REFNUM
+9 ;
HL7NAME(FBDFN) ; return patient name formatted in a 35 character length string
+1 NEW FBAR,FBNM
+2 SET FBAR("FILE")=2
SET FBAR("IENS")=FBDFN
SET FBAR("FIELD")=.01
+3 SET FBNM=$$HLNAME^XLFNAME(.FBAR,"L35","|")
+4 QUIT $$LRJ^FBAAV4(FBNM,35)
+5 ;
CRARC(FBIENS,FBCRARC) ; load CARCs and RARCs
+1 ;
+2 NEW FBADJ,FBRRMK
+3 DO LOADADJ^FBRXFA(FBIENS,.FBADJ)
+4 DO LOADRR^FBRXFR(FBIENS,.FBRRMK)
+5 DO CRARC^FBAAUTL(.FBADJ,.FBRRMK,.FBCRARC)
+6 QUIT
+7 ;
