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 ---[H[J[2J[HFBAAV5 14867 printed Dec 13, 2024@01:57 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))
End DoDot:1
+89 KILL FBYDX,FBYPOA
+90 ;
+91 KILL FBPRC
+92 ;7 SPACES
FOR M=1:1:25
SET FBPRC(M)=" "
+93 SET FBYPROC=$GET(^FBAAI(K,"PROC"))
+94 FOR M=1:1:25
if $PIECE(FBYPROC,"^",M)=""
QUIT
Begin DoDot:1
+95 SET FBPRC(M)=$$PROC($PIECE(FBYPROC,"^",M),FBCSVDT)
End DoDot:1
+96 KILL FBYPROC
+97 ;
+98 SET DFN=$PIECE(Y(0),"^",4)
+99 ; Note: Prior to the following line Y(0) = the 0 node of file 162.5
+100 ;After the line Y(0) will equal the 0 node of file #2
+101 SET VAPA("P")=""
SET Y(0)=$SELECT($DATA(^DPT(DFN,0)):^(0),1:"")
+102 DO PAT^FBAAUTL2
+103 ; obtain date of birth, must follow call to PAT^FBAAUTL2 to overwrite
+104 ; the value returned from it
+105 SET FBDOB=$$AUSDT^FBAAV3($PIECE(Y(0),"^",3))
+106 DO ADD^VADPT
+107 ; patient name
SET FBPNAMX=$$HL7NAME^FBAAV2(DFN)
+108 SET FBST=$SELECT($PIECE(VAPA(5),"^",1)="":" ",$DATA(^DIC(5,$PIECE(VAPA(5),"^",1),0)):$PIECE(^(0),"^",2),1:" ")
+109 IF $LENGTH(FBST)>2
SET FBST="**"
+110 if $LENGTH(FBST)'=2
SET FBST=$EXTRACT(PAD,$LENGTH(FBST)+1,2)_FBST
+111 SET FBCTY=$SELECT($PIECE(VAPA(7),"^",1)="":" ",FBST=" ":" ",$DATA(^DIC(5,$PIECE(VAPA(5),"^",1),1,$PIECE(VAPA(7),"^",1),0)):$PIECE(^(0),"^",3),1:" ")
+112 IF $LENGTH(FBCTY)'=3
SET FBCTY=$EXTRACT("000",$LENGTH(FBCTY)+1,3)_FBCTY
+113 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)
+114 ; admission date
SET FBADMIT=$$AUSDT^FBAAV3($PIECE($$B9ADMIT(FBIENS),"."))
+115 ; get and format discharge date and type
+116 SET FBX=$$B9DISCHG(FBIENS)
+117 ; discharge date
SET FBDISDT=$$AUSDT^FBAAV3($PIECE($PIECE(FBX,U),"."))
+118 ; discharge type
SET FBDISTY=$$RJ^XLFSTR($PIECE(FBX,U,2),3,0)
+119 KILL FBX
+120 ; get volume indicator (covered days)
+121 SET FBCDAYS=$$RJ^XLFSTR($$GET1^DIQ(162.5,FBIENS,54),5,"0")
+122 ; obtain and format the adjustment codes and amounts
+123 ; get and format adjustment reason codes and amounts (if any)
+124 DO CRARC(FBIENS,.FBCRARC)
+125 ;
+126 ; determine if 4th line needed (set FB4LN =1 when true)
+127 SET FB4LN=1
IF FBDX(11)=" "
IF FBPRC(11)=" "
SET FB4LN=0
+128 ;
+129 ; build 1st line
+130 SET FBSTR=9_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_" "_FBAP_FBAAON_FBSUSP
+131 SET FBSTR=FBSTR_FBPOV_FBPATT_FBFTD_FBTTD_FBDIN_FBINVN_FBVMID
+132 ; reserved for foreign addr
SET FBSTR=FBSTR_$EXTRACT(PAD,1,33)_FBST_FBCTY_FBZIP
+133 SET FBSTR=FBSTR_FBPSA_$PIECE(FBY,U,2)_$EXTRACT(PAD,1,14)
+134 FOR I=1:1:5
SET FBSTR=FBSTR_FBDX(I)
+135 SET FBSTR=FBSTR_"~"
+136 DO STORE^FBAAV01
+137 ;
+138 ; build 2nd line
+139 SET FBSTR=$$PADZ^FBAAV01(FBPICN,23)_$$AUSDT^FBAAV3(+FBY)
+140 FOR I=1:1:5
SET FBSTR=FBSTR_FBPRC(I)
+141 SET FBADJR=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,2),1:"")
SET FBADJR=$$RJ^XLFSTR(FBADJR,5," ")
+142 SET FBADJA=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,3),1:0)
SET FBADJA=$$AUSAMT^FBAAV3(FBADJA,10,1)
+143 SET FBSTR=FBSTR_FBAC_FBPA_FBDRG_" "_FBADMIT_FBDISDT_FBDOB_FBDISTY_FBCDAYS_FBAUTHF_FBADJR_FBADJA_FBNPI_FBDX(0)_FBCSID_FBEDIF_FBCNTRN
+144 ; IPAC data from FB*3.5*123
SET FBSTR=FBSTR_FBIA_FBDODINV_"~"
+145 DO STORE^FBAAV01
+146 ;
+147 ; build 3rd line
+148 SET FBSTR=""
+149 FOR I=6:1:10
SET FBSTR=FBSTR_FBDX(I)
+150 FOR I=6:1:10
SET FBSTR=FBSTR_FBPRC(I)
+151 SET FBSTR=FBSTR_"~"
+152 DO STORE^FBAAV01
+153 ;
+154 ; build 4th line
+155 SET FBSTR=""
+156 IF FB4LN
Begin DoDot:1
+157 FOR I=11:1:25
SET FBSTR=FBSTR_FBDX(I)
+158 FOR I=11:1:25
SET FBSTR=FBSTR_FBPRC(I)
End DoDot:1
+159 SET FBSTR=FBSTR_"~"
+160 DO STORE^FBAAV01
+161 ;
+162 ; build 5th line FB*3.5*158
+163 SET FBSTR=FBFPPSID
+164 ;Authorization Number
SET FBSTR=FBSTR_FBAUTHNUM
+165 ;Claim Level Allowed Amount
SET FBSTR=FBSTR_FBCLAMT
+166 SET FBADJG=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U),1:"")
SET FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
+167 SET FBRRC1=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,4),1:"")
SET FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
+168 SET FBRRC2=$SELECT($DATA(FBCRARC(1)):$PIECE(FBCRARC(1),U,5),1:"")
SET FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
+169 SET FBSTR=FBSTR_FBADJG_FBRRC1_FBRRC2
+170 ;
+171 FOR FBI=2:1:5
Begin DoDot:1
+172 SET FBADJG=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U),1:"")
SET FBADJG=$$RJ^XLFSTR(FBADJG,2," ")
+173 SET FBADJR=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,2),1:"")
SET FBADJR=$$RJ^XLFSTR(FBADJR,5," ")
+174 SET FBRRC1=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,4),1:"")
SET FBRRC1=$$RJ^XLFSTR(FBRRC1,6," ")
+175 SET FBRRC2=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,5),1:"")
SET FBRRC2=$$RJ^XLFSTR(FBRRC2,6," ")
+176 SET FBADJA=$SELECT($DATA(FBCRARC(FBI)):$PIECE(FBCRARC(FBI),U,3),1:0)
SET FBADJA=$$AUSAMT^FBAAV3(FBADJA,10,1)
+177 SET FBSTR=FBSTR_FBADJG_FBADJR_FBRRC1_FBRRC2_FBADJA
End DoDot:1
+178 ;
+179 SET FBSTR=FBSTR_FBDRGWT_FBBILAMT_FBPYMTH
+180 ;Additional Payment Indicator
SET FBSTR=FBSTR_" "
+181 ;Additional Payment Type
SET FBSTR=FBSTR_" "
+182 ;Parent Internal Control Number
SET FBSTR=FBSTR_$$PADZ^FBAAV01(0,30)
+183 SET FBSTR=FBSTR_"~$"
+184 DO STORE^FBAAV01
+185 QUIT
+186 ;
AUTHIP(IENS) ;
+1 ;
+2 NEW REFNUM
+3 SET REFNUM=""
+4 DO GETS^DIQ(162.5,IENS,"4","I","FB")
+5 IF $DATA(FB)
IF FB(162.5,IENS,4,"I")["FB7078"
Begin DoDot:1
+6 SET FB7078=$PIECE(FB(162.5,IENS,4,"I"),";")
+7 if $DATA(^FB7078(FB7078,0))
SET REFNUM=$PIECE(^FB7078(FB7078,0),U)
End DoDot:1
+8 QUIT REFNUM
+9 ;
PSA(X,Y) ;call to set default Primary Service Area (PSA)
+1 ;to send to Austin.
+2 ;X = pointer to the institution file
+3 ;Y = default if unable to determine station number in file 4
+4 ;call returns the 3 digit station number only
+5 ;if Y undef return '0'
+6 IF '$GET(Y)
SET Y=0
+7 QUIT $SELECT('X:+Y,$EXTRACT($PIECE($GET(^DIC(4,+X,99)),U),1,3)'?3N:+Y,1:$EXTRACT($PIECE($GET(^(99)),U),1,3))
+8 ;
B9ADMIT(FBIENS) ; Determine Admission Date for a B9 payment
+1 ; input
+2 ; FBIENS
+3 ; returns admission date in internal FileMan format or null value
+4 NEW FB7078,FBRET
+5 ;NULL
SET FBRET=""
+6 ;
+7 ; associated 7078/583
SET FB7078=$$GET1^DIQ(162.5,FBIENS,4,"I")
+8 ;
+9 ; if invoice points to a 7078 authorization then get date from the 7078
+10 IF $PIECE(FB7078,";",2)="FB7078("
Begin DoDot:1
+11 NEW FBY
+12 SET FBY=$GET(^FB7078(+FB7078,0))
+13 ; if fee program is civil hospital then return 7078 date of admission
+14 IF $PIECE(FBY,U,11)=6
SET FBRET=$PIECE(FBY,U,15)
+15 ; if fee program is CNH then return 7078 authorized from date
+16 IF $PIECE(FBY,U,11)=7
SET FBRET=$PIECE(FBY,U,4)
End DoDot:1
+17 ;
+18 ; if invoice points to an unauthorized claim then use the treatment from
+19 ; date on the unauthorized claim
+20 IF $PIECE(FB7078,";",2)="FB583("
Begin DoDot:1
+21 NEW FBY
+22 SET FBY=$GET(^FB583(+FB7078,0))
+23 SET FBRET=$PIECE(FBY,U,5)
End DoDot:1
+24 ;
+25 ; return the result
+26 QUIT FBRET
+27 ;
B9DISCHG(FBIENS) ; Determine Discharge Date and Type for a B9 payment
+1 ; input
+2 ; FBIENS - Invoice IEN (file 162.5) with trailing comma
+3 ; returns discharge date in internal FileMan format or null value and
+4 ; discharge type or null value
+5 NEW FB7078,FBDISDT,FBDISTY
+6 SET (FBDISDT,FBDISTY)=""
+7 ;
+8 ; associated 7078/583
SET FB7078=$$GET1^DIQ(162.5,FBIENS,4,"I")
+9 ;
+10 ; if invoice points to an unauthorized claim then use the treatment to
+11 ; date on the unauthorized claim
+12 IF $PIECE(FB7078,";",2)="FB583("
Begin DoDot:1
+13 NEW FBY
+14 SET FBY=$GET(^FB583(+FB7078,0))
+15 SET FBDISDT=$PIECE(FBY,U,6)
+16 ; discharge type
SET FBDISTY=$$GET1^DIQ(162.5,FBIENS,"6.5:1")
End DoDot:1
+17 ;
+18 ; if invoice points to a 7078 authorization then get date from the 7078
+19 IF $PIECE(FB7078,";",2)="FB7078("
Begin DoDot:1
+20 NEW FBY
+21 SET FBY=$GET(^FB7078(+FB7078,0))
+22 ;
+23 ; if fee program is civil hospital then return 7078 date of discharge
+24 IF $PIECE(FBY,U,11)=6
Begin DoDot:2
+25 ; discharge date
SET FBDISDT=$PIECE(FBY,U,16)
+26 ; discharge type
SET FBDISTY=$$GET1^DIQ(162.5,FBIENS,"6.5:1")
End DoDot:2
+27 ;
+28 ; if fee program is CNH then get date & type from CNH activity file
+29 IF $PIECE(FBY,U,11)=7
Begin DoDot:2
+30 NEW DFN,FBADMIT,FBADMITR,FBACTA,FBAUTHP,FBDA,FBDTR
+31 ; patient IEN
SET DFN=$PIECE(FBY,U,3)
+32 ; CNH admission date
SET FBADMIT=$PIECE($PIECE(FBY,U,4),".")
+33 ; authorization 'pointer'
SET FBAUTHP=+$ORDER(^FBAAA("AG",FB7078,DFN,0))
+34 ;
+35 ; find the admission entry in CNH ACTIVITY file
+36 ; init the admission activity ien
SET FBACTA=0
+37 ; reverse admission date
SET FBADMITR=9999999-FBADMIT
+38 ; start loop
SET FBDTR=9999999-$$FMADD^XLFDT(FBADMIT,1)
+39 FOR
SET FBDTR=$ORDER(^FBAACNH("AF",DFN,FBDTR))
if 'FBDTR!($PIECE(FBDTR,".")>FBADMITR)
QUIT
Begin DoDot:3
+40 SET FBDA=0
FOR
SET FBDA=$ORDER(^FBAACNH("AF",DFN,FBDTR,FBDA))
if 'FBDA
QUIT
Begin DoDot:4
+41 SET FBY=$GET(^FBAACNH(FBDA,0))
+42 ; found it
IF $PIECE(FBY,U,3)="A"
IF $PIECE(FBY,U,10)=FBAUTHP
SET FBACTA=FBDA
End DoDot:4
End DoDot:3
if FBACTA
QUIT
+43 ; could not find the admission activity
if 'FBACTA
QUIT
+44 ;
+45 ; get date from associated discharge (if any) in CNH ACTIVITY file
+46 SET FBDA=" "
+47 FOR
SET FBDA=$ORDER(^FBAACNH("AC",FBACTA,FBDA),-1)
if FBDA'>0
QUIT
Begin DoDot:3
+48 SET FBY=$GET(^FBAACNH(FBDA,0))
+49 IF $PIECE(FBY,U,3)="D"
Begin DoDot:4
+50 SET FBDISDT=$PIECE($PIECE(FBY,U),".")
+51 SET FBDISTY=$PIECE(FBY,U,8)
+52 IF FBDISTY'=""
SET FBDISTY=FBDISTY+100
End DoDot:4
End DoDot:3
if FBDISDT
QUIT
End DoDot:2
End DoDot:1
+53 ;
+54 ; return the result
+55 QUIT FBDISDT_"^"_FBDISTY
+56 ;
DX(FBDX,FBDATE,FBPOA) ; format diagnosis & POA for B9
+1 ; Input
+2 ; FBDX = pointer to file 80 (ICD diagnosis)
+3 ; FBDATE = fileman date
+4 ; FBPOA = (optional) poiner to file 161.94 (present on admission)
+5 ; Returns formatted string of 8 characters
+6 NEW FBRET,FBX,FBX2
+7 SET FBRET=" "
+8 IF FBDX
Begin DoDot:1
+9 SET FBX=$$ICD9^FBCSV1(FBDX,FBDATE)
+10 if FBX=""
QUIT
+11 ;DEM;139 ICD-10 Project - decimal is stripped only from ICD-10 diagnosis codes and not ICD-9 diagnosis codes.
+12 ;DEM;139 ICD-10 Project
IF $$CODEABA^ICDEX(FBX,80,30)>0
if FBX["."
SET FBX=$PIECE(FBX,".",1)_$PIECE(FBX,".",2)
+13 SET FBX=FBX_$EXTRACT(" ",$LENGTH(FBX)+1,7)
+14 SET FBX2=$SELECT($GET(FBPOA):$PIECE($GET(^FB(161.94,FBPOA,0)),"^"),1:"")
+15 if FBX2=""
SET FBX2=" "
+16 SET FBRET=FBX_FBX2
End DoDot:1
+17 QUIT FBRET
+18 ;
PROC(FBPROC,FBDATE) ; format procedure for B9
+1 ; Input
+2 ; FBPROC = pointer to file 80.1 (ICD operation/procedure)
+3 ; FBDATE = fileman date
+4 ; Returns formatted string of 7 characters
+5 NEW FBRET,FBX
+6 SET FBRET=" "
+7 IF FBPROC
Begin DoDot:1
+8 SET FBX=$$ICD0^FBCSV1(FBPROC,FBDATE)
+9 if FBX=""
QUIT
+10 SET FBX=FBX_$EXTRACT(" ",$LENGTH(FBX)+1,7)
+11 SET FBRET=FBX
End DoDot:1
+12 QUIT FBRET
+13 ;
CRARC(FBIENS,FBCRARC) ; load CARCs and RARCs
+1 ;
+2 NEW FBADJ,FBRRMK
+3 DO LOADADJ^FBCHFA(FBIENS,.FBADJ)
+4 DO LOADRR^FBCHFR(FBIENS,.FBRRMK)
+5 DO CRARC^FBAAUTL(.FBADJ,.FBRRMK,.FBCRARC)
+6 QUIT
+7 ;FBAAV5
