FBPAY67.m

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 ---FBPAY67   7087     printed  Apr 23, 2025@18:14:02                                                                                                                                                                                                     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