FBAAPAR.m

FBAAPAR ;WOIFO/SAB - PAYMENT AGING REPORT ;11/7/2012

 ;;3.5;FEE BASIS;**132**;JAN 30, 1995;Build 17

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ; ICRs

 ;  #10090  ^DIC(4,

 ;  #2056   $$GET1^DIQ

 ;  #10026  DIR

 ;  #10003  DD^%DT

 ;  #10000  NOW^%DTC

 ;  #4398   FIRST^VAUTOMA

 ;  #10103  $$FMADD^XLFDT, $$FMDIFF^XLFDT, $$FMTE^XLFDT

 ;  #2171   $$STA^XUAF4

 ;  #10086  %ZIS, HOME^%ZIS

 ;  #10089  %ZISC

 ;  #10063  %ZTLOAD, $$S^%ZTLOAD

 ;

 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,FBDT1,FBDT2,FBPSV,FBX,%ZIS,POP,X,Y

 ;

 ; user prompts

 ;

 ; ask one/many/all primary service failities

 W !!

 S DIC="^DIC(4,"

 S VAUTSTR="Primary Service Facility",VAUTNI=2,VAUTVB="FBPSV"

 D FIRST^VAUTOMA K DIC I Y=-1 G EXIT

 ;

 ; ask end date

 S DIR(0)="D^:"_DT_":EX"

 S DIR("A")="Report payments finalized on or before"

 ;   default end date is last day of month at least 30 days ago

 S FBX=$$FMADD^XLFDT($E(DT,1,5)_"01",-1) ; last date of prior month

 I $$FMDIFF^XLFDT(DT,FBX)<30 S FBX=$$FMADD^XLFDT($E(FBX,1,5)_"01",-1)

 S DIR("B")=$$FMTE^XLFDT(FBX)

 D ^DIR K DIR G:$D(DIRUT) EXIT

 S FBDT2=Y

 ;

 ; ask start date

 S DIR(0)="D^:"_FBDT2_":EX"

 S DIR("A")="Earliest finalized date to report"

 ;   default start date is first day of selected month

 S DIR("B")=$$FMTE^XLFDT($E(FBDT2,1,5)_"01")

 D ^DIR K DIR G:$D(DIRUT) EXIT

 S FBDT1=Y

 ;

 ; ask device

 S %ZIS="Q" D ^%ZIS G:POP EXIT

 I $D(IO("Q")) D  G EXIT

 . N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK

 . S ZTRTN="QEN^FBAAPAR",ZTDESC="Fee Basis Payment Aging Report"

 . F FBX="FBDT*","FBPSV","FBPSV(" S ZTSAVE(FBX)=""

 . D ^%ZTLOAD,HOME^%ZIS

 ;

QEN ; queued entry

 U IO

 ;

GATHER ; collect and sort data

 K ^TMP($J)

 ; init counters

 K FBC F X="B2","B3","B5","B9" F Y="F","P" S FBC(X,Y)=0

 ;

 ;

 ; batch type B2

 ; loop thru batch file by date finalized for specified period

 ;   because DATE FINALIZED field is not being populated

 S FBDT=FBDT1-.0001

 F  S FBDT=$O(^FBAA(161.7,"AF",FBDT)) Q:FBDT>FBDT2!(FBDT="")  D

 . ; loop thru batch

 . S FBN=0 F  S FBN=$O(^FBAA(161.7,"AF",FBDT,FBN)) Q:'FBN  D

 . . ; loop thru payments for batch

 . . S FBJ=0 F  S FBJ=$O(^FBAAC("AD",FBN,FBJ)) Q:'FBJ  D

 . . . S FBK=0 F  S FBK=$O(^FBAAC("AD",FBN,FBJ,FBK)) Q:'FBK  D

 . . . . S FBY0=$G(^FBAAC(FBJ,3,FBK,0))

 . . . . ;

 . . . . ; dont't check primary service facility since it is not

 . . . . ;   stored with payment, associated auth. is not known, and

 . . . . ;   station in batch file is not necessarily the same

 . . . . ;

 . . . . S FBC("B2","F")=FBC("B2","F")+1 ; incr finalized count

 . . . . ;

 . . . . ; check if payment meets criterion for pending

 . . . . Q:$P(FBY0,U,7)'=""  ; check number

 . . . . Q:$P(FBY0,U,6)'=""  ; date paid

 . . . . Q:$P(FBY0,U,8)'=""  ; cancel date

 . . . . Q:$P($G(^FBAAC(FBJ,3,FBK,"FBREJ")),U)'=""  ; reject status

 . . . . ; travel payment cannot be void

 . . . . ;

 . . . . ; save payment in list

 . . . . S ^TMP($J,"B2",FBDT,FBJ,FBK)=""

 . . . . S FBC("B2","P")=FBC("B2","P")+1 ; incr pending payment count

 ;

 ; batch type B3

 ; loop thru DATE FINALIZED x-ref

 S FBDT=FBDT1-.0001

 F  S FBDT=$O(^FBAAC("AK",FBDT)) Q:FBDT>FBDT2!(FBDT="")  D

 . S FBJ=0 F  S FBJ=$O(^FBAAC("AK",FBDT,FBJ)) Q:'FBJ  D

 . . S FBK=0 F  S FBK=$O(^FBAAC("AK",FBDT,FBJ,FBK)) Q:'FBK  D

 . . . S FBL=0 F  S FBL=$O(^FBAAC("AK",FBDT,FBJ,FBK,FBL)) Q:'FBL  D

 . . . . S FBM=0 F  S FBM=$O(^FBAAC("AK",FBDT,FBJ,FBK,FBL,FBM)) Q:'FBM  D

 . . . . . S FBY0=$G(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,0))

 . . . . . S FBY2=$G(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,2))

 . . . . . ;

 . . . . . ; skip if not selected primary service facility

 . . . . . I 'FBPSV,$P(FBY0,U,12),'$D(FBPSV($P(FBY0,U,12))) Q

 . . . . . ;

 . . . . . S FBC("B3","F")=FBC("B3","F")+1 ; incr finalized count

 . . . . . ;

 . . . . . ; check if payment meets criterion for pending

 . . . . . Q:$P(FBY2,U,3)'=""  ; check number

 . . . . . Q:$P(FBY0,U,14)'=""  ; date paid

 . . . . . Q:$P(FBY2,U,4)'=""  ; cancellation date

 . . . . . Q:$P($G(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,"FBREJ")),U)'=""  ; rej.

 . . . . . Q:$P(FBY0,U,21)'=""  ; void

 . . . . . ;

 . . . . . ; save payment in list

 . . . . . S ^TMP($J,"B3",FBDT,FBJ,FBK,FBL,FBM)=""

 . . . . . S FBC("B3","P")=FBC("B3","P")+1 ; incr pending payment count

 ;

 ; batch type B5

 ; loop thru batch file by date finalized for specified period

 ;   because DATE FINALIZED field does not exist

 S FBDT=FBDT1-.0001

 F  S FBDT=$O(^FBAA(161.7,"AF",FBDT)) Q:FBDT>FBDT2!(FBDT="")  D

 . ; loop thru batch

 . S FBN=0 F  S FBN=$O(^FBAA(161.7,"AF",FBDT,FBN)) Q:'FBN  D

 . . ; loop thru payments for batch

 . . S FBJ=0 F  S FBJ=$O(^FBAA(162.1,"AE",FBN,FBJ)) Q:'FBJ  D

 . . . S FBK=0 F  S FBK=$O(^FBAA(162.1,"AE",FBN,FBJ,FBK)) Q:'FBK  D

 . . . . S FBY2=$G(^FBAA(162.1,FBJ,"RX",FBK,2))

 . . . . ;

 . . . . ; skip if not selected primary service facility

 . . . . I 'FBPSV,$P(FBY2,U,5),'$D(FBPSV($P(FBY2,U,5))) Q

 . . . . ;

 . . . . S FBC("B5","F")=FBC("B5","F")+1 ; incr finalzied count

 . . . . ;

 . . . . ; check if payment meets criterion as pending

 . . . . Q:$P(FBY2,U,10)'=""  ; check number

 . . . . Q:$P(FBY2,U,8)'=""  ; date paid

 . . . . Q:$P(FBY2,U,11)'=""  ; cancel date

 . . . . Q:$P(FBY2,U,3)'=""  ; void

 . . . . Q:$P($G(^FBAA(162.1,FBJ,"RX",FBK,"FBREJ")),U)'=""  ; reject

 . . . . ;

 . . . . ; save payment in list

 . . . . S ^TMP($J,"B5",FBDT,FBJ,FBK)=""

 . . . . S FBC("B5","P")=FBC("B5","P")+1 ; incr pending payment count

 ;

 ; batch type B9

 ; loop thru DATE FINALIZED x-ref

 S FBDT=FBDT1-.0001

 F  S FBDT=$O(^FBAAI("AD",FBDT)) Q:FBDT>FBDT2!(FBDT="")  D

 . S FBJ=0 F  S FBJ=$O(^FBAAI("AD",FBDT,FBJ)) Q:'FBJ  D

 . . S FBY0=$G(^FBAAI(FBJ,0))

 . . S FBY2=$G(^FBAAI(FBJ,2))

 . . ;

 . . ; skip if not selected primary service facility

 . . I 'FBPSV,$P(FBY0,U,20),'$D(FBPSV($P(FBY0,U,20))) Q

 . . ;

 . . S FBC("B9","F")=FBC("B9","F")+1 ; incr finalized count

 . . ;

 . . ; check if payment meets criterion

 . . Q:$P(FBY2,U,4)'=""  ; check number

 . . Q:$P(FBY2,U,1)'=""  ; date paid

 . . Q:$P(FBY2,U,5)'=""  ; cancellation date

 . . Q:$P($G(^FBAAI(FBJ,"FBREJ")),U)'=""  ; reject status

 . . Q:$P(FBY0,U,14)'=""  ; void

 . . ;

 . . ; save payment in list

 . . S ^TMP($J,"B9",FBDT,FBJ)=""

 . . S FBC("B9","P")=FBC("B9","P")+1 ; incr pending payment count

 ;

PRINT ; report data

 S (FBQUIT,FBPG)=0 D NOW^%DTC S Y=% D DD^%DT S FBDTR=Y

 K FBDL

 S FBDL="",$P(FBDL,"-",80)=""

 ;

 ; build page header text for selection criteria

 K FBHDT

 S FBHDT(1)="  Payments finalized from "

 S FBHDT(1)=FBHDT(1)_$$FMTE^XLFDT(FBDT1)_" to "_$$FMTE^XLFDT(FBDT2)

 S FBHDT(2)="  for "_$S(FBPSV:"all ",1:"")_"primary service facilities"_$S(FBPSV:"",1:": ")

 I 'FBPSV D

 . ; load facility numbers into header lines

 . S FBK=2

 . S FBJ=0 F  S FBJ=$O(FBPSV(FBJ)) Q:'FBJ  D

 . . S FBX=$$STA^XUAF4(FBJ)_"  "

 . . I $L(FBHDT(FBK))+$L(FBX)>78 S FBK=FBK+1,FBHDT(FBK)="  "

 . . S FBHDT(FBK)=FBHDT(FBK)_FBX

 S Q="",$P(Q,"=",80)="="

 S (FBAAOUT,FBINTOT)=0

 ;

 ; loop thru ^TMP global by batch type

 S FBTYPE="" F  S FBTYPE=$O(^TMP($J,FBTYPE)) Q:FBTYPE=""  D  Q:FBQUIT

 . ; print header

 . D HD

 . ; add header for batch type

 . D:FBTYPE="B2" HEDP^FBAACCB0

 . D:FBTYPE="B3" HED^FBAACCB

 . D:FBTYPE="B5" HED^FBAACCB

 . D:FBTYPE="B9" HEDC^FBAACCB1

 . ;

 . ; loop thru date finalized

 . S FBDT="" F  S FBDT=$O(^TMP($J,FBTYPE,FBDT)) Q:FBDT=""  D  Q:FBQUIT

 . . ; process payments

 . . D:FBTYPE="B2" PROCB2

 . . D:FBTYPE="B3" PROCB3

 . . D:FBTYPE="B5" PROCB5

 . . D:FBTYPE="B9" PROCB9

 ;

 I FBQUIT W !!,"REPORT STOPPED AT USER REQUEST"

 E  D  ; report footer

 . I $Y+5>IOSL D HD Q:FBQUIT

 . W !,FBDL

 . W !,"Type",?30,"Total Finalized",?50,"Pending Payment"

 . F FBTYPE="B2","B3","B5","B9" D

 . . W !,"  "

 . . W:FBTYPE="B2" "Travel"

 . . W:FBTYPE="B3" "Outpatient/Ancillary"

 . . W:FBTYPE="B5" "Pharmacy"

 . . W:FBTYPE="B9" "Inpatient"

 . . W ?30,$J(FBC(FBTYPE,"F"),10)

 . . W ?50,$J(FBC(FBTYPE,"P"),10)

 ;

 I 'FBQUIT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR

 D ^%ZISC

 ;

EXIT ;

 I $D(ZTQUEUED) S ZTREQ="@"

 K ^TMP($J)

 K FBC,FBDA,FBDL,FBDT,FBDT1,FBDT2,FBDTR,FBEV,FBHDT,FBJ,FBK,FBL,FBM,FBN

 K FBPG,FBSTALL,FBSTN,FBQUIT,FBY0,FBY2

 D Q^FBAACCB0

 K DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 Q

 ;

HD ; page header

 N FBI

 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,FBQUIT=1 Q

 I $E(IOST,1,2)="C-",FBPG S DIR(0)="E" D ^DIR K DIR I 'Y S FBQUIT=1 Q

 I $E(IOST,1,2)="C-"!FBPG W @IOF

 S FBPG=FBPG+1

 W !,"Fee Basis Payment Aging Report",?49,FBDTR,?72,"page ",FBPG

 S FBI=0 F  S FBI=$O(FBHDT(FBI)) Q:'FBI  W !,FBHDT(FBI)

 W !

 Q

 ;

PROCB2 ;

 N J,K,Y

 ; loop thru payments

 S FBJ=0 F  S FBJ=$O(^TMP($J,FBTYPE,FBDT,FBJ)) Q:'FBJ  D  Q:FBQUIT

 . S FBK=0 F  S FBK=$O(^TMP($J,FBTYPE,FBDT,FBJ,FBK)) Q:'FBK  D  Q:FBQUIT

 . . I $Y+7>IOSL D HD Q:FBQUIT  D HEDP^FBAACCB0

 . . S J=FBJ,K=FBK,Y(0)=^FBAAC(J,3,K,0)

 . . D SETT^FBAACCB0 I FBAAOUT S FBQUIT=1

 Q

 ;

PROCB3 ;

 N B,J,K,L,M

 ; loop thru payments

 S FBJ=0 F  S FBJ=$O(^TMP($J,FBTYPE,FBDT,FBJ)) Q:'FBJ  D  Q:FBQUIT

 . S FBK=0 F  S FBK=$O(^TMP($J,FBTYPE,FBDT,FBJ,FBK)) Q:'FBK  D  Q:FBQUIT

 . . S FBL=0

 . . F  S FBL=$O(^TMP($J,FBTYPE,FBDT,FBJ,FBK,FBL)) Q:'FBL  D  Q:FBQUIT

 . . . S FBM=0

 . . . F  S FBM=$O(^TMP($J,FBTYPE,FBDT,FBJ,FBK,FBL,FBM)) Q:'FBM  D  Q:FBQUIT

 . . . . I $Y+8>IOSL D HD Q:FBQUIT  D HED^FBAACCB

 . . . . S J=FBJ,K=FBK,L=FBL,M=FBM

 . . . . S Y(0)=^FBAAC(J,1,K,1,L,1,M,0),B=$P(Y(0),U,8)

 . . . . D SET^FBAACCB I FBAAOUT S FBQUIT=1

 Q

 ;

PROCB5 ;

 N A,B,B2,Z

 ; loop thru payments

 S FBJ=0 F  S FBJ=$O(^TMP($J,FBTYPE,FBDT,FBJ)) Q:'FBJ  D  Q:FBQUIT

 . S FBK=0 F  S FBK=$O(^TMP($J,FBTYPE,FBDT,FBJ,FBK)) Q:'FBK  D  Q:FBQUIT

 . . I $Y+7>IOSL D HD Q:FBQUIT  D HED^FBAACCB

 . . S A=FBJ,B2=FBK,Z(0)=^FBAA(162.1,A,"RX",B2,0),B=$P(Z(0),U,17)

 . . D SETV^FBAACCB0,MORE^FBAACCB1 I FBAAOUT S FBQUIT=1

 Q

 ;

PROCB9 ;

 N A,B,B2,Z

 ; loop thru payments

 S FBJ=0 F  S FBJ=$O(^TMP($J,FBTYPE,FBDT,FBJ)) Q:'FBJ  D  Q:FBQUIT

 . I $Y+7>IOSL D HD Q:FBQUIT  D HEDC^FBAACCB1

 . S I=FBJ,Z(0)=^FBAAI(I,0),B=$P(Z(0),U,17)

 . D CMORE^FBAACCB1 I FBAAOUT S FBQUIT=1

 Q

 ;

 ;FBAAPAR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBAAPAR   10200     printed  Mar 13, 2025@21:00:37                                                                                                                                                                                                    Page 2

FBAAPAR   ;WOIFO/SAB - PAYMENT AGING REPORT ;11/7/2012

 +1       ;;3.5;FEE BASIS;**132**;JAN 30, 1995;Build 17

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ; ICRs

 +4       ;  #10090  ^DIC(4,

 +5       ;  #2056   $$GET1^DIQ

 +6       ;  #10026  DIR

 +7       ;  #10003  DD^%DT

 +8       ;  #10000  NOW^%DTC

 +9       ;  #4398   FIRST^VAUTOMA

 +10      ;  #10103  $$FMADD^XLFDT, $$FMDIFF^XLFDT, $$FMTE^XLFDT

 +11      ;  #2171   $$STA^XUAF4

 +12      ;  #10086  %ZIS, HOME^%ZIS

 +13      ;  #10089  %ZISC

 +14      ;  #10063  %ZTLOAD, $$S^%ZTLOAD

 +15      ;

 +16       NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,FBDT1,FBDT2,FBPSV,FBX,%ZIS,POP,X,Y

 +17      ;

 +18      ; user prompts

 +19      ;

 +20      ; ask one/many/all primary service failities

 +21       WRITE !!

 +22       SET DIC="^DIC(4,"

 +23       SET VAUTSTR="Primary Service Facility"

           SET VAUTNI=2

           SET VAUTVB="FBPSV"

 +24       DO FIRST^VAUTOMA

           KILL DIC

           IF Y=-1

               GOTO EXIT

 +25      ;

 +26      ; ask end date

 +27       SET DIR(0)="D^:"_DT_":EX"

 +28       SET DIR("A")="Report payments finalized on or before"

 +29      ;   default end date is last day of month at least 30 days ago

 +30      ; last date of prior month

           SET FBX=$$FMADD^XLFDT($EXTRACT(DT,1,5)_"01",-1)

 +31       IF $$FMDIFF^XLFDT(DT,FBX)<30

               SET FBX=$$FMADD^XLFDT($EXTRACT(FBX,1,5)_"01",-1)

 +32       SET DIR("B")=$$FMTE^XLFDT(FBX)

 +33       DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO EXIT

 +34       SET FBDT2=Y

 +35      ;

 +36      ; ask start date

 +37       SET DIR(0)="D^:"_FBDT2_":EX"

 +38       SET DIR("A")="Earliest finalized date to report"

 +39      ;   default start date is first day of selected month

 +40       SET DIR("B")=$$FMTE^XLFDT($EXTRACT(FBDT2,1,5)_"01")

 +41       DO ^DIR

           KILL DIR

           if $DATA(DIRUT)

               GOTO EXIT

 +42       SET FBDT1=Y

 +43      ;

 +44      ; ask device

 +45       SET %ZIS="Q"

           DO ^%ZIS

           if POP

               GOTO EXIT

 +46       IF $DATA(IO("Q"))

               Begin DoDot:1

 +47               NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK

 +48               SET ZTRTN="QEN^FBAAPAR"

                   SET ZTDESC="Fee Basis Payment Aging Report"

 +49               FOR FBX="FBDT*","FBPSV","FBPSV("

                       SET ZTSAVE(FBX)=""

 +50               DO ^%ZTLOAD

                   DO HOME^%ZIS

               End DoDot:1

               GOTO EXIT

 +51      ;

QEN       ; queued entry

 +1        USE IO

 +2       ;

GATHER    ; collect and sort data

 +1        KILL ^TMP($JOB)

 +2       ; init counters

 +3        KILL FBC

           FOR X="B2","B3","B5","B9"

               FOR Y="F","P"

                   SET FBC(X,Y)=0

 +4       ;

 +5       ;

 +6       ; batch type B2

 +7       ; loop thru batch file by date finalized for specified period

 +8       ;   because DATE FINALIZED field is not being populated

 +9        SET FBDT=FBDT1-.0001

 +10       FOR 

               SET FBDT=$ORDER(^FBAA(161.7,"AF",FBDT))

               if FBDT>FBDT2!(FBDT="")

                   QUIT 

               Begin DoDot:1

 +11      ; loop thru batch

 +12               SET FBN=0

                   FOR 

                       SET FBN=$ORDER(^FBAA(161.7,"AF",FBDT,FBN))

                       if 'FBN

                           QUIT 

                       Begin DoDot:2

 +13      ; loop thru payments for batch

 +14                       SET FBJ=0

                           FOR 

                               SET FBJ=$ORDER(^FBAAC("AD",FBN,FBJ))

                               if 'FBJ

                                   QUIT 

                               Begin DoDot:3

 +15                               SET FBK=0

                                   FOR 

                                       SET FBK=$ORDER(^FBAAC("AD",FBN,FBJ,FBK))

                                       if 'FBK

                                           QUIT 

                                       Begin DoDot:4

 +16                                       SET FBY0=$GET(^FBAAC(FBJ,3,FBK,0))

 +17      ;

 +18      ; dont't check primary service facility since it is not

 +19      ;   stored with payment, associated auth. is not known, and

 +20      ;   station in batch file is not necessarily the same

 +21      ;

 +22      ; incr finalized count

                                           SET FBC("B2","F")=FBC("B2","F")+1

 +23      ;

 +24      ; check if payment meets criterion for pending

 +25      ; check number

                                           if $PIECE(FBY0,U,7)'=""

                                               QUIT 

 +26      ; date paid

                                           if $PIECE(FBY0,U,6)'=""

                                               QUIT 

 +27      ; cancel date

                                           if $PIECE(FBY0,U,8)'=""

                                               QUIT 

 +28      ; reject status

                                           if $PIECE($GET(^FBAAC(FBJ,3,FBK,"FBREJ")),U)'=""

                                               QUIT 

 +29      ; travel payment cannot be void

 +30      ;

 +31      ; save payment in list

 +32                                       SET ^TMP($JOB,"B2",FBDT,FBJ,FBK)=""

 +33      ; incr pending payment count

                                           SET FBC("B2","P")=FBC("B2","P")+1

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +34      ;

 +35      ; batch type B3

 +36      ; loop thru DATE FINALIZED x-ref

 +37       SET FBDT=FBDT1-.0001

 +38       FOR 

               SET FBDT=$ORDER(^FBAAC("AK",FBDT))

               if FBDT>FBDT2!(FBDT="")

                   QUIT 

               Begin DoDot:1

 +39               SET FBJ=0

                   FOR 

                       SET FBJ=$ORDER(^FBAAC("AK",FBDT,FBJ))

                       if 'FBJ

                           QUIT 

                       Begin DoDot:2

 +40                       SET FBK=0

                           FOR 

                               SET FBK=$ORDER(^FBAAC("AK",FBDT,FBJ,FBK))

                               if 'FBK

                                   QUIT 

                               Begin DoDot:3

 +41                               SET FBL=0

                                   FOR 

                                       SET FBL=$ORDER(^FBAAC("AK",FBDT,FBJ,FBK,FBL))

                                       if 'FBL

                                           QUIT 

                                       Begin DoDot:4

 +42                                       SET FBM=0

                                           FOR 

                                               SET FBM=$ORDER(^FBAAC("AK",FBDT,FBJ,FBK,FBL,FBM))

                                               if 'FBM

                                                   QUIT 

                                               Begin DoDot:5

 +43                                               SET FBY0=$GET(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,0))

 +44                                               SET FBY2=$GET(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,2))

 +45      ;

 +46      ; skip if not selected primary service facility

 +47                                               IF 'FBPSV

                                                       IF $PIECE(FBY0,U,12)

                                                           IF '$DATA(FBPSV($PIECE(FBY0,U,12)))

                                                               QUIT 

 +48      ;

 +49      ; incr finalized count

                                                   SET FBC("B3","F")=FBC("B3","F")+1

 +50      ;

 +51      ; check if payment meets criterion for pending

 +52      ; check number

                                                   if $PIECE(FBY2,U,3)'=""

                                                       QUIT 

 +53      ; date paid

                                                   if $PIECE(FBY0,U,14)'=""

                                                       QUIT 

 +54      ; cancellation date

                                                   if $PIECE(FBY2,U,4)'=""

                                                       QUIT 

 +55      ; rej.

                                                   if $PIECE($GET(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,"FBREJ")),U)'=""

                                                       QUIT 

 +56      ; void

                                                   if $PIECE(FBY0,U,21)'=""

                                                       QUIT 

 +57      ;

 +58      ; save payment in list

 +59                                               SET ^TMP($JOB,"B3",FBDT,FBJ,FBK,FBL,FBM)=""

 +60      ; incr pending payment count

                                                   SET FBC("B3","P")=FBC("B3","P")+1

                                               End DoDot:5

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +61      ;

 +62      ; batch type B5

 +63      ; loop thru batch file by date finalized for specified period

 +64      ;   because DATE FINALIZED field does not exist

 +65       SET FBDT=FBDT1-.0001

 +66       FOR 

               SET FBDT=$ORDER(^FBAA(161.7,"AF",FBDT))

               if FBDT>FBDT2!(FBDT="")

                   QUIT 

               Begin DoDot:1

 +67      ; loop thru batch

 +68               SET FBN=0

                   FOR 

                       SET FBN=$ORDER(^FBAA(161.7,"AF",FBDT,FBN))

                       if 'FBN

                           QUIT 

                       Begin DoDot:2

 +69      ; loop thru payments for batch

 +70                       SET FBJ=0

                           FOR 

                               SET FBJ=$ORDER(^FBAA(162.1,"AE",FBN,FBJ))

                               if 'FBJ

                                   QUIT 

                               Begin DoDot:3

 +71                               SET FBK=0

                                   FOR 

                                       SET FBK=$ORDER(^FBAA(162.1,"AE",FBN,FBJ,FBK))

                                       if 'FBK

                                           QUIT 

                                       Begin DoDot:4

 +72                                       SET FBY2=$GET(^FBAA(162.1,FBJ,"RX",FBK,2))

 +73      ;

 +74      ; skip if not selected primary service facility

 +75                                       IF 'FBPSV

                                               IF $PIECE(FBY2,U,5)

                                                   IF '$DATA(FBPSV($PIECE(FBY2,U,5)))

                                                       QUIT 

 +76      ;

 +77      ; incr finalzied count

                                           SET FBC("B5","F")=FBC("B5","F")+1

 +78      ;

 +79      ; check if payment meets criterion as pending

 +80      ; check number

                                           if $PIECE(FBY2,U,10)'=""

                                               QUIT 

 +81      ; date paid

                                           if $PIECE(FBY2,U,8)'=""

                                               QUIT 

 +82      ; cancel date

                                           if $PIECE(FBY2,U,11)'=""

                                               QUIT 

 +83      ; void

                                           if $PIECE(FBY2,U,3)'=""

                                               QUIT 

 +84      ; reject

                                           if $PIECE($GET(^FBAA(162.1,FBJ,"RX",FBK,"FBREJ")),U)'=""

                                               QUIT 

 +85      ;

 +86      ; save payment in list

 +87                                       SET ^TMP($JOB,"B5",FBDT,FBJ,FBK)=""

 +88      ; incr pending payment count

                                           SET FBC("B5","P")=FBC("B5","P")+1

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +89      ;

 +90      ; batch type B9

 +91      ; loop thru DATE FINALIZED x-ref

 +92       SET FBDT=FBDT1-.0001

 +93       FOR 

               SET FBDT=$ORDER(^FBAAI("AD",FBDT))

               if FBDT>FBDT2!(FBDT="")

                   QUIT 

               Begin DoDot:1

 +94               SET FBJ=0

                   FOR 

                       SET FBJ=$ORDER(^FBAAI("AD",FBDT,FBJ))

                       if 'FBJ

                           QUIT 

                       Begin DoDot:2

 +95                       SET FBY0=$GET(^FBAAI(FBJ,0))

 +96                       SET FBY2=$GET(^FBAAI(FBJ,2))

 +97      ;

 +98      ; skip if not selected primary service facility

 +99                       IF 'FBPSV

                               IF $PIECE(FBY0,U,20)

                                   IF '$DATA(FBPSV($PIECE(FBY0,U,20)))

                                       QUIT 

 +100     ;

 +101     ; incr finalized count

                           SET FBC("B9","F")=FBC("B9","F")+1

 +102     ;

 +103     ; check if payment meets criterion

 +104     ; check number

                           if $PIECE(FBY2,U,4)'=""

                               QUIT 

 +105     ; date paid

                           if $PIECE(FBY2,U,1)'=""

                               QUIT 

 +106     ; cancellation date

                           if $PIECE(FBY2,U,5)'=""

                               QUIT 

 +107     ; reject status

                           if $PIECE($GET(^FBAAI(FBJ,"FBREJ")),U)'=""

                               QUIT 

 +108     ; void

                           if $PIECE(FBY0,U,14)'=""

                               QUIT 

 +109     ;

 +110     ; save payment in list

 +111                      SET ^TMP($JOB,"B9",FBDT,FBJ)=""

 +112     ; incr pending payment count

                           SET FBC("B9","P")=FBC("B9","P")+1

                       End DoDot:2

               End DoDot:1

 +113     ;

PRINT     ; report data

 +1        SET (FBQUIT,FBPG)=0

           DO NOW^%DTC

           SET Y=%

           DO DD^%DT

           SET FBDTR=Y

 +2        KILL FBDL

 +3        SET FBDL=""

           SET $PIECE(FBDL,"-",80)=""

 +4       ;

 +5       ; build page header text for selection criteria

 +6        KILL FBHDT

 +7        SET FBHDT(1)="  Payments finalized from "

 +8        SET FBHDT(1)=FBHDT(1)_$$FMTE^XLFDT(FBDT1)_" to "_$$FMTE^XLFDT(FBDT2)