FBAAV5.m

FBAAV5 ;AISC/GRR - CREATE TRANSACTIONS FOR CH/CNH PAYMENTS ;11 Apr 2006  2:54 PM

 ;;3.5;FEE BASIS;**3,55,89,98,116,108,139,123,158**;JAN 30, 1995;Build 94

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 ; Reference to API $$CODEABA^ICDEX supported by ICR #5747

 ;

 D CKB9V^FBAAV01 I $G(FBERR) K FBERR Q

 G:FBSTAT="S"&(FBCHB="Y")&($P(Y(0),"^",18)'="Y") ^FBAAV6

DETCH S FBTXT=0

 ; HIPAA 5010 - line items that have 0.00 amount paid are now required to go to Central Fee

 F K=0:0 S K=$O(^FBAAI("AC",J,K)) Q:K'>0  S Y(0)=$G(^FBAAI(K,0)),Y(2)=$G(^(2)),Y(3)=$G(^(3)),Y(5)=$G(^(5)),Y(7)=$G(^(7)) I Y(0)]"" D

 .N FBPICN,FBY

 .S FBPICN=K

 .S FBY=$S($P(Y(2),U,2):$P(Y(2),U,2),1:$P(Y(0),U,2))_U_+$P(Y(2),U,3)

 .I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01,STORE^FBAAV01,UPD^FBAAV0

 .D GOT

 D:FBTXT XMIT^FBAAV01 Q

GOT ; process an inpatient invoice

 N DFN,FBADJ,FBADJA,FBADJR,FBADMIT,FBAUTHF,FBCDAYS,FBDISDT,FBDISTY,FBNPI

 N FBDRG,FBIENS,FBPA,FBPNAMX,FBVMID,FBX,FBFPPSID,FBCRARC,FBADJG,FBRRC1,FBRRC2

 N FB4LN,FBADMTDX,FBCSVDT,FBCSID,FBEDIF,FBCNTRN,FBAUTHNUM,FBDRGWT,FBBILAMT

 N FBIA,FBDODINV,FBCLAMT,FBPYMTH

 S FBIENS=K_","

 S FBCSVDT=$$FRDTINV^FBCSV1(K)

 I '$L($G(FBAASN)) D STATION^FBAAUTL

 S FBPSA=$$PSA(+$P(Y(0),U,20),+$G(FBAASN)) I $L(+FBPSA)'=3 S FBPSA=999

 S FBPAYT=$P(Y(0),"^",13),FBPAYT=$S(FBPAYT]"":FBPAYT,1:"V")

 S L=$P(Y(0),"^",3)

 S FBVID=$S($D(^FBAAV(L,0)):$P(^(0),"^",2),1:"")

 ;

 ; FB*3.5*123 - gather and format IPAC agreement ID and DoD invoice# for federal vendors

 S FBIA=+$P(Y(5),U,10)                                   ; IPAC vendor agreement pointer (FB*3.5*123)

 S FBIA=$S(FBIA:$P($G(^FBAA(161.95,FBIA,0)),U,1),1:"")   ; IPAC external agreement ID# or ""

 S FBDODINV=$P(Y(5),U,7)                                 ; DoD invoice#

 I $$IPACREQD^FBAAMP(L) D

 . N FBIPIEN

 . ;

 . ; If IPAC is required, but IPAC ID is not on file, and only 1 active IPAC agreement exists, then save it/use it

 . I FBIA="" S FBIA=$$IPACID^FBAAMP(L,.FBIPIEN) I FBIA'="",FBIPIEN D

 .. N FBIAFDA

 .. S FBIAFDA(162.5,FBIENS,87)=FBIPIEN    ; ipac vendor agreement ien

 .. D FILE^DIE("","FBIAFDA")              ; update the database

 .. Q

 . I FBIA="" S FBIA="9999999999"          ; if still not found, send error condition to Central Fee

 . ;

 . ; if IPAC is required, but DoD invoice# is not on file, then attempt to use PATIENT CONTROL NUMBER (field# 55)

 . I FBDODINV="" S FBDODINV=$P(Y(2),U,11) I FBDODINV'="" D

 .. N FBIAFDA

 .. S FBIAFDA(162.5,FBIENS,86)=FBDODINV   ; DoD invoice# field

 .. D FILE^DIE("","FBIAFDA")              ; update the database

 .. Q

 . I FBDODINV="" S FBDODINV="9999999999999999999999"  ; if still not found, send error condition to Central Fee

 . Q

 ;

 S FBIA=$$LJ^XLFSTR(FBIA,"10T")                          ; format IPAC agreement ID to 10 characters

 S FBDODINV=$$LJ^XLFSTR(FBDODINV,"22T")                  ; format DoD invoice# to 22 characters

 ;

 S FBNPI=$$EN^FBNPILK(L)

 S FBVID=FBVID_$E(PAD,$L(FBVID)+1,11)

 S:FBPAYT="R" FBVID=$E(PAD,1,11)

 S FBVMID=$S($D(^FBAAV(L,0)):$P(^(0),"^",17),1:"")

 S FBVMID=$E(PAD,$L(FBVMID)+1,6)_FBVMID

 S POV=$P(Y(0),"^",18)

 S POV=$S(POV']"":"",POV="A":6,POV="B":7,POV="C":8,POV="D":9,POV="E":10,1:POV),POV=$S(POV']"":40,$D(^FBAA(161.82,POV,0)):$P(^(0),"^",3),1:40),FBPOV=POV

 S FBPATT=$P(Y(0),"^",19),FBPATT=$S(FBPATT]"":FBPATT,1:10)

 S FBFTD=$$AUSDT^FBAAV3($P(Y(0),"^",6)) ; from treatment date

 S FBTTD=$$AUSDT^FBAAV3($P(Y(0),"^",7)) ; to treatment date

 S FBSUSP=$P(Y(0),"^",11),FBSUSP=$S(FBSUSP="":" ",$D(^FBAA(161.27,FBSUSP,0)):$P(^(0),"^",1),1:" ")

 S FBINVN=$P(Y(0),"^",1)

 S FBINVN=$E("000000000",$L(FBINVN)+1,9)_FBINVN

 S FBDIN=$$AUSDT^FBAAV3($P(Y(0),"^",2)) ; invoice date rec'd

 S FBAP=$$AUSAMT^FBAAV3($P(Y(0),"^",9),9) ;AMOUNT PAID (#8)

 S FBAC=$$AUSAMT^FBAAV3($P(Y(0),"^",8),9) ;AMOUNT CLAIMED (#7)

 S FBPA=$$AUSAMT^FBAAV3($P(Y(0),"^",26),9) ;NVH PRICER AMOUNT (#26)

 S FBDRG=$P(Y(0),"^",24),FBDRG=$E(PAD,$L(FBDRG)+1,4)_FBDRG

 S FBAUTHF=$S($P(Y(0),U,5)["FB583":"U",1:"A") ; auth/unauth flag

 S FBCSID=$$LJ^XLFSTR($P(Y(2),"^",11),20," ") ; patient acct #

 S FBDRGWT=$P(Y(2),U,12),FBDRGWT=$$AUSNUM^FBAAV3(FBDRGWT,4,8) ;DRG WEIGHT

 S FBPYMTH=$P(Y(2),U,16),FBPYMTH=$$PYMTH^FBAAV0(FBPYMTH)  ;PAYMENT METHODOLOGY

 S FBPYMTH=$$RJ^XLFSTR(FBPYMTH,1," ")

 S FBBILAMT=$P(Y(0),U,22),FBBILAMT=$$AUSAMT^FBAAV3(FBBILAMT,10,1) ;BILLED CHARGES

 S FBFPPSID=$$RJ^XLFSTR($P(Y(3),U),"12T",0) ; FPPS CLAIM ID

 S FBAUTHNUM=$P(Y(7),U) I FBAUTHNUM']"" S FBAUTHNUM=$$AUTHIP(FBIENS)   ;AUTHORIZATION NUMBER

 S FBAUTHNUM=$$LJ^XLFSTR(FBAUTHNUM,"29T"," ")

 S FBCLAMT=$P(Y(7),U,2),FBCLAMT=$$AUSAMT^FBAAV3(FBCLAMT,9)  ;CLAIM LEVEL ALLOWED AMOUNT

 S FBADMTDX=$P(Y(5),"^",9) ; admitting Dx pointer

 D

 . N FBCNTRP

 . S FBCNTRP=$P(Y(5),"^",8)

 . S FBCNTRN=$S(FBCNTRP:$P($G(^FBAA(161.43,FBCNTRP,0)),"^"),1:"")

 . S FBCNTRN=$$LJ^XLFSTR(FBCNTRN,20," ") ; contract number

 S FBEDIF=$S($P($G(^FBAAI(K,3)),"^")]"":"Y",1:" ") ;EDI flag

 ;

 K FBDX

 S FBDX(0)="       " ; initialize admitting Dx transmitted value to 7 spaces

 F M=1:1:25 S FBDX(M)="        "  ;8 spaces

 I FBADMTDX D

 . N FBX

 . S FBX=$$ICD9^FBCSV1(FBADMTDX,FBCSVDT)

 . Q:FBX=""

 . ;DEM;139 ICD-10 Project - decimal is stripped only from ICD-10 diagnosis codes and not ICD-9 diagnosis codes.

 . I $$CODEABA^ICDEX(FBX,80,30)>0 S:FBX["." FBX=$P(FBX,".",1)_$P(FBX,".",2)  ;DEM;139 ICD-10 Project

 . S FBDX(0)=FBX_$E("       ",$L(FBX)+1,7)

 S FBYDX=$G(^FBAAI(K,"DX")),FBYPOA=$G(^FBAAI(K,"POA"))

 F M=1:1:25 Q:$P(FBYDX,"^",M)=""  D

 . S FBDX(M)=$$DX($P(FBYDX,"^",M),FBCSVDT,$P(FBYPOA,"^",M))

 K FBYDX,FBYPOA

 ;

 K FBPRC

 F M=1:1:25 S FBPRC(M)="       "  ;7 SPACES

 S FBYPROC=$G(^FBAAI(K,"PROC"))

 F M=1:1:25 Q:$P(FBYPROC,"^",M)=""  D

 . S FBPRC(M)=$$PROC($P(FBYPROC,"^",M),FBCSVDT)

 K FBYPROC

 ;

 S DFN=$P(Y(0),"^",4)

 ; Note: Prior to the following line Y(0) = the 0 node of file 162.5

 ;After the line Y(0) will equal the 0 node of file #2

 S VAPA("P")="",Y(0)=$S($D(^DPT(DFN,0)):^(0),1:"")

 D PAT^FBAAUTL2

 ; obtain date of birth, must follow call to PAT^FBAAUTL2 to overwrite 

 ; the value returned from it

 S FBDOB=$$AUSDT^FBAAV3($P(Y(0),"^",3))

 D ADD^VADPT

 S FBPNAMX=$$HL7NAME^FBAAV2(DFN) ; patient name

 S FBST=$S($P(VAPA(5),"^",1)="":"  ",$D(^DIC(5,$P(VAPA(5),"^",1),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),"^",1)="":"   ",FBST="  ":"   ",$D(^DIC(5,$P(VAPA(5),"^",1),1,$P(VAPA(7),"^",1),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)

 S FBADMIT=$$AUSDT^FBAAV3($P($$B9ADMIT(FBIENS),".")) ; admission date

 ; get and format discharge date and type

 S FBX=$$B9DISCHG(FBIENS)

 S FBDISDT=$$AUSDT^FBAAV3($P($P(FBX,U),".")) ; discharge date

 S FBDISTY=$$RJ^XLFSTR($P(FBX,U,2),3,0) ; discharge type

 K FBX

 ; get volume indicator (covered days)

 S FBCDAYS=$$RJ^XLFSTR($$GET1^DIQ(162.5,FBIENS,54),5,"0")

 ; obtain and format the adjustment codes and amounts

 ; get and format adjustment reason codes and amounts (if any)

 D CRARC(FBIENS,.FBCRARC)

 ;

 ; determine if 4th line needed (set FB4LN =1 when true)

 S FB4LN=1 I FBDX(11)="        ",FBPRC(11)="       " S FB4LN=0

 ;

 ; build 1st line

 S FBSTR=9_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_"  "_FBAP_FBAAON_FBSUSP

 S FBSTR=FBSTR_FBPOV_FBPATT_FBFTD_FBTTD_FBDIN_FBINVN_FBVMID

 S FBSTR=FBSTR_$E(PAD,1,33)_FBST_FBCTY_FBZIP ; reserved for foreign addr

 S FBSTR=FBSTR_FBPSA_$P(FBY,U,2)_$E(PAD,1,14)

 F I=1:1:5 S FBSTR=FBSTR_FBDX(I)

 S FBSTR=FBSTR_"~"

 D STORE^FBAAV01

 ;

 ; build 2nd line

 S FBSTR=$$PADZ^FBAAV01(FBPICN,23)_$$AUSDT^FBAAV3(+FBY)

 F I=1:1:5 S FBSTR=FBSTR_FBPRC(I)

 S FBADJR=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,2),1:""),FBADJR=$$RJ^XLFSTR(FBADJR,5," ")

 S FBADJA=$S($D(FBCRARC(1)):$P(FBCRARC(1),U,3),1:0),FBADJA=$$AUSAMT^FBAAV3(FBADJA,10,1)

 S FBSTR=FBSTR_FBAC_FBPA_FBDRG_" "_FBADMIT_FBDISDT_FBDOB_FBDISTY_FBCDAYS_FBAUTHF_FBADJR_FBADJA_FBNPI_FBDX(0)_FBCSID_FBEDIF_FBCNTRN

 S FBSTR=FBSTR_FBIA_FBDODINV_"~"                          ; IPAC data from FB*3.5*123

 D STORE^FBAAV01

 ;

 ; build 3rd line

 S FBSTR=""

 F I=6:1:10 S FBSTR=FBSTR_FBDX(I)

 F I=6:1:10 S FBSTR=FBSTR_FBPRC(I)

 S FBSTR=FBSTR_"~"

 D STORE^FBAAV01

 ;

 ; build 4th line

 S FBSTR=""

 I FB4LN D

 . F I=11:1:25 S FBSTR=FBSTR_FBDX(I)

 . F I=11:1:25 S FBSTR=FBSTR_FBPRC(I)

 S FBSTR=FBSTR_"~"

 D STORE^FBAAV01

 ;

 ; build 5th line FB*3.5*158

 S FBSTR=FBFPPSID

 S FBSTR=FBSTR_FBAUTHNUM ;Authorization Number

 S FBSTR=FBSTR_FBCLAMT   ;Claim Level Allowed 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

 ; 

 F FBI=2: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,10,1)

 . S FBSTR=FBSTR_FBADJG_FBADJR_FBRRC1_FBRRC2_FBADJA

 ;

 S FBSTR=FBSTR_FBDRGWT_FBBILAMT_FBPYMTH

 S FBSTR=FBSTR_" "  ;Additional Payment Indicator

 S FBSTR=FBSTR_" "  ;Additional Payment Type

 S FBSTR=FBSTR_$$PADZ^FBAAV01(0,30)  ;Parent Internal Control Number

 S FBSTR=FBSTR_"~$"

 D STORE^FBAAV01

 Q

 ;

AUTHIP(IENS) ;

 ;

 N REFNUM

 S REFNUM=""

 D GETS^DIQ(162.5,IENS,"4","I","FB")

 I $D(FB),FB(162.5,IENS,4,"I")["FB7078" D

 . S FB7078=$P(FB(162.5,IENS,4,"I"),";")

 . S:$D(^FB7078(FB7078,0)) REFNUM=$P(^FB7078(FB7078,0),U)

 Q REFNUM

 ;

PSA(X,Y) ;call to set default Primary Service Area (PSA)

 ;to send to Austin.

 ;X = pointer to the institution file

 ;Y = default if unable to determine station number in file 4

 ;call returns the 3 digit station number only

 ;if Y undef return '0'

 I '$G(Y) S Y=0

 Q $S('X:+Y,$E($P($G(^DIC(4,+X,99)),U),1,3)'?3N:+Y,1:$E($P($G(^(99)),U),1,3))

 ;

B9ADMIT(FBIENS) ; Determine Admission Date for a B9 payment

 ; input

 ;   FBIENS

 ; returns admission date in internal FileMan format or null value

 N FB7078,FBRET

 S FBRET=""  ;NULL

 ;

 S FB7078=$$GET1^DIQ(162.5,FBIENS,4,"I") ; associated 7078/583

 ;

 ; if invoice points to a 7078 authorization then get date from the 7078

 I $P(FB7078,";",2)="FB7078(" D

 . N FBY

 . S FBY=$G(^FB7078(+FB7078,0))

 . ; if fee program is civil hospital then return 7078 date of admission

 . I $P(FBY,U,11)=6 S FBRET=$P(FBY,U,15)

 . ; if fee program is CNH then return 7078 authorized from date

 . I $P(FBY,U,11)=7 S FBRET=$P(FBY,U,4)

 ;

 ; if invoice points to an unauthorized claim then use the treatment from

 ;   date on the unauthorized claim

 I $P(FB7078,";",2)="FB583(" D

 . N FBY

 . S FBY=$G(^FB583(+FB7078,0))

 . S FBRET=$P(FBY,U,5)

 ;

 ; return the result

 Q FBRET

 ;

B9DISCHG(FBIENS) ; Determine Discharge Date and Type for a B9 payment

 ; input

 ;   FBIENS - Invoice IEN (file 162.5) with trailing comma

 ; returns discharge date in internal FileMan format or null value and

 ; discharge type or null value

 N FB7078,FBDISDT,FBDISTY

 S (FBDISDT,FBDISTY)=""

 ;

 S FB7078=$$GET1^DIQ(162.5,FBIENS,4,"I") ; associated 7078/583

 ;

 ; if invoice points to an unauthorized claim then use the treatment to

 ;   date on the unauthorized claim

 I $P(FB7078,";",2)="FB583(" D

 . N FBY

 . S FBY=$G(^FB583(+FB7078,0))

 . S FBDISDT=$P(FBY,U,6)

 . S FBDISTY=$$GET1^DIQ(162.5,FBIENS,"6.5:1") ; discharge type

 ;

 ; if invoice points to a 7078 authorization then get date from the 7078

 I $P(FB7078,";",2)="FB7078(" D

 . N FBY

 . S FBY=$G(^FB7078(+FB7078,0))

 . ;

 . ; if fee program is civil hospital then return 7078 date of discharge

 . I $P(FBY,U,11)=6 D

 . . S FBDISDT=$P(FBY,U,16) ; discharge date

 . . S FBDISTY=$$GET1^DIQ(162.5,FBIENS,"6.5:1") ; discharge type

 . ;

 . ; if fee program is CNH then get date & type from CNH activity file

 . I $P(FBY,U,11)=7 D

 . . N DFN,FBADMIT,FBADMITR,FBACTA,FBAUTHP,FBDA,FBDTR

 . . S DFN=$P(FBY,U,3) ; patient IEN

 . . S FBADMIT=$P($P(FBY,U,4),".") ; CNH admission date

 . . S FBAUTHP=+$O(^FBAAA("AG",FB7078,DFN,0)) ; authorization 'pointer'

 . . ;

 . . ; find the admission entry in CNH ACTIVITY file   

 . . S FBACTA=0 ; init the admission activity ien

 . . S FBADMITR=9999999-FBADMIT ; reverse admission date

 . . S FBDTR=9999999-$$FMADD^XLFDT(FBADMIT,1) ; start loop

 . . F  S FBDTR=$O(^FBAACNH("AF",DFN,FBDTR)) Q:'FBDTR!($P(FBDTR,".")>FBADMITR)  D  Q:FBACTA

 . . . S FBDA=0 F  S FBDA=$O(^FBAACNH("AF",DFN,FBDTR,FBDA)) Q:'FBDA  D

 . . . . S FBY=$G(^FBAACNH(FBDA,0))

 . . . . I $P(FBY,U,3)="A",$P(FBY,U,10)=FBAUTHP S FBACTA=FBDA ; found it

 . . Q:'FBACTA  ; could not find the admission activity

 . . ;

 . . ; get date from associated discharge (if any) in CNH ACTIVITY file

 . . S FBDA=" "

 . . F  S FBDA=$O(^FBAACNH("AC",FBACTA,FBDA),-1) Q:FBDA'>0  D  Q:FBDISDT

 . . . S FBY=$G(^FBAACNH(FBDA,0))

 . . . I $P(FBY,U,3)="D" D

 . . . . S FBDISDT=$P($P(FBY,U),".")

 . . . . S FBDISTY=$P(FBY,U,8)

 . . . . I FBDISTY'="" S FBDISTY=FBDISTY+100

 ;

 ; return the result

 Q FBDISDT_"^"_FBDISTY

 ;

DX(FBDX,FBDATE,FBPOA) ; format diagnosis & POA for B9

 ; Input

 ;   FBDX   = pointer to file 80 (ICD diagnosis)

 ;   FBDATE = fileman date

 ;   FBPOA  = (optional) poiner to file 161.94 (present on admission)

 ; Returns formatted string of 8 characters

 N FBRET,FBX,FBX2

 S FBRET="        "

 I FBDX D

 . S FBX=$$ICD9^FBCSV1(FBDX,FBDATE)

 . Q:FBX=""

 . ;DEM;139 ICD-10 Project - decimal is stripped only from ICD-10 diagnosis codes and not ICD-9 diagnosis codes.

 . I $$CODEABA^ICDEX(FBX,80,30)>0 S:FBX["." FBX=$P(FBX,".",1)_$P(FBX,".",2)  ;DEM;139 ICD-10 Project

 . S FBX=FBX_$E("       ",$L(FBX)+1,7)

 . S FBX2=$S($G(FBPOA):$P($G(^FB(161.94,FBPOA,0)),"^"),1:"")

 . S:FBX2="" FBX2=" "

 . S FBRET=FBX_FBX2

 Q FBRET

 ;

PROC(FBPROC,FBDATE) ; format procedure for B9

 ; Input

 ;   FBPROC = pointer to file 80.1 (ICD operation/procedure)

 ;   FBDATE = fileman date

 ; Returns formatted string of 7 characters

 N FBRET,FBX

 S FBRET="       "

 I FBPROC D

 . S FBX=$$ICD0^FBCSV1(FBPROC,FBDATE)

 . Q:FBX=""

 . S FBX=FBX_$E("       ",$L(FBX)+1,7)

 . S FBRET=FBX

 Q FBRET

 ;

CRARC(FBIENS,FBCRARC) ; load CARCs and RARCs

 ;

 N FBADJ,FBRRMK

 D LOADADJ^FBCHFA(FBIENS,.FBADJ)

 D LOADRR^FBCHFR(FBIENS,.FBRRMK)

 D CRARC^FBAAUTL(.FBADJ,.FBRRMK,.FBCRARC)

 Q

 ;FBAAV5

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBAAV5   14867     printed  Mar 13, 2025@21:01:42                                                                                                                                                                                                     Page 2

FBAAV5    ;AISC/GRR - CREATE TRANSACTIONS FOR CH/CNH PAYMENTS ;11 Apr 2006  2:54 PM

 +1       ;;3.5;FEE BASIS;**3,55,89,98,116,108,139,123,158**;JAN 30, 1995;Build 94

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ; Reference to API $$CODEABA^ICDEX supported by ICR #5747

 +5       ;

 +6        DO CKB9V^FBAAV01

           IF $GET(FBERR)

               KILL FBERR

               QUIT 

 +7        if FBSTAT="S"&(FBCHB="Y")&($PIECE(Y(0),"^",18)'="Y")

               GOTO ^FBAAV6

DETCH      SET FBTXT=0

 +1       ; HIPAA 5010 - line items that have 0.00 amount paid are now required to go to Central Fee

 +2        FOR K=0:0

               SET K=$ORDER(^FBAAI("AC",J,K))

               if K'>0

                   QUIT 

               SET Y(0)=$GET(^FBAAI(K,0))

               SET Y(2)=$GET(^(2))

               SET Y(3)=$GET(^(3))

               SET Y(5)=$GET(^(5))

               SET Y(7)=$GET(^(7))

               IF Y(0)]""

                   Begin DoDot:1

 +3                    NEW FBPICN,FBY

 +4                    SET FBPICN=K

 +5                    SET FBY=$SELECT($PIECE(Y(2),U,2):$PIECE(Y(2),U,2),1:$PIECE(Y(0),U,2))_U_+$PIECE(Y(2),U,3)

 +6                    IF 'FBTXT

                           SET FBTXT=1

                           DO NEWMSG^FBAAV01

                           DO STORE^FBAAV01

                           DO UPD^FBAAV0

 +7                    DO GOT

                   End DoDot:1

 +8        if FBTXT

               DO XMIT^FBAAV01

           QUIT 

GOT       ; process an inpatient invoice

 +1        NEW DFN,FBADJ,FBADJA,FBADJR,FBADMIT,FBAUTHF,FBCDAYS,FBDISDT,FBDISTY,FBNPI

 +2        NEW FBDRG,FBIENS,FBPA,FBPNAMX,FBVMID,FBX,FBFPPSID,FBCRARC,FBADJG,FBRRC1,FBRRC2

 +3        NEW FB4LN,FBADMTDX,FBCSVDT,FBCSID,FBEDIF,FBCNTRN,FBAUTHNUM,FBDRGWT,FBBILAMT

 +4        NEW FBIA,FBDODINV,FBCLAMT,FBPYMTH

 +5        SET FBIENS=K_","

 +6        SET FBCSVDT=$$FRDTINV^FBCSV1(K)

 +7        IF '$LENGTH($GET(FBAASN))

               DO STATION^FBAAUTL

 +8        SET FBPSA=$$PSA(+$PIECE(Y(0),U,20),+$GET(FBAASN))

           IF $LENGTH(+FBPSA)'=3

               SET FBPSA=999

 +9        SET FBPAYT=$PIECE(Y(0),"^",13)

           SET FBPAYT=$SELECT(FBPAYT]"":FBPAYT,1:"V")

 +10       SET L=$PIECE(Y(0),"^",3)

 +11       SET FBVID=$SELECT($DATA(^FBAAV(L,0)):$PIECE(^(0),"^",2),1:"")

 +12      ;

 +13      ; FB*3.5*123 - gather and format IPAC agreement ID and DoD invoice# for federal vendors

 +14      ; IPAC vendor agreement pointer (FB*3.5*123)

           SET FBIA=+$PIECE(Y(5),U,10)

 +15      ; IPAC external agreement ID# or ""

           SET FBIA=$SELECT(FBIA:$PIECE($GET(^FBAA(161.95,FBIA,0)),U,1),1:"")

 +16      ; DoD invoice#

           SET FBDODINV=$PIECE(Y(5),U,7)

 +17       IF $$IPACREQD^FBAAMP(L)

               Begin DoDot:1

 +18               NEW FBIPIEN

 +19      ;

 +20      ; If IPAC is required, but IPAC ID is not on file, and only 1 active IPAC agreement exists, then save it/use it

 +21               IF FBIA=""

                       SET FBIA=$$IPACID^FBAAMP(L,.FBIPIEN)

                       IF FBIA'=""

                           IF FBIPIEN

                               Begin DoDot:2

 +22                               NEW FBIAFDA

 +23      ; ipac vendor agreement ien

                                   SET FBIAFDA(162.5,FBIENS,87)=FBIPIEN

 +24      ; update the database

                                   DO FILE^DIE("","FBIAFDA")

 +25                               QUIT 

                               End DoDot:2

 +26      ; if still not found, send error condition to Central Fee

                   IF FBIA=""

                       SET FBIA="9999999999"

 +27      ;

 +28      ; if IPAC is required, but DoD invoice# is not on file, then attempt to use PATIENT CONTROL NUMBER (field# 55)

 +29               IF FBDODINV=""

                       SET FBDODINV=$PIECE(Y(2),U,11)

                       IF FBDODINV'=""

                           Begin DoDot:2

 +30                           NEW FBIAFDA

 +31      ; DoD invoice# field

                               SET FBIAFDA(162.5,FBIENS,86)=FBDODINV

 +32      ; update the database

                               DO FILE^DIE("","FBIAFDA")

 +33                           QUIT 

                           End DoDot:2

 +34      ; if still not found, send error condition to Central Fee

                   IF FBDODINV=""

                       SET FBDODINV="9999999999999999999999"

 +35               QUIT 

               End DoDot:1

 +36      ;

 +37      ; format IPAC agreement ID to 10 characters

           SET FBIA=$$LJ^XLFSTR(FBIA,"10T")

 +38      ; format DoD invoice# to 22 characters

           SET FBDODINV=$$LJ^XLFSTR(FBDODINV,"22T")

 +39      ;

 +40       SET FBNPI=$$EN^FBNPILK(L)

 +41       SET FBVID=FBVID_$EXTRACT(PAD,$LENGTH(FBVID)+1,11)

 +42       if FBPAYT="R"

               SET FBVID=$EXTRACT(PAD,1,11)

 +43       SET FBVMID=$SELECT($DATA(^FBAAV(L,0)):$PIECE(^(0),"^",17),1:"")

 +44       SET FBVMID=$EXTRACT(PAD,$LENGTH(FBVMID)+1,6)_FBVMID

 +45       SET POV=$PIECE(Y(0),"^",18)

 +46       SET POV=$SELECT(POV']"":"",POV="A":6,POV="B":7,POV="C":8,POV="D":9,POV="E":10,1:POV)

           SET POV=$SELECT(POV']"":40,$DATA(^FBAA(161.82,POV,0)):$PIECE(^(0),"^",3),1:40)

           SET FBPOV=POV

 +47       SET FBPATT=$PIECE(Y(0),"^",19)

           SET FBPATT=$SELECT(FBPATT]"":FBPATT,1:10)

 +48      ; from treatment date

           SET FBFTD=$$AUSDT^FBAAV3($PIECE(Y(0),"^",6))

 +49      ; to treatment date

           SET FBTTD=$$AUSDT^FBAAV3($PIECE(Y(0),"^",7))

 +50       SET FBSUSP=$PIECE(Y(0),"^",11)

           SET FBSUSP=$SELECT(FBSUSP="":" ",$DATA(^FBAA(161.27,FBSUSP,0)):$PIECE(^(0),"^",1),1:" ")

 +51       SET FBINVN=$PIECE(Y(0),"^",1)

 +52       SET FBINVN=$EXTRACT("000000000",$LENGTH(FBINVN)+1,9)_FBINVN

 +53      ; invoice date rec'd

           SET FBDIN=$$AUSDT^FBAAV3($PIECE(Y(0),"^",2))

 +54      ;AMOUNT PAID (#8)

           SET FBAP=$$AUSAMT^FBAAV3($PIECE(Y(0),"^",9),9)

 +55      ;AMOUNT CLAIMED (#7)

           SET FBAC=$$AUSAMT^FBAAV3($PIECE(Y(0),"^",8),9)

 +56      ;NVH PRICER AMOUNT (#26)

           SET FBPA=$$AUSAMT^FBAAV3($PIECE(Y(0),"^",26),9)

 +57       SET FBDRG=$PIECE(Y(0),"^",24)

           SET FBDRG=$EXTRACT(PAD,$LENGTH(FBDRG)+1,4)_FBDRG

 +58      ; auth/unauth flag

           SET FBAUTHF=$SELECT($PIECE(Y(0),U,5)["FB583":"U",1:"A")

 +59      ; patient acct #

           SET FBCSID=$$LJ^XLFSTR($PIECE(Y(2),"^",11),20," ")

 +60      ;DRG WEIGHT

           SET FBDRGWT=$PIECE(Y(2),U,12)

           SET FBDRGWT=$$AUSNUM^FBAAV3(FBDRGWT,4,8)

 +61      ;PAYMENT METHODOLOGY

           SET FBPYMTH=$PIECE(Y(2),U,16)

           SET FBPYMTH=$$PYMTH^FBAAV0(FBPYMTH)

 +62       SET FBPYMTH=$$RJ^XLFSTR(FBPYMTH,1," ")

 +63      ;BILLED CHARGES

           SET FBBILAMT=$PIECE(Y(0),U,22)

           SET FBBILAMT=$$AUSAMT^FBAAV3(FBBILAMT,10,1)

 +64      ; FPPS CLAIM ID

           SET FBFPPSID=$$RJ^XLFSTR($PIECE(Y(3),U),"12T",0)

 +65      ;AUTHORIZATION NUMBER

           SET FBAUTHNUM=$PIECE(Y(7),U)

           IF FBAUTHNUM']""

               SET FBAUTHNUM=$$AUTHIP(FBIENS)

 +66       SET FBAUTHNUM=$$LJ^XLFSTR(FBAUTHNUM,"29T"," ")

 +67      ;CLAIM LEVEL ALLOWED AMOUNT

           SET FBCLAMT=$PIECE(Y(7),U,2)

           SET FBCLAMT=$$AUSAMT^FBAAV3(FBCLAMT,9)

 +68      ; admitting Dx pointer

           SET FBADMTDX=$PIECE(Y(5),"^",9)

 +69       Begin DoDot:1

 +70           NEW FBCNTRP

 +71           SET FBCNTRP=$PIECE(Y(5),"^",8)

 +72           SET FBCNTRN=$SELECT(FBCNTRP:$PIECE($GET(^FBAA(161.43,FBCNTRP,0)),"^"),1:"")

 +73      ; contract number

               SET FBCNTRN=$$LJ^XLFSTR(FBCNTRN,20," ")

           End DoDot:1

 +74      ;EDI flag

           SET FBEDIF=$SELECT($PIECE($GET(^FBAAI(K,3)),"^")]"":"Y",1:" ")

 +75      ;

 +76       KILL FBDX

 +77      ; initialize admitting Dx transmitted value to 7 spaces

           SET FBDX(0)="       "

 +78      ;8 spaces

           FOR M=1:1:25

               SET FBDX(M)="        "

 +79       IF FBADMTDX

               Begin DoDot:1

 +80               NEW FBX

 +81               SET FBX=$$ICD9^FBCSV1(FBADMTDX,FBCSVDT)

 +82               if FBX=""

                       QUIT 

 +83      ;DEM;139 ICD-10 Project - decimal is stripped only from ICD-10 diagnosis codes and not ICD-9 diagnosis codes.

 +84      ;DEM;139 ICD-10 Project

                   IF $$CODEABA^ICDEX(FBX,80,30)>0

                       if FBX["."

                           SET FBX=$PIECE(FBX,".",1)_$PIECE(FBX,".",2)

 +85               SET FBDX(0)=FBX_$EXTRACT("       ",$LENGTH(FBX)+1,7)

               End DoDot:1

 +86       SET FBYDX=$GET(^FBAAI(K,"DX"))

           SET FBYPOA=$GET(^FBAAI(K,"POA"))

 +87       FOR M=1:1:25

               if $PIECE(FBYDX,"^",M)=""

                   QUIT 

               Begin DoDot:1

 +88               SET FBDX(M)=$$DX($PIECE(FBYDX,"^",M),FBCSVDT,$PIECE(FBYPOA,"^",M))