Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBAAV2

FBAAV2.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1. DETP ; ENTRY FROM FBAAV0
  1.  S FBTXT=0
  1.  D CKB5V^FBAAV01 I $G(FBERR) K FBERR Q
  1.  ; HIPAA 5010 - line items that have 0.00 amount paid are now required togo to Central Fee
  1.  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
  1.  .S Y(6)=$G(^FBAA(162.1,K,"RX",L,6))       ; FB*3.5*123
  1.  .S Y(3)=$G(^FBAA(162.1,K,"RX",L,3))       ; FB*3.5*158
  1.  .N FBPICN,FBY
  1.  .S FBPICN=K_U_L
  1.  .S FBY=$S($P(Y,U,12):$P(Y,U,12),1:$P(Y,U,2))_U_+$P(Y(2),U,9)
  1.  .I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01,STORE^FBAAV01,UPD^FBAAV0
  1.  .D GOTP
  1.  D:FBTXT XMIT^FBAAV01
  1.  Q
  1.  ;
  1. GOTP ; process a B5 line item
  1.  N DFN,FBADJ,FBADJA1,FBADJA2,FBADJR1,FBADJR2,FBIENS,FBPNAMX,FBVY0,FBX
  1.  N FBNPI,FBEDIF,FBIA,FBDODINV,FBCRARC,FBFPPSID,FBAUTHNUM,FBAMTCLM,FBQNTY
  1.  ;
  1.  S FBLNITM=+$P(Y(3),U) ;FPPS line item
  1.  S FBIENS=$P(FBPICN,U,2)_","_$P(FBPICN,U,1)_","
  1.  S FBPAYT=$P(Y(0),"^",20),FBPAYT=$S(FBPAYT]"":FBPAYT,1:"V")
  1.  S FBINVN=$P(Y,"^"),FBINVN=$E("000000000",$L(FBINVN)+1,9)_FBINVN
  1.  S FBEDIF=$S($P(Y,"^",13)]"":"Y",1:" ") ; EDI flag
  1.  S FBFPPSID=$E($P(Y,U,13),1,12),FBFPPSID=$$RJ^XLFSTR(FBFPPSID,12,0) ;FPPS Claim Number
  1.  S FBAUTHNUM=$P(Y(3),U,2)  ;AUTHORIZATION NUMBER
  1.  I FBAUTHNUM']"" S FBAUTHNUM=$$AUTHRX(FBIENS)
  1.  S FBAUTHNUM=$$LJ^XLFSTR(FBAUTHNUM,"29T"," ")
  1.  S FBAMTCLM=$P(Y(0),U,4) ;Amount Claimed = Service Line Billed Amount
  1.  S FBDIN=$$AUSDT^FBAAV3($P(Y,"^",2))
  1.  ;
  1.  S FBVFN=$P(Y,"^",4)
  1.  S FBNPI=$$EN^FBNPILK(FBVFN)
  1.  S FBVY0=$G(^FBAAV(FBVFN,0)) ; vendor 0 node
  1.  ;
  1.  S FBIA=+$P(Y,U,23)                                      ; IPAC agreement ptr
  1.  S FBIA=$S(FBIA:$P($G(^FBAA(161.95,FBIA,0)),U,1),1:"")   ; IPAC external agreement ID# or ""
  1.  S FBIA=$$LJ^XLFSTR(FBIA,"10T")                          ; format to 10 characters
  1.  S FBDODINV=$P(Y(6),U,1)                                 ; DoD invoice#
  1.  S FBDODINV=$$LJ^XLFSTR(FBDODINV,"22T")                  ; format to 22 characters
  1.  ;
  1.  S FBVID=$P(FBVY0,U,2),FBVID=$E(FBVID,1,9)_$E(PAD,$L(FBVID)+1,9)
  1.  S FBCSN=$S($P(FBVY0,U,2)]"":$P(FBVY0,U,10),1:"")
  1.  S FBCSN=$E("0000",$L(FBCSN)+1,4)_FBCSN
  1.  I FBPAYT="R" S FBVID=$E(PAD,1,9),FBCSN=$E(PAD,1,4)
  1.  K FBVY0
  1.  ;
  1.  S FBRX=$P(Y(0),"^",1),FBRX=$E("00000000",$L(FBRX)+1,8)_FBRX
  1.  I '$L($G(FBAASN)) D STATION^FBAAUTL
  1.  S FBPSA=$$PSA^FBAAV5(+$P(Y(2),U,5),+FBAASN) I $L(+FBPSA)'=3 S FBPSA=999
  1.  S FBTD=$$AUSDT^FBAAV3($P(Y(0),"^",3))
  1.  S FBSUSP=$P(Y(0),"^",8),FBSUSP=$S(FBSUSP="":" ",$D(^FBAA(161.27,+FBSUSP,0)):$P(^(0),"^"),1:" ")
  1.  S FBAC=$$AUSAMT^FBAAV3($P(Y(0),"^",4),8)
  1.  S FBAP=$$AUSAMT^FBAAV3($P(Y(0),"^",16),8)
  1.  I FBAC=FBAP S FBAP="        "
  1.  ;
  1.  S FBQNTY=+$P(Y(0),U,13)  ;Quantity/Units 162.11,1.6
  1.  S FBQNTY=$S((FBQNTY>0)&(FBQNTY<10000000):FBQNTY,1:0)
  1.  S FBQNTY=$$AUSNUM^FBAAV3(FBQNTY,5,12)
  1.  ;
  1.  S DFN=$P(Y(0),"^",5)
  1.  Q:'DFN
  1.  Q:'$D(^DPT(DFN,0))
  1.  ; Note: Prior to the following line Y(0) = the 0 node of subfile 161.11
  1.  ;After the line Y(0) will be the 0 node of file #2
  1.  S VAPA("P")="",Y(0)=^DPT(DFN,0) D PAT^FBAAUTL2,ADD^VADPT
  1.  S FBPNAMX=$$HL7NAME^FBAAV2(DFN)
  1.  S FBST=$S($P(VAPA(5),"^")="":"  ",$D(^DIC(5,$P(VAPA(5),"^"),0)):$P(^(0),"^",2),1:"  ")
  1.  I $L(FBST)>2 S FBST="**"
  1.  S:$L(FBST)'=2 FBST=$E(PAD,$L(FBST)+1,2)_FBST
  1.  S FBCTY=$S($P(VAPA(7),"^")="":"   ",FBST="  ":"   ",$D(^DIC(5,$P(VAPA(5),"^"),1,$P(VAPA(7),"^"),0)):$P(^(0),"^",3),1:"   ")
  1.  I $L(FBCTY)'=3 S FBCTY=$E("000",$L(FBCTY)+1,3)_FBCTY
  1.  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)
  1.  ;
  1.  ; get and format CARCs and RARCs
  1.  D CRARC(FBIENS,.FBCRARC) ; FB*3.5*158
  1.  ;
  1.  ; build 1st line
  1.  S FBSTR=5_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_FBCSN_FBAC_FBAP_FBAAON
  1.  S FBSTR=FBSTR_FBSUSP_FBTD_FBRX_FBDIN_FBINVN
  1.  S FBSTR=FBSTR_$E(PAD,1,33)_FBST_FBCTY_FBZIP ; reserved for foreign addr
  1.  S FBSTR=FBSTR_$E(FBPSA,1,3)_$P(FBY,U,2)_$E(PAD,1,8)
  1.  S FBSTR=FBSTR_$$PADZ^FBAAV01(FBPICN,30)_$$AUSDT^FBAAV3(+FBY)_"~"
  1.  D STORE^FBAAV01
  1.  ;
  1.  ; build 2nd line
  1.  ; FB*3.5*158
  1.  S FBADJR1=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,2),1:""),FBADJR1=$$RJ^XLFSTR(FBADJR1,5," ")
  1.  S FBADJR2=$S($D(FBCRARC(2)):$P(FBCRARC(2),U,2),1:""),FBADJR2=$$RJ^XLFSTR(FBADJR2,5," ")
  1.  S FBSTR=FBADJR1_FBADJR2
  1.  S FBADJA1=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,3),1:0),FBADJA1=$$AUSAMT^FBAAV3(FBADJA1,9,1)
  1.  S FBADJA2=$S($D(FBCRARC(2)):$P(FBCRARC(2),U,3),1:0),FBADJA2=$$AUSAMT^FBAAV3(FBADJA2,9,1)
  1.  S FBSTR=FBSTR_FBADJA1_FBADJA2
  1.  ;
  1.  S FBSTR=FBSTR_FBNPI_FBEDIF
  1.  S FBSTR=FBSTR_FBIA_FBDODINV                          ; IPAC data from FB*3.5*123
  1.  ; FB*3.5*158
  1.  S FBSTR=FBSTR_FBFPPSID
  1.  S FBSTR=FBSTR_FBAUTHNUM ;Authorization Number
  1.  S FBSTR=FBSTR_$$RJ^XLFSTR(FBLNITM,3,0) ;FPPS line item
  1.  S FBSTR=FBSTR_$$AUSAMT^FBAAV3(FBAMTCLM,12) ;Service Line Billed Amount
  1.  ;
  1.  S FBADJG=$S($D(FBCRARC(1)):$P(FBCRARC(1),U),1:""),FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
  1.  S FBRRC1=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,4),1:""),FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
  1.  S FBRRC2=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,5),1:""),FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
  1.  S FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
  1.  ;
  1.  S FBADJG=$S($D(FBCRARC(2)):$P(FBCRARC(2),U),1:""),FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
  1.  S FBRRC1=$S($D(FBCRARC(2)):$P(FBCRARC(2),U,4),1:""),FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
  1.  S FBRRC2=$S($D(FBCRARC(2)):$P(FBCRARC(2),U,5),1:""),FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
  1.  S FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
  1.  ; 
  1.  F FBI=3:1:5 D
  1.  . S FBADJG=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U),1:""),FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
  1.  . S FBADJR=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U,2),1:""),FBADJR=$$RJ^XLFSTR(FBADJR,5," ")
  1.  . S FBRRC1=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U,4),1:""),FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
  1.  . S FBRRC2=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U,5),1:""),FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
  1.  . S FBADJA=$S($D(FBCRARC(FBI)):$P(FBCRARC(FBI),U,3),1:0),FBADJA=$$AUSAMT^FBAAV3(FBADJA,9,1)
  1.  . S FBSTR=FBSTR_FBADJG_FBADJR_FBRRC1_FBRRC2_FBADJA
  1.  ;
  1.  S FBSTR=FBSTR_FBQNTY
  1.  ;
  1.  S FBSTR=FBSTR_"~$"
  1.  D STORE^FBAAV01
  1.  Q
  1.  ;
  1. AUTHRX(IENS) ; returns REFERENCE NUMBER from ^FB7078
  1.  ;
  1.  N REFNUM
  1.  S REFNUM=""
  1.  D GETS^DIQ(162.11,IENS,"26","I","FB")
  1.  I $D(FB),FB(162.11,IENS,26,"I")["FB7078" D
  1.  . S FB7078=$P(FB(162.11,IENS,26,"I"),";")
  1.  . S:$D(^FB7078(FB7078,0)) REFNUM=$P(^FB7078(FB7078,0),U)
  1.  Q REFNUM
  1.  ;
  1. HL7NAME(FBDFN) ; return patient name formatted in a 35 character length string
  1.  N FBAR,FBNM
  1.  S FBAR("FILE")=2,FBAR("IENS")=FBDFN,FBAR("FIELD")=.01
  1.  S FBNM=$$HLNAME^XLFNAME(.FBAR,"L35","|")
  1.  Q $$LRJ^FBAAV4(FBNM,35)
  1.  ;
  1. CRARC(FBIENS,FBCRARC) ; load CARCs and RARCs
  1.  ;
  1.  N FBADJ,FBRRMK
  1.  D LOADADJ^FBRXFA(FBIENS,.FBADJ)
  1.  D LOADRR^FBRXFR(FBIENS,.FBRRMK)
  1.  D CRARC^FBAAUTL(.FBADJ,.FBRRMK,.FBCRARC)
  1.  Q
  1.  ;