FBPCR67 ;AISC/DMK,TET-CH/CNH POTENTIAL COST RECOVERY SORT ;7/5/2013
;;3.5;FEE BASIS;**4,48,55,69,98,122,108,148,163**;JAN 30, 1995;Build 21
;Per VA Directive 6402, this routine should not be modified.
;
EN ;entry point for sort
S (FBCATC,FBINS,FBPSF)=0
SORT ;sort by date finalized, ien
N FBY2,FBY5,FBCDAYS,FBCSID,FBX,FBADJLR,FBADJLA,FBRRMKL
S FBM=FBBDATE-.1 F S FBM=$O(^FBAAI("AD",FBM)) Q:'FBM!(FBM>FBEDATE) S FBI=0 F S FBI=$O(^FBAAI("AD",FBM,FBI)) Q:FBI'>0 S FBIN=$G(^FBAAI(FBI,0)) I FBIN]""&($G(^FBAAI(FBI,"FBREJ"))']"") D S (FBCATC,FBINS,FBPSF)=0
.S (DFN,J)=+$P(FBIN,U,4) D VET^FBPCR
.D SET Q:FBPI'[+$P(FBIN,U,12)!('FBPSV&('$D(FBPSV(FBPSF)))) I FBCATC!FBINS D SETTMP
KILL ;kill variables set in this routine and in FPAY2, sort/set sections
K A1,A2,A3,D,D2,DFN,FBAACPTC,FBBN,FBCATC,FBCNT,FBCP,FBDOB,FBDT,FBDT1,FBDX,FBDX1,FBI,FBIN,FBINS,FBIX,FBJ,FBM,FBOB,FBPAT,FBPDX,FBPROC,FBPROC1,FBPSF,FBSC,FBTA,FBVEN,FBVENID,FBVP,I,J,K,L,M,Y,FBPOA,FBPROA,FBADMTDX
K FBVNAME,FBVID,FBPNAME,FBPID
K FBY2,FBY4,FBCDAYS,FBCSID,FBX,FBADJLR,FBADJLA,FBRRMKL ; FB*3.5*122
D KILL^FBPCR2
Q
SET ;set variables
S FBY2=$G(^FBAAI(FBI,2)),FBY4=$G(^FBAAI(FBI,4)),$P(FBY4,U,20)=$P($G(^FBAAI(FBI,5)),U,1,4) ; FB*3.5*122
S FBY5=$G(^FBAAI(FBI,5))
F FBJ=1,2,3,4,6,7,8,9,11,13,14 S FBIN(FBJ)=$P(FBIN,"^",FBJ)
Q:FBPI'[+$P(FBIN,U,12) S FBPSF=+$P(FBIN,U,20)
Q:'FBPSV&('$D(FBPSV(FBPSF)))
S ^TMP($J,"FB",FBPSF)=$G(^FBAAI(FBI,5)) ; FB*3.5*122
D
. N FBCATC2
. S FBCATC=$$CATC^FBPCR(DFN,+$P(FBIN,U,6),+$P(FBIN,U,18))
. Q:FBCATC=2
. S FBCATC2=$$CATC^FBPCR(DFN,+$P(FBIN,U,7),+$P(FBIN,U,18))
. I FBCATC2=0 Q
. I FBCATC=0!(FBCATC=1) S FBCATC=FBCATC2 Q
. S:FBCATC2=2 FBCATC=2
;,FBINS=$S($O(^FBAAA("AIC",FBIN(4),+$O(^FBAAA("AIC",FBIN(4),-FBIN(6))),0))="Y":1,1:0)
S FBINS=$S($$INSCK^FBPCR3(FBIN(6),FBIN(4),+$P(FBIN,U,12))=1:$$INSURED^FBPCR4(DFN,+$P(FBIN,U,6),+$P(FBIN,U,7)),1:0)
Q:'FBCATC&'FBINS
S FBIN(5)=$P(FBIN,U,5)
S FBIEN=FBIN(3),FBVNAME=$G(^FBAAV(FBIN(3),0)) Q:FBVNAME']"" S FBVID=$P(FBVNAME,U,2)_"/"_$S($P($G(^FBAAV(FBIEN,3)),U,2)]"":$P($G(^FBAAV(FBIEN,3)),U,2),1:"**********"),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))
Q
SETTMP ;sort data by primary service facility, patient, fee program, vendor, date
N FBBILL,FBINAU,FBSKIP ;FB*3.5*163
S FBSKIP=0,(FBBILL,FBINAU)="" ;FB*3.5*163
Q:$$FILTER^FBPCR4()=0
D CHKBILL^IBFBUTIL(FBIN) ;FB*3.5*163
I $G(FBSKIP),$G(FBNPB) Q ;Quit if running for not previously billed and bill IEN exists on File #360 FB*3.5*163
S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,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_$P(FBIN,U,12)_U_FBCATC_U_FBINS_U_FBIN(13)_U_FBIN(14)
S FBCDAYS=$P(FBY2,U,10) ; covered days
S FBCSID=$P(FBY2,U,11) ; patient control number
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
S FBADMTDX=$$ICD9^FBCSV1($P(FBY5,"^",9)) ; admitting diagnosis
S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"FBINV")=FBCDAYS_"^"_FBCSID_"^"_FBADJLR_"^"_FBADJLA_"^"_FBRRMKL_"^"_FBADMTDX
;S FBDX=$G(^FBAAI(FBI,"DX")) I FBDX]"" S FBDX1="" F I=1:1:5 S:$P(FBDX,U,I) FBDX1=FBDX1_$$ICD9^FBCSV1($P(FBDX,U,I),+$P($G(FBIN),U,6))_U
S FBDX=$G(^FBAAI(FBI,"DX"))
S FBPOA=$G(^FBAAI(FBI,"POA"))
I FBDX]"" S FBDX1="" F I=1:1:25 D
. N FBPOA1
. Q:$P(FBDX,U,I)=""
. S FBPOA1=$P(FBPOA,U,I)
. S FBDX1=FBDX1_$$ICD9^FBCSV1($P(FBDX,U,I),+$P($G(FBIN),U,6))_"/"
. 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",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,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",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"PROC")=FBPROC1
;*** removed conditional to get ancillary payments processed
;D ANC:$D(^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI))
D ANC
K FB5010
;get line item rendering provider data
I FBPROC]"" S I=0 F S I=$O(^FBAAI(FBI,"RPROV",I)) Q:'I D
. N X
. S X=$G(^FBAAI(FBI,"RPROV",I,0))
. I $P(X,U) S FB5010($P(X,U))=X
I $D(FB5010) M ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"RPROV")=FB5010 K FB5010
I $TR(FBY4,U)]"" S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"FBY4")=FBY4 ; FB*3.5*122
I FBBILL S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"FBBILL")=FBBILL ; FB*3.5*163 Bill Number
I FBINAU S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"FBINAU")=FBINAU ; FB*3.5*163 Insurance Auth
I $G(FBAUTH)'="" S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"FBAUTH")=$G(FBADX1)_U_$G(FBADX2)_U_$G(FBADX3)_U_$G(FBAICD)_U_$G(FBAREF)_U_$G(FBARNPI)_U_$G(FBAVND)_U_$G(FBAVNPI)_U_$G(FBAVTAX) ; FB*3.5*163
;I FBPROC]"" K FB5010 F I=1:1:25 S:$P(FBPROC,U,I) FB5010(I)=$G(^FBAAI(FBI,"RPROV",I,0)) ; FB*3.5*122
;I FBPROC]"" K FB5010 F I=1:1:25 S:$P(FBPROC,U,I) FB5010($P($G(^FBAAI(FBI,"RPROV",I,0)),U,1))=$G(^FBAAI(FBI,"RPROV",I,0))
;I FBPROC]"" M ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"RPROV")=FB5010 K FB5010 ; FB*3.5*122
Q
ANC ;ancillary payments
;Patch FB*3.5*148 saves off any previous values and then cleans up variable FBAACPTC
N J,K,L,M,Y,FBDT1,FBVID,FBAACPTC I FBPI=67 N FBPI S FBPI=+$P(FBIN,U,12)
S J=DFN,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
..S FBDT1=$P($G(^FBAAC(J,1,K,1,L,0)),U) I FBDT1]"" S 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
...K FBAACPTC
...D EN1^FBPCR2 Q:'$D(FBAACPTC) S FBCNT=FBCNT+1
...Q:$$FILTER^FBPCR4()=0
...S ^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI,"A",FBCNT)=FBDT1_U_FBAACPTC_FBCP_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_FBVNAME_U_FBVID_U_FBPI_U_FBCATC_U_FBINS
...S ^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI,"A",FBCNT,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPCR67 6429 printed Apr 09, 2024@21:06:32 Page 2
FBPCR67 ;AISC/DMK,TET-CH/CNH POTENTIAL COST RECOVERY SORT ;7/5/2013
+1 ;;3.5;FEE BASIS;**4,48,55,69,98,122,108,148,163**;JAN 30, 1995;Build 21
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ;entry point for sort
+1 SET (FBCATC,FBINS,FBPSF)=0
SORT ;sort by date finalized, ien
+1 NEW FBY2,FBY5,FBCDAYS,FBCSID,FBX,FBADJLR,FBADJLA,FBRRMKL
+2 SET FBM=FBBDATE-.1
FOR
SET FBM=$ORDER(^FBAAI("AD",FBM))
if 'FBM!(FBM>FBEDATE)
QUIT
SET FBI=0
FOR
SET FBI=$ORDER(^FBAAI("AD",FBM,FBI))
if FBI'>0
QUIT
SET FBIN=$GET(^FBAAI(FBI,0))
IF FBIN]""&($GET(^FBAAI(FBI,"FBREJ"))']"")
Begin DoDot:1
+3 SET (DFN,J)=+$PIECE(FBIN,U,4)
DO VET^FBPCR
+4 DO SET
if FBPI'[+$PIECE(FBIN,U,12)!('FBPSV&('$DATA(FBPSV(FBPSF))))
QUIT
IF FBCATC!FBINS
DO SETTMP
End DoDot:1
SET (FBCATC,FBINS,FBPSF)=0
KILL ;kill variables set in this routine and in FPAY2, sort/set sections
+1 KILL A1,A2,A3,D,D2,DFN,FBAACPTC,FBBN,FBCATC,FBCNT,FBCP,FBDOB,FBDT,FBDT1,FBDX,FBDX1,FBI,FBIN,FBINS,FBIX,FBJ,FBM,FBOB,FBPAT,FBPDX,FBPROC,FBPROC1,FBPSF,FBSC,FBTA,FBVEN,FBVENID,FBVP,I,J,K,L,M,Y,FBPOA,FBPROA,FBADMTDX
+2 KILL FBVNAME,FBVID,FBPNAME,FBPID
+3 ; FB*3.5*122
KILL FBY2,FBY4,FBCDAYS,FBCSID,FBX,FBADJLR,FBADJLA,FBRRMKL
+4 DO KILL^FBPCR2
+5 QUIT
SET ;set variables
+1 ; FB*3.5*122
SET FBY2=$GET(^FBAAI(FBI,2))
SET FBY4=$GET(^FBAAI(FBI,4))
SET $PIECE(FBY4,U,20)=$PIECE($GET(^FBAAI(FBI,5)),U,1,4)
+2 SET FBY5=$GET(^FBAAI(FBI,5))
+3 FOR FBJ=1,2,3,4,6,7,8,9,11,13,14
SET FBIN(FBJ)=$PIECE(FBIN,"^",FBJ)
+4 if FBPI'[+$PIECE(FBIN,U,12)
QUIT
SET FBPSF=+$PIECE(FBIN,U,20)
+5 if 'FBPSV&('$DATA(FBPSV(FBPSF)))
QUIT
+6 ; FB*3.5*122
SET ^TMP($JOB,"FB",FBPSF)=$GET(^FBAAI(FBI,5))
+7 Begin DoDot:1
+8 NEW FBCATC2
+9 SET FBCATC=$$CATC^FBPCR(DFN,+$PIECE(FBIN,U,6),+$PIECE(FBIN,U,18))
+10 if FBCATC=2
QUIT
+11 SET FBCATC2=$$CATC^FBPCR(DFN,+$PIECE(FBIN,U,7),+$PIECE(FBIN,U,18))
+12 IF FBCATC2=0
QUIT
+13 IF FBCATC=0!(FBCATC=1)
SET FBCATC=FBCATC2
QUIT
+14 if FBCATC2=2
SET FBCATC=2
End DoDot:1
+15 ;,FBINS=$S($O(^FBAAA("AIC",FBIN(4),+$O(^FBAAA("AIC",FBIN(4),-FBIN(6))),0))="Y":1,1:0)
+16 SET FBINS=$SELECT($$INSCK^FBPCR3(FBIN(6),FBIN(4),+$PIECE(FBIN,U,12))=1:$$INSURED^FBPCR4(DFN,+$PIECE(FBIN,U,6),+$PIECE(FBIN,U,7)),1:0)
+17 if 'FBCATC&'FBINS
QUIT
+18 SET FBIN(5)=$PIECE(FBIN,U,5)
+19 SET FBIEN=FBIN(3)
SET FBVNAME=$GET(^FBAAV(FBIN(3),0))
if FBVNAME']""
QUIT
SET FBVID=$PIECE(FBVNAME,U,2)_"/"_$SELECT($PIECE($GET(^FBAAV(FBIEN,3)),U,2)]"":$PIECE($GET(^FBAAV(FBIEN,3)),U,2),1:"**********")
SET FBVNAME=$EXTRACT($PIECE(FBVNAME,U),1,23)
+20 SET FBIN(2)=$$DATX^FBAAUTL(FBIN(2))
SET FBVEN=FBVNAME_";"_FBVID
SET FBPAT=FBPNAME_";"_DFN
+21 SET FBIN(6)=$$DATX^FBAAUTL(FBIN(6))
SET FBIN(7)=$$DATX^FBAAUTL(FBIN(7))
+22 QUIT
SETTMP ;sort data by primary service facility, patient, fee program, vendor, date
+1 ;FB*3.5*163
NEW FBBILL,FBINAU,FBSKIP
+2 ;FB*3.5*163
SET FBSKIP=0
SET (FBBILL,FBINAU)=""
+3 if $$FILTER^FBPCR4()=0
QUIT
+4 ;FB*3.5*163
DO CHKBILL^IBFBUTIL(FBIN)
+5 ;Quit if running for not previously billed and bill IEN exists on File #360 FB*3.5*163
IF $GET(FBSKIP)
IF $GET(FBNPB)
QUIT
+6 SET ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,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_$PIECE(FBIN,U,12)_U_FBCATC_U_FBINS_U_FBIN(13)_U_FBIN(14)
+7 ; covered days
SET FBCDAYS=$PIECE(FBY2,U,10)
+8 ; patient control number
SET FBCSID=$PIECE(FBY2,U,11)
+9 SET FBX=$$ADJLRA^FBCHFA(FBI_",")
+10 ;adjustment reason
SET FBADJLR=$PIECE(FBX,U)
+11 ;adjustment amount
SET FBADJLA=$PIECE(FBX,U,2)
+12 ;remittance remarks
SET FBRRMKL=$$RRL^FBCHFR(FBI_",")
+13 ; admitting diagnosis
SET FBADMTDX=$$ICD9^FBCSV1($PIECE(FBY5,"^",9))
+14 SET ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,FBM,FBI,"FBINV")=FBCDAYS_"^"_FBCSID_"^"_FBADJLR_"^"_FBADJLA_"^"_FBRRMKL_"^"_FBADMTDX
+15 ;S FBDX=$G(^FBAAI(FBI,"DX")) I FBDX]"" S FBDX1="" F I=1:1:5 S:$P(FBDX,U,I) FBDX1=FBDX1_$$ICD9^FBCSV1($P(FBDX,U,I),+$P($G(FBIN),U,6))_U
+16 SET FBDX=$GET(^FBAAI(FBI,"DX"))
+17 SET FBPOA=$GET(^FBAAI(FBI,"POA"))
+18 IF FBDX]""
SET FBDX1=""
FOR I=1:1:25
Begin DoDot:1
+19 NEW FBPOA1
+20 if $PIECE(FBDX,U,I)=""
QUIT
+21 SET FBPOA1=$PIECE(FBPOA,U,I)
+22 SET FBDX1=FBDX1_$$ICD9^FBCSV1($PIECE(FBDX,U,I),+$PIECE($GET(FBIN),U,6))_"/"
+23 SET FBDX1=FBDX1_$SELECT(FBPOA1:$PIECE($GET(^FB(161.94,FBPOA1,0)),"^"),1:"")_U
+24 QUIT
End DoDot:1
+25 IF FBDX]""
SET FBDX1=$PIECE(FBDX1,U,1,($LENGTH(FBDX1,U)-1))
SET ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,FBM,FBI,"DX")=FBDX1
+26 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
+27 IF FBPROC]""
SET FBPROC1=$PIECE(FBPROC1,U,1,($LENGTH(FBPROC1,U)-1))
SET ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,FBM,FBI,"PROC")=FBPROC1
+28 ;*** removed conditional to get ancillary payments processed
+29 ;D ANC:$D(^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI))
+30 DO ANC
+31 KILL FB5010
+32 ;get line item rendering provider data
+33 IF FBPROC]""
SET I=0
FOR
SET I=$ORDER(^FBAAI(FBI,"RPROV",I))
if 'I
QUIT
Begin DoDot:1
+34 NEW X
+35 SET X=$GET(^FBAAI(FBI,"RPROV",I,0))
+36 IF $PIECE(X,U)
SET FB5010($PIECE(X,U))=X
End DoDot:1
+37 IF $DATA(FB5010)
MERGE ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,FBM,FBI,"RPROV")=FB5010
KILL FB5010
+38 ; FB*3.5*122
IF $TRANSLATE(FBY4,U)]""
SET ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,FBM,FBI,"FBY4")=FBY4
+39 ; FB*3.5*163 Bill Number
IF FBBILL
SET ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,FBM,FBI,"FBBILL")=FBBILL
+40 ; FB*3.5*163 Insurance Auth
IF FBINAU
SET ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,FBM,FBI,"FBINAU")=FBINAU
+41 ; FB*3.5*163
IF $GET(FBAUTH)'=""
SET ^TMP($JOB,"FB",FBPSF,FBPAT,+$PIECE(FBIN,U,12),FBVEN,FBM,FBI,"FBAUTH")=$GET(FBADX1)_U_$GET(FBADX2)_U_$GET(FBADX3)_U_$GET(FBAICD)_U_$GET(FBAREF)_U_$GET(FBARNPI)_U_$GET(FBAVND)_U_$GET(FBAVNPI)_U_$GET(FBAVTAX)
+42 ;I FBPROC]"" K FB5010 F I=1:1:25 S:$P(FBPROC,U,I) FB5010(I)=$G(^FBAAI(FBI,"RPROV",I,0)) ; FB*3.5*122
+43 ;I FBPROC]"" K FB5010 F I=1:1:25 S:$P(FBPROC,U,I) FB5010($P($G(^FBAAI(FBI,"RPROV",I,0)),U,1))=$G(^FBAAI(FBI,"RPROV",I,0))
+44 ;I FBPROC]"" M ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"RPROV")=FB5010 K FB5010 ; FB*3.5*122
+45 QUIT
ANC ;ancillary payments
+1 ;Patch FB*3.5*148 saves off any previous values and then cleans up variable FBAACPTC
+2 NEW J,K,L,M,Y,FBDT1,FBVID,FBAACPTC
IF FBPI=67
NEW FBPI
SET FBPI=+$PIECE(FBIN,U,12)
+3 SET J=DFN
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 SET FBDT1=$PIECE($GET(^FBAAC(J,1,K,1,L,0)),U)
IF FBDT1]""
SET FBDT1=$$DATX^FBAAUTL(FBDT1)
+6 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
+7 KILL FBAACPTC
+8 DO EN1^FBPCR2
if '$DATA(FBAACPTC)
QUIT
SET FBCNT=FBCNT+1
+9 if $$FILTER^FBPCR4()=0
QUIT
+10 SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI,"A",FBCNT)=FBDT1_U_FBAACPTC_FBCP_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_FBVNAME_U_FBVID_U_FBPI_U_
FBCATC_U_FBINS
+11 SET ^TMP($JOB,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI,"A",FBCNT,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
