FBPAY67 ;AISC/DMK,TET,BPOIFO/MEC - CH/CNH PAYMENT HISTORY SORT ;9/13/12 10:29am
;;3.5;FEE BASIS;**4,32,55,69,108,143,139**;JAN 30, 1995;Build 127
;;Per VA Directive 6402, this routine should not be modified.
EN ;entry to sort
I FBSORT S DFN=FBIEN,FBPID=FBID,FBPNAME=FBNAME
I 'FBSORT S FBVI=FBIEN,FBVID=FBID,FBVNAME=$E(FBNAME,1,23)
FBAAC ;check ^fbaac("an" (file 162)
S FBOUT=0 I $D(^FBAAC("AN",FBPI)) D AN I $G(FBPIFLG) S FBPI=7 D AN S FBPI=6
S I=FBBEG,FBIX=$S(FBSORT:"AG",1:"AF")
SORT ;sort programs 6 & 7 (civil hos & cnh)
F FBM=FBBEG-.1:0 S FBM=$O(^FBAAI(FBIX,FBIEN,FBM)) Q:FBM'>0!(FBM>FBEND) F FBI=0:0 S FBI=$O(^FBAAI(FBIX,FBIEN,FBM,FBI)) Q:FBI'>0 I $G(^FBAAI(FBI,"FBREJ"))']"" D SET S FBPI=FBPISV
KILL ;kill variables set in routine and in FBPAY2, sort/set sections
K A1,A2,A3,D,D2,FBAACPTC,FBBN,FBCNT,FBCP,FBDT,FBDT1,FBDX,FBDX1,FBI,FBIN,FBIX,FBM,FBOB,FBPDX,FBPISV,FBPROC,FBPROC1,FBSC,FBTA,FBVEN,FBVENID,FBVP,I,J,K,L,M,Y,FBDT2,FBPROA,FBPOA,FBADMTDX
K:FBSORT FBVNAME,FBVID K:'FBSORT FBPNAME,FBPID
D KILL^FBPAY2
Q
SET ;set string, also called by fbchdi (fblistc or fbaanq set if called by fbchdi)
N FBY2,FBY3,FBY5,FBCDAYS,FBCSID,FBFPPSC,FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,FBAARCE,FBX,FBADMTDX,P2,FBPOA
S FBPISV=$G(FBPI),FBIN=$G(^FBAAI(FBI,0)) Q:FBIN']"" S FBPI=+$P(FBIN,U,12)
I 'FBPROG,'$D(FBPROG(+$P(FBIN,U,12))) Q
I '$D(FBPIFLG) Q:+$P(FBIN,U,12)'=FBPI
I $D(FBPIFLG),'FBPROG Q:'$D(FBPROG(+$P(FBIN,U,12)))
S FBY2=$G(^FBAAI(FBI,2))
S FBY3=$G(^FBAAI(FBI,3))
S FBY5=$G(^FBAAI(FBI,5))
; if user wants just mill bill or just non-mill bill then check payment
; and skip if associated with an mill bill claim
I "^M^N^"[(U_$G(FB1725R)_U) S FB1725=$S($P(FBIN,U,5)["FB583":+$P($G(^FB583(+$P(FBIN,U,5),0)),U,28),1:0) I $S(FB1725R="M"&'FB1725:1,FB1725R="N"&FB1725:1,1:0) Q
F J=1,2,3,6,7,8,9,10,11,13,14 S FBIN(J)=$P(FBIN,"^",J)
S:FBSORT FBIN(5)=$P(FBIN,U,5) I 'FBSORT S FBIN(4)=$P(FBIN,U,4),DFN=FBIN(4) Q:DFN']"" S FBPID=$$SSN^FBAAUTL(DFN),FBPNAME=$P($G(^DPT(+DFN,0)),U)
I FBSORT S FBVNAME=$G(^FBAAV(FBIN(3),0)) Q:FBVNAME']"" S FBVID=$P(FBVNAME,U,2),FBVNAME=$E($P(FBVNAME,U),1,23)
S FBIN(2)=$$DATX^FBAAUTL(FBIN(2)),FBVEN=FBVNAME_";"_FBVID,FBPAT=FBPNAME_";"_DFN
S FBIN(6)=$$DATX^FBAAUTL(FBIN(6)),FBIN(7)=$$DATX^FBAAUTL(FBIN(7))
D FBCKI^FBAACCB1(FBI)
SETTMP S ^TMP($J,"FB",+$P(FBIN,U,12),FBVEN,FBPAT,FBM,FBI)=FBIN(2)_U_$J(FBIN(8),8,2)_U_$J(FBIN(9),8,2)_U_FBIN(11)_U_$J(FBIN(1),8)_U_FBIN(6)_U_FBIN(7)_U_FBIN(13)_U_FBIN(14)_U_FBIN(10)
S ^TMP($J,"FB",+$P(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"FBCK")="^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT
S FBCDAYS=$P(FBY2,U,10) ; covered days
S FBCSID=$P(FBY2,U,11) ; patient control number
S FBFPPSC=$P(FBY3,U) ; fpps claim id
S FBFPPSL=$P(FBY3,U,2) ; fpps line item
S FBX=$$ADJLRA^FBCHFA(FBI_",")
S FBADJLR=$P(FBX,U) ;adjustment reason
S FBADJLA=$P(FBX,U,2) ;adjustment amount
S FBRRMKL=$$RRL^FBCHFR(FBI_",") ;remittance remarks
; FB*3.5*139-ICD10 REMEDIATION-JLG
N FBISYS S FBISYS=10 S:$P($G(FBIN),U,6)<$$IMPDATE^FBCSV1("10D") FBISYS=9
S:FBISYS=9 FBADMTDX=$$ICD9^FBCSV1($P(FBY5,"^",9)) ; admitting diagnosis (icd-9)
S:FBISYS=10 FBADMTDX=$$CODEC^ICDCODE($P(FBY5,"^",9),80) ; admitting diagnosis (icd-10)
I $P(FBADMTDX,"^")=-1 S FBADMTDX=""
; End 139
S ^TMP($J,"FB",+$P(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"FBINV")=FBCDAYS_"^"_FBCSID_"^"_FBFPPSC_"^"_FBFPPSL_"^"_FBADJLR_"^"_FBADJLA_"^"_FBRRMKL_"^"_FBADMTDX
S FBDX=$G(^FBAAI(FBI,"DX"))
S FBPOA=$G(^FBAAI(FBI,"POA"))
;determine which ICD version to use (9 or 10) based on date of service
I FBDX]"" S FBDX1="" F I=1:1:25 D
.N FBPOA1
.Q:$P(FBDX,U,I)=""
.S FBPOA1=$P(FBPOA,U,I)
.; FB*3.5*139-ICD10 REMEDIATION-JLG
.S:FBISYS=10 FBDX1=FBDX1_$$CODEC^ICDCODE($P(FBDX,U,I),80)_"/"
.S:FBISYS=9 FBDX1=FBDX1_$$ICD9^FBCSV1($P(FBDX,U,I),+$P($G(FBIN),U,6))_"/"
.; End 139
.S FBDX1=FBDX1_$S(FBPOA1:$P($G(^FB(161.94,FBPOA1,0)),"^"),1:"")_U
.Q
I FBDX]"" S FBDX1=$P(FBDX1,U,1,($L(FBDX1,U)-1)),^TMP($J,"FB",$P(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"DX")=FBDX1
S FBPROC=$G(^FBAAI(FBI,"PROC")) I FBPROC]"" S FBPROC1="" F I=1:1:25 S:$P(FBPROC,U,I) FBPROC1=FBPROC1_$$ICD0^FBCSV1($P(FBPROC,U,I),+$P($G(FBIN),U,6))_U
I FBPROC]"" S FBPROC1=$P(FBPROC1,U,1,($L(FBPROC1,U)-1)),^TMP($J,"FB",$P(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"PROC")=FBPROC1
D ANC(FBM,FBI):FBSORT&($D(^TMP($J,"FB",FBPI,FBVEN,FBPAT,FBM,FBI)))
Q
AN ;get data from an xref - called at tag fbaac in pay3 & pay67
I FBSORT G AN1
S FBVEN=FBVNAME_";"_FBVID,DFN=0 F S DFN=$O(^FBAAC("AN",FBPI,DFN)) Q:'DFN S FBPAT=$G(^DPT(DFN,0)),FBPNAME=$P(FBPAT,U),FBPID=$$SSN^FBAAUTL(DFN),FBPAT=FBPNAME_";"_DFN D OTH
Q
AN1 S FBPAT=FBPNAME_";"_FBPID,FBVI=0 F S FBVI=$O(^FBAAC("AN",FBPI,DFN,FBVI)) Q:'FBVI S FBVNAME=$E($$VNAME^FBNHEXP(FBVI),1,23),FBVID=$$VID^FBNHEXP(FBVI),FBVEN=FBVNAME_";"_FBVID D OTH
Q
OTH ;other fee programs - if 'fbsort (by vendor)
Q:'$O(^FBAAC("AN",FBPI,DFN,FBVI,0))
N J,K,L,M,Y,FBDT1 S J=DFN,K=FBVI
S L=0 F S L=$O(^FBAAC("AN",FBPI,J,K,L)) Q:'L S FBDT1=$P($G(^FBAAC(J,1,K,1,L,0)),U) I FBDT1]""&(FBDT1'<FBBDATE&(FBDT1'>FBEDATE)) D S:FBOUT FBOUT=0
.S M=0 F S M=$O(^FBAAC("AN",FBPI,J,K,L,M)) Q:'M S Y=$G(^FBAAC(J,1,K,1,L,1,M,0)) I Y]"" D
..S FBOUT=0 D EN1^FBPAY2 Q:FBOUT D EN^FBPAY21
..S ^TMP($J,"FB",FBPI_"O",FBVEN,FBPAT,(9999999.9999-FBDT1),L,M)=$G(FBR)_$$DATX^FBAAUTL(FBDT1)_U_FBAACPTC_FBCP_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_T_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_$G(FBVP)
..S ^TMP($J,"FB",FBPI_"O",FBVEN,FBPAT,(9999999.9999-FBDT1),L,M,"FBCK")="^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT
..S ^TMP($J,"FB",FBPI_"O",FBVEN,FBPAT,(9999999.9999-FBDT1),L,M,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID_U_FBFPPSC_U_FBFPPSL_U_FBAARCE
Q
ANC(FBM,FBI) ;ancillary payments - if fbsort (by patient)
N J,K,L,M,Y,FBDT1,FBVID
N FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ,FBFPPSC,FBFPPSL,FBAARCE
S J=FBIEN,FBCNT=0 I J,+FBIN(5),$D(^FBAAC("AM",FBIN(5),J)) D
.F K=0:0 S K=$O(^FBAAC("AM",FBIN(5),J,K)) Q:'K S L=0 F S L=$O(^FBAAC("AM",FBIN(5),J,K,L)) Q:'L D
..N FBOUT
..S FBDT1=$P($G(^FBAAC(J,1,K,1,L,0)),U) I FBDT1]"" S FBDT2=(9999999.9999-FBDT1),FBDT1=$$DATX^FBAAUTL(FBDT1)
..S M=0 F S M=$O(^FBAAC("AM",FBIN(5),J,K,L,M)) Q:'M S Y=$G(^FBAAC(J,1,K,1,L,1,M,0)) I Y]"" D
...D EN1^FBPAY2 Q:'$D(FBAACPTC)!($G(FBOUT)) S FBCNT=FBCNT+1 D EN^FBPAY21
...S ^TMP($J,"FB",FBPI,FBVEN,FBPAT,"A",K,L,M)=$G(FBR)_FBDT1_U_FBAACPTC_FBCP_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_T_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_FBVNAME_U_FBVID
...S ^TMP($J,"FB",FBPI,FBVEN,FBPAT,"A",K,L,M,"FBCK")="^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT
...S ^TMP($J,"FB",FBPI,FBVEN,FBPAT,"A",K,L,M,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID_U_FBFPPSC_U_FBFPPSL_U_FBAARCE
...I $D(^TMP($J,"FB",FBPI_"O",FBVNAME_";"_FBVID,$P(FBPAT,";")_";"_$$SSN^FBAAUTL($P(FBPAT,";",2)),FBDT2)) K ^TMP($J,"FB",FBPI_"O",FBVNAME_";"_FBVID,$P(FBPAT,";")_";"_$$SSN^FBAAUTL($P(FBPAT,";",2)),FBDT2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPAY67 7087 printed Apr 09, 2024@21:04:06 Page 2
FBPAY67 ;AISC/DMK,TET,BPOIFO/MEC - CH/CNH PAYMENT HISTORY SORT ;9/13/12 10:29am
+1 ;;3.5;FEE BASIS;**4,32,55,69,108,143,139**;JAN 30, 1995;Build 127
+2 ;;Per VA Directive 6402, this routine should not be modified.
EN ;entry to sort
+1 IF FBSORT
SET DFN=FBIEN
SET FBPID=FBID
SET FBPNAME=FBNAME
+2 IF 'FBSORT
SET FBVI=FBIEN
SET FBVID=FBID
SET FBVNAME=$EXTRACT(FBNAME,1,23)
FBAAC ;check ^fbaac("an" (file 162)
+1 SET FBOUT=0
IF $DATA(^FBAAC("AN",FBPI))
DO AN
IF $GET(FBPIFLG)
SET FBPI=7
DO AN
SET FBPI=6
+2 SET I=FBBEG
SET FBIX=$SELECT(FBSORT:"AG",1:"AF")
SORT ;sort programs 6 & 7 (civil hos & cnh)
+1 FOR FBM=FBBEG-.1:0
SET FBM=$ORDER(^FBAAI(FBIX,FBIEN,FBM))
if FBM'>0!(FBM>FBEND)
QUIT
FOR FBI=0:0
SET FBI=$ORDER(^FBAAI(FBIX,FBIEN,FBM,FBI))
if FBI'>0
QUIT
IF $GET(^FBAAI(FBI,"FBREJ"))']""
DO SET
SET FBPI=FBPISV
KILL ;kill variables set in routine and in FBPAY2, sort/set sections
+1 KILL A1,A2,A3,D,D2,FBAACPTC,FBBN,FBCNT,FBCP,FBDT,FBDT1,FBDX,FBDX1,FBI,FBIN,FBIX,FBM,FBOB,FBPDX,FBPISV,FBPROC,FBPROC1,FBSC,FBTA,FBVEN,FBVENID,FBVP,I,J,K,L,M,Y,FBDT2,FBPROA,FBPOA,FBADMTDX
+2 if FBSORT
KILL FBVNAME,FBVID
if 'FBSORT
KILL FBPNAME,FBPID
+3 DO KILL^FBPAY2
+4 QUIT
SET ;set string, also called by fbchdi (fblistc or fbaanq set if called by fbchdi)
+1 NEW FBY2,FBY3,FBY5,FBCDAYS,FBCSID,FBFPPSC,FBFPPSL,FBX,FBADJLR,FBADJLA,FBRRMKL,FBAARCE,FBX,FBADMTDX,P2,FBPOA
+2 SET FBPISV=$GET(FBPI)
SET FBIN=$GET(^FBAAI(FBI,0))
if FBIN']""
QUIT
SET FBPI=+$PIECE(FBIN,U,12)
+3 IF 'FBPROG
IF '$DATA(FBPROG(+$PIECE(FBIN,U,12)))
QUIT
+4 IF '$DATA(FBPIFLG)
if +$PIECE(FBIN,U,12)'=FBPI
QUIT
+5 IF $DATA(FBPIFLG)
IF 'FBPROG
if '$DATA(FBPROG(+$PIECE(FBIN,U,12)))
QUIT
+6 SET FBY2=$GET(^FBAAI(FBI,2))
+7 SET FBY3=$GET(^FBAAI(FBI,3))
+8 SET FBY5=$GET(^FBAAI(FBI,5))
+9 ; if user wants just mill bill or just non-mill bill then check payment
+10 ; and skip if associated with an mill bill claim
+11 IF "^M^N^"[(U_$GET(FB1725R)_U)
SET FB1725=$SELECT($PIECE(FBIN,U,5)["FB583":+$PIECE($GET(^FB583(+$PIECE(FBIN,U,5),0)),U,28),1:0)
IF $SELECT(FB1725R="M"&'FB1725:1,FB1725R="N"&FB1725:1,1:0)
QUIT
+12 FOR J=1,2,3,6,7,8,9,10,11,13,14
SET FBIN(J)=$PIECE(FBIN,"^",J)
+13 if FBSORT
SET FBIN(5)=$PIECE(FBIN,U,5)
IF 'FBSORT
SET FBIN(4)=$PIECE(FBIN,U,4)
SET DFN=FBIN(4)
if DFN']""
QUIT
SET FBPID=$$SSN^FBAAUTL(DFN)
SET FBPNAME=$PIECE($GET(^DPT(+DFN,0)),U)
+14 IF FBSORT
SET FBVNAME=$GET(^FBAAV(FBIN(3),0))
if FBVNAME']""
QUIT
SET FBVID=$PIECE(FBVNAME,U,2)
SET FBVNAME=$EXTRACT($PIECE(FBVNAME,U),1,23)
+15 SET FBIN(2)=$$DATX^FBAAUTL(FBIN(2))
SET FBVEN=FBVNAME_";"_FBVID
SET FBPAT=FBPNAME_";"_DFN
+16 SET FBIN(6)=$$DATX^FBAAUTL(FBIN(6))
SET FBIN(7)=$$DATX^FBAAUTL(FBIN(7))
+17 DO FBCKI^FBAACCB1(FBI)
SETTMP SET ^TMP($JOB,"FB",+$PIECE(FBIN,U,12),FBVEN,FBPAT,FBM,FBI)=FBIN(2)_U_$JUSTIFY(FBIN(8),8,2)_U_$JUSTIFY(FBIN(9),8,2)_U_FBIN(11)_U_$JUSTIFY(FBIN(1),8)_U_FBIN(6)_U_FBIN(7)_U_FBIN(13)_U_FBIN(14)_U_FBIN(10)
+1 SET ^TMP($JOB,"FB",+$PIECE(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"FBCK")="^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT
+2 ; covered days
SET FBCDAYS=$PIECE(FBY2,U,10)
+3 ; patient control number
SET FBCSID=$PIECE(FBY2,U,11)
+4 ; fpps claim id
SET FBFPPSC=$PIECE(FBY3,U)
+5 ; fpps line item
SET FBFPPSL=$PIECE(FBY3,U,2)
+6 SET FBX=$$ADJLRA^FBCHFA(FBI_",")
+7 ;adjustment reason
SET FBADJLR=$PIECE(FBX,U)
+8 ;adjustment amount
SET FBADJLA=$PIECE(FBX,U,2)
+9 ;remittance remarks
SET FBRRMKL=$$RRL^FBCHFR(FBI_",")
+10 ; FB*3.5*139-ICD10 REMEDIATION-JLG
+11 NEW FBISYS
SET FBISYS=10
if $PIECE($GET(FBIN),U,6)<$$IMPDATE^FBCSV1("10D")
SET FBISYS=9
+12 ; admitting diagnosis (icd-9)
if FBISYS=9
SET FBADMTDX=$$ICD9^FBCSV1($PIECE(FBY5,"^",9))
+13 ; admitting diagnosis (icd-10)
if FBISYS=10
SET FBADMTDX=$$CODEC^ICDCODE($PIECE(FBY5,"^",9),80)
+14 IF $PIECE(FBADMTDX,"^")=-1
SET FBADMTDX=""
+15 ; End 139
+16 SET ^TMP($JOB,"FB",+$PIECE(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"FBINV")=FBCDAYS_"^"_FBCSID_"^"_FBFPPSC_"^"_FBFPPSL_"^"_FBADJLR_"^"_FBADJLA_"^"_FBRRMKL_"^"_FBADMTDX
+17 SET FBDX=$GET(^FBAAI(FBI,"DX"))
+18 SET FBPOA=$GET(^FBAAI(FBI,"POA"))
+19 ;determine which ICD version to use (9 or 10) based on date of service
+20 IF FBDX]""
SET FBDX1=""
FOR I=1:1:25
Begin DoDot:1
+21 NEW FBPOA1
+22 if $PIECE(FBDX,U,I)=""
QUIT
+23 SET FBPOA1=$PIECE(FBPOA,U,I)
+24 ; FB*3.5*139-ICD10 REMEDIATION-JLG
+25 if FBISYS=10
SET FBDX1=FBDX1_$$CODEC^ICDCODE($PIECE(FBDX,U,I),80)_"/"
+26 if FBISYS=9
SET FBDX1=FBDX1_$$ICD9^FBCSV1($PIECE(FBDX,U,I),+$PIECE($GET(FBIN),U,6))_"/"
+27 ; End 139
+28 SET FBDX1=FBDX1_$SELECT(FBPOA1:$PIECE($GET(^FB(161.94,FBPOA1,0)),"^"),1:"")_U
+29 QUIT
End DoDot:1
+30 IF FBDX]""
SET FBDX1=$PIECE(FBDX1,U,1,($LENGTH(FBDX1,U)-1))
SET ^TMP($JOB,"FB",$PIECE(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"DX")=FBDX1
+31 SET FBPROC=$GET(^FBAAI(FBI,"PROC"))
IF FBPROC]""
SET FBPROC1=""
FOR I=1:1:25
if $PIECE(FBPROC,U,I)
SET FBPROC1=FBPROC1_$$ICD0^FBCSV1($PIECE(FBPROC,U,I),+$PIECE($GET(FBIN),U,6))_U
+32 IF FBPROC]""
SET FBPROC1=$PIECE(FBPROC1,U,1,($LENGTH(FBPROC1,U)-1))
SET ^TMP($JOB,"FB",$PIECE(FBIN,U,12),FBVEN,FBPAT,FBM,FBI,"PROC")=FBPROC1
+33 if FBSORT&($DATA(^TMP($JOB,"FB",FBPI,FBVEN,FBPAT,FBM,FBI)))
DO ANC(FBM,FBI)
+34 QUIT
AN ;get data from an xref - called at tag fbaac in pay3 & pay67
+1 IF FBSORT
GOTO AN1
+2 SET FBVEN=FBVNAME_";"_FBVID
SET DFN=0
FOR
SET DFN=$ORDER(^FBAAC("AN",FBPI,DFN))
if 'DFN
QUIT
SET FBPAT=$GET(^DPT(DFN,0))
SET FBPNAME=$PIECE(FBPAT,U)
SET FBPID=$$SSN^FBAAUTL(DFN)
SET FBPAT=FBPNAME_";"_DFN
DO OTH
+3 QUIT
AN1 SET FBPAT=FBPNAME_";"_FBPID
SET FBVI=0
FOR
SET FBVI=$ORDER(^FBAAC("AN",FBPI,DFN,FBVI))
if 'FBVI
QUIT
SET FBVNAME=$EXTRACT($$VNAME^FBNHEXP(FBVI),1,23)
SET FBVID=$$VID^FBNHEXP(FBVI)
SET FBVEN=FBVNAME_";"_FBVID
DO OTH
+1 QUIT
OTH ;other fee programs - if 'fbsort (by vendor)
+1 if '$ORDER(^FBAAC("AN",FBPI,DFN,FBVI,0))
QUIT
+2 NEW J,K,L,M,Y,FBDT1
SET J=DFN
SET K=FBVI
+3 SET L=0
FOR
SET L=$ORDER(^FBAAC("AN",FBPI,J,K,L))
if 'L
QUIT
SET FBDT1=$PIECE($GET(^FBAAC(J,1,K,1,L,0)),U)
IF FBDT1]""&(FBDT1'<FBBDATE&(FBDT1'>FBEDATE))
Begin DoDot:1
+4 SET M=0
FOR
SET M=$ORDER(^FBAAC("AN",FBPI,J,K,L,M))
if 'M
QUIT
SET Y=$GET(^FBAAC(J,1,K,1,L,1,M,0))
IF Y]""
Begin DoDot:2
+5 SET FBOUT=0
DO EN1^FBPAY2
if FBOUT
QUIT
DO EN^FBPAY21
+6 SET ^TMP($JOB,"FB",FBPI_"O",FBVEN,FBPAT,(9999999.9999-FBDT1),L,M)=$GET(FBR)_$$DATX^FBAAUTL(FBDT1)_U_FBAACPTC_FBCP_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_T_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_$GET(F
BVP)
+7 SET ^TMP($JOB,"FB",FBPI_"O",FBVEN,FBPAT,(9999999.9999-FBDT1),L,M,"FBCK")="^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT
+8 SET ^TMP($JOB,"FB",FBPI_"O",FBVEN,FBPAT,(9999999.9999-FBDT1),L,M,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID_U_FBFPPSC_U_FBFPPSL_U_FBAARCE
End DoDot:2
End DoDot:1
if FBOUT
SET FBOUT=0
+9 QUIT
ANC(FBM,FBI) ;ancillary payments - if fbsort (by patient)
+1 NEW J,K,L,M,Y,FBDT1,FBVID
+2 NEW FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ,FBFPPSC,FBFPPSL,FBAARCE
+3 SET J=FBIEN
SET FBCNT=0
IF J
IF +FBIN(5)
IF $DATA(^FBAAC("AM",FBIN(5),J))
Begin DoDot:1
+4 FOR K=0:0
SET K=$ORDER(^FBAAC("AM",FBIN(5),J,K))
if 'K
QUIT
SET L=0
FOR
SET L=$ORDER(^FBAAC("AM",FBIN(5),J,K,L))
if 'L
QUIT
Begin DoDot:2
+5 NEW FBOUT
+6 SET FBDT1=$PIECE($GET(^FBAAC(J,1,K,1,L,0)),U)
IF FBDT1]""
SET FBDT2=(9999999.9999-FBDT1)
SET FBDT1=$$DATX^FBAAUTL(FBDT1)
+7 SET M=0
FOR
SET M=$ORDER(^FBAAC("AM",FBIN(5),J,K,L,M))
if 'M
QUIT
SET Y=$GET(^FBAAC(J,1,K,1,L,1,M,0))
IF Y]""
Begin DoDot:3
+8 DO EN1^FBPAY2
if '$DATA(FBAACPTC)!($GET(FBOUT))
QUIT
SET FBCNT=FBCNT+1
DO EN^FBPAY21
+9 SET ^TMP($JOB,"FB",FBPI,FBVEN,FBPAT,"A",K,L,M)=$GET(FBR)_FBDT1_U_FBAACPTC_FBCP_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_T_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_FBVNAME_U_FBVID
+10 SET ^TMP($JOB,"FB",FBPI,FBVEN,FBPAT,"A",K,L,M,"FBCK")="^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT
+11 SET ^TMP($JOB,"FB",FBPI,FBVEN,FBPAT,"A",K,L,M,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID_U_FBFPPSC_U_FBFPPSL_U_FBAARCE
+12 IF $DATA(^TMP($JOB,"FB",FBPI_"O",FBVNAME_";"_FBVID,$PIECE(FBPAT,";")_";"_$$SSN^FBAAUTL($PIECE(FBPAT,";",2)),FBDT2))
KILL ^TMP($JOB,"FB",FBPI_"O",FBVNAME_";"_FBVID,$PIECE(FBPAT,";")_";"_$$SSN^FBAAUTL($PIECE(FBPAT,";",2)),FBDT2)
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
