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 ---[H[J[2J[HFBAAPAR 10200 printed Dec 13, 2024@01:55:55 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)
+9 SET FBHDT(2)=" for "_$SELECT(FBPSV:"all ",1:"")_"primary service facilities"_$SELECT(FBPSV:"",1:": ")
+10 IF 'FBPSV
Begin DoDot:1
+11 ; load facility numbers into header lines
+12 SET FBK=2
+13 SET FBJ=0
FOR
SET FBJ=$ORDER(FBPSV(FBJ))
if 'FBJ
QUIT
Begin DoDot:2
+14 SET FBX=$$STA^XUAF4(FBJ)_" "
+15 IF $LENGTH(FBHDT(FBK))+$LENGTH(FBX)>78
SET FBK=FBK+1
SET FBHDT(FBK)=" "
+16 SET FBHDT(FBK)=FBHDT(FBK)_FBX
End DoDot:2
End DoDot:1
+17 SET Q=""
SET $PIECE(Q,"=",80)="="
+18 SET (FBAAOUT,FBINTOT)=0
+19 ;
+20 ; loop thru ^TMP global by batch type
+21 SET FBTYPE=""
FOR
SET FBTYPE=$ORDER(^TMP($JOB,FBTYPE))
if FBTYPE=""
QUIT
Begin DoDot:1
+22 ; print header
+23 DO HD
+24 ; add header for batch type
+25 if FBTYPE="B2"
DO HEDP^FBAACCB0
+26 if FBTYPE="B3"
DO HED^FBAACCB
+27 if FBTYPE="B5"
DO HED^FBAACCB
+28 if FBTYPE="B9"
DO HEDC^FBAACCB1
+29 ;
+30 ; loop thru date finalized
+31 SET FBDT=""
FOR
SET FBDT=$ORDER(^TMP($JOB,FBTYPE,FBDT))
if FBDT=""
QUIT
Begin DoDot:2
+32 ; process payments
+33 if FBTYPE="B2"
DO PROCB2
+34 if FBTYPE="B3"
DO PROCB3
+35 if FBTYPE="B5"
DO PROCB5
+36 if FBTYPE="B9"
DO PROCB9
End DoDot:2
if FBQUIT
QUIT
End DoDot:1
if FBQUIT
QUIT
+37 ;
+38 IF FBQUIT
WRITE !!,"REPORT STOPPED AT USER REQUEST"
+39 ; report footer
IF '$TEST
Begin DoDot:1
+40 IF $Y+5>IOSL
DO HD
if FBQUIT
QUIT
+41 WRITE !,FBDL
+42 WRITE !,"Type",?30,"Total Finalized",?50,"Pending Payment"
+43 FOR FBTYPE="B2","B3","B5","B9"
Begin DoDot:2
+44 WRITE !," "
+45 if FBTYPE="B2"
WRITE "Travel"
+46 if FBTYPE="B3"
WRITE "Outpatient/Ancillary"
+47 if FBTYPE="B5"
WRITE "Pharmacy"
+48 if FBTYPE="B9"
WRITE "Inpatient"
+49 WRITE ?30,$JUSTIFY(FBC(FBTYPE,"F"),10)
+50 WRITE ?50,$JUSTIFY(FBC(FBTYPE,"P"),10)
End DoDot:2
End DoDot:1
+51 ;
+52 IF 'FBQUIT
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+53 DO ^%ZISC
+54 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL ^TMP($JOB)
+3 KILL FBC,FBDA,FBDL,FBDT,FBDT1,FBDT2,FBDTR,FBEV,FBHDT,FBJ,FBK,FBL,FBM,FBN
+4 KILL FBPG,FBSTALL,FBSTN,FBQUIT,FBY0,FBY2
+5 DO Q^FBAACCB0
+6 KILL DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 QUIT
+8 ;
HD ; page header
+1 NEW FBI
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET FBQUIT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"
IF FBPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBQUIT=1
QUIT
+4 IF $EXTRACT(IOST,1,2)="C-"!FBPG
WRITE @IOF
+5 SET FBPG=FBPG+1
+6 WRITE !,"Fee Basis Payment Aging Report",?49,FBDTR,?72,"page ",FBPG
+7 SET FBI=0
FOR
SET FBI=$ORDER(FBHDT(FBI))
if 'FBI
QUIT
WRITE !,FBHDT(FBI)
+8 WRITE !
+9 QUIT
+10 ;
PROCB2 ;
+1 NEW J,K,Y
+2 ; loop thru payments
+3 SET FBJ=0
FOR
SET FBJ=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ))
if 'FBJ
QUIT
Begin DoDot:1
+4 SET FBK=0
FOR
SET FBK=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ,FBK))
if 'FBK
QUIT
Begin DoDot:2
+5 IF $Y+7>IOSL
DO HD
if FBQUIT
QUIT
DO HEDP^FBAACCB0
+6 SET J=FBJ
SET K=FBK
SET Y(0)=^FBAAC(J,3,K,0)
+7 DO SETT^FBAACCB0
IF FBAAOUT
SET FBQUIT=1
End DoDot:2
if FBQUIT
QUIT
End DoDot:1
if FBQUIT
QUIT
+8 QUIT
+9 ;
PROCB3 ;
+1 NEW B,J,K,L,M
+2 ; loop thru payments
+3 SET FBJ=0
FOR
SET FBJ=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ))
if 'FBJ
QUIT
Begin DoDot:1
+4 SET FBK=0
FOR
SET FBK=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ,FBK))
if 'FBK
QUIT
Begin DoDot:2
+5 SET FBL=0
+6 FOR
SET FBL=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ,FBK,FBL))
if 'FBL
QUIT
Begin DoDot:3
+7 SET FBM=0
+8 FOR
SET FBM=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ,FBK,FBL,FBM))
if 'FBM
QUIT
Begin DoDot:4
+9 IF $Y+8>IOSL
DO HD
if FBQUIT
QUIT
DO HED^FBAACCB
+10 SET J=FBJ
SET K=FBK
SET L=FBL
SET M=FBM
+11 SET Y(0)=^FBAAC(J,1,K,1,L,1,M,0)
SET B=$PIECE(Y(0),U,8)
+12 DO SET^FBAACCB
IF FBAAOUT
SET FBQUIT=1
End DoDot:4
if FBQUIT
QUIT
End DoDot:3
if FBQUIT
QUIT
End DoDot:2
if FBQUIT
QUIT
End DoDot:1
if FBQUIT
QUIT
+13 QUIT
+14 ;
PROCB5 ;
+1 NEW A,B,B2,Z
+2 ; loop thru payments
+3 SET FBJ=0
FOR
SET FBJ=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ))
if 'FBJ
QUIT
Begin DoDot:1
+4 SET FBK=0
FOR
SET FBK=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ,FBK))
if 'FBK
QUIT
Begin DoDot:2
+5 IF $Y+7>IOSL
DO HD
if FBQUIT
QUIT
DO HED^FBAACCB
+6 SET A=FBJ
SET B2=FBK
SET Z(0)=^FBAA(162.1,A,"RX",B2,0)
SET B=$PIECE(Z(0),U,17)
+7 DO SETV^FBAACCB0
DO MORE^FBAACCB1
IF FBAAOUT
SET FBQUIT=1
End DoDot:2
if FBQUIT
QUIT
End DoDot:1
if FBQUIT
QUIT
+8 QUIT
+9 ;
PROCB9 ;
+1 NEW A,B,B2,Z
+2 ; loop thru payments
+3 SET FBJ=0
FOR
SET FBJ=$ORDER(^TMP($JOB,FBTYPE,FBDT,FBJ))
if 'FBJ
QUIT
Begin DoDot:1
+4 IF $Y+7>IOSL
DO HD
if FBQUIT
QUIT
DO HEDC^FBAACCB1
+5 SET I=FBJ
SET Z(0)=^FBAAI(I,0)
SET B=$PIECE(Z(0),U,17)
+6 DO CMORE^FBAACCB1
IF FBAAOUT
SET FBQUIT=1
End DoDot:1
if FBQUIT
QUIT
+7 QUIT
+8 ;
+9 ;FBAAPAR
