FBPCR67.m

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 ---FBPCR67   6429     printed  Mar 13, 2025@21:04: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