- FBUCMBS ;LEX/WRC - MILLENNIUM ACT EMERGENCY CARE SUMMARY REPORT ;07/07/03
- ;;3.5;FEE BASIS;**62,90**;JAN 30, 1995
- ;
- SDT S %DT="EA",%DT("A")="Start Date: " D ^%DT
- S FBSDT=Y I FBSDT<0 D KIL Q
- I FBSDT>DT W !,"Start date cannot be in the future." G SDT
- ;
- EDT S %DT="EA",%DT("A")="End Date: " D ^%DT
- S FBEDT=Y I FBEDT<0 D KIL Q
- I FBEDT<FBSDT W !,"End date cannot be prior to the Start date." G EDT
- ;
- ZIS S %IS="Q" D ^%ZIS
- K %H,%T I POP=1 D KIL Q
- I '$D(IO("Q")) U IO D STRT Q
- S ZTRTN="STRT^FBUCMBS",ZTIO=ION,ZTSAVE("FBEDT")="",ZTSAVE("FBSDT")=""
- D ^%ZTLOAD
- W:'$D(ZTQUEUED) !,"Request Queued!",!,"Task Number: "_$G(ZTSK),!
- D KIL Q
- ;
- STRT ;
- S (FBTNCL,FBTDCL,FBTCLMTS,FBTNCLPD,FBTDCLPD,FBTNCLR,FBTDCLR,FBTNCLPN,FBTDCLPN,FBTREAS,FBNCLMS,FBDAYS,FBTDSUPD)=0
- S Y=FBSDT D DD^%DT S FBPSDT=Y
- S FBDA="",FBSDT=FBSDT-1
- F S FBSDT=$O(^FB583("B",FBSDT)) Q:FBSDT>FBEDT!(FBSDT="") D
- . F S FBDA=$O(^FB583("B",FBSDT,FBDA)) Q:FBDA="" D
- .. I $P($G(^FB583(FBDA,0)),"^",28)'=1 Q
- .. S FBUCL0=$G(^FB583(FBDA,0))
- .. S FBTNCL=FBTNCL+1
- .. S FBAMTCL=$P(FBUCL0,"^",9)
- .. S FBTDCL=FBTDCL+FBAMTCL
- .. S FBCLMT=$P(FBUCL0,"^",23)
- .. I FBCLMT'="",($D(^TMP($J,"FBUCMBS","CLMT",FBCLMT))=0) S ^TMP($J,"FBUCMBS","CLMT",FBCLMT)="",FBTCLMTS=FBTCLMTS+1
- .. S FBDISPO=$P(FBUCL0,"^",11)
- .. I FBDISPO="" S FBTNCLPN=FBTNCLPN+1,FBTDCLPN=FBTDCLPN+$P(FBUCL0,"^",9) Q
- .. I $D(^FB(162.91,FBDISPO,0))=0 S FBTNCLPN=FBTNCLPN+1,FBTDCLPN=FBTDCLPN+$P(FBUCL0,"^",9) Q
- .. S FBDIS0=$P($G(^FB(162.91,FBDISPO,0)),"^",1)
- .. I $E($P(FBDIS0,"^",1),1,8)="APPROVED" D Q
- ... S FBPD1=$$AMTPD(FBDA)
- ... S FBTNCLPD=FBTNCLPD+1,FBTDCLPD=FBTDCLPD+FBPD1,FBTDSUPD=FBTDSUPD+FBAMTCL D AVGTM
- .. S FBTNCLR=FBTNCLR+1,FBTDCLR=FBTDCLR+$P(FBUCL0,"^",9)
- .. D REAS,ADD,STATUS,AVGTM
- D PRT S FBDENIAL="" D DENIAL I $D(FBQ) D KIL Q
- D PAVG I $D(FBQ) D KIL Q
- D KIL
- Q
- ;
- REAS N X S FBREAS=""
- S X=$O(^FB583(FBDA,"D",0))
- I X S X=+$G(^FB583(FBDA,"D",X,0))
- I X S FBREAS=$P($G(^FB(162.94,X,0)),"^")
- S FBREAS=$S(FBREAS="":"OTHER",1:FBREAS)
- Q
- ADD ;
- I $D(^TMP($J,"FBUCMBS","REAS",FBREAS))=1 S $P(^TMP($J,"FBUCMBS","REAS",FBREAS),"^",1)=$P(^TMP($J,"FBUCMBS","REAS",FBREAS),"^",1)+1 Q
- S ^TMP($J,"FBUCMBS","REAS",FBREAS)=1
- Q
- ;
- STATUS I $P(FBUCL0,"^",24)="" Q
- S FBSIEN=$P(FBUCL0,"^",24)
- I $D(^FB(162.92,FBSIEN,0))=0 Q
- I $P(^FB(162.92,FBSIEN,0),"^",1)["PENDING" S FBTNCLPN=FBTNCLPN+1,FBTDCLPN=FBTDCLPN+$P(FBUCL0,"^",9)
- Q
- ;
- AVGTM ;
- I $P(FBUCL0,"^",1)="" Q
- I $P(FBUCL0,"^",12)="" Q
- S FBNCLMS=FBNCLMS+1,X1=$P(FBUCL0,"^",12),X2=$P(FBUCL0,"^",1) D ^%DTC S FBDAYS=FBDAYS+X
- Q
- ;
- PRT ;
- S Y=DT D DD^%DT S FBPRDT=Y
- S Y=FBEDT D DD^%DT S FBPEDT=Y
- W @IOF,!,?25,"MILLENNIUM ACT EMERGENCY CARE"
- S FBTDSU=FBTDSUPD-FBTDCLPD
- W !,?32,"SUMMARY REPORT"
- W !,?23,FBPSDT," THROUGH ",FBPEDT
- W !,?29,"RUN DATE: ",FBPRDT,!!
- W !,"Total Number Claims Received: " S X=FBTNCL,X2=0,X3=20 D COMMA^%DTC W ?50,X
- W !,"Total Dollars Claims Received: " S X=FBTDCL,X2="2$",X3=20 D COMMA^%DTC W ?50,X
- W !!,"Total Claimants: " S X=FBTCLMTS,X2=0,X3=20 D COMMA^%DTC W ?50,X
- W !!,"Total Claims Paid: " S X=FBTNCLPD,X2=0,X3=20 D COMMA^%DTC W ?50,X
- W !,"Total Dollars Claims Paid: " S X=FBTDCLPD,X2="2$",X3=20 D COMMA^%DTC W ?50,X
- W !!,"Total Dollars Suspended: " S X=FBTDSU,X2="2$",X3=20 D COMMA^%DTC W ?50,X
- W !!,"Total Number Claims Rejected: " S X=FBTNCLR,X2=0,X3=20 D COMMA^%DTC W ?50,X
- W !,"Total Dollars Claims Rejected: " S X=FBTDCLR,X2="2$",X3=20 D COMMA^%DTC W ?50,X,!
- W !,?32,"REASONS REJECTED",!
- Q
- ;
- DENIAL F S FBDENIAL=$O(^TMP($J,"FBUCMBS","REAS",FBDENIAL)) Q:FBDENIAL=""!($D(FBQ)) D
- . W !,?5,FBDENIAL,":" S X=$P(^TMP($J,"FBUCMBS","REAS",FBDENIAL),"^",1),X2=0,X3=20 D COMMA^%DTC W ?50,X
- . I $Y>(IOSL-2) D PAUSE Q:$D(FBQ)
- . S FBTREAS=FBTREAS+$P(^TMP($J,"FBUCMBS","REAS",FBDENIAL),"^",1)
- Q
- ;
- PAVG W !,?59,"----------" I $Y>(IOSL-2) D PAUSE S FBPSW=1 Q:$D(FBQ)
- S X=FBTREAS,X2=0,X3=20 D COMMA^%DTC W !,?50,X I $Y>(IOSL-2) D PAUSE S FBPSW=1 Q:$D(FBQ)
- W !!,"Total Number Claims Pending: " S X=FBTNCLPN,X2=0,X3=20 D COMMA^%DTC W ?50,X I $Y>(IOSL-2) D PAUSE S FBPSW=1 Q:$D(FBQ)
- W !,"Total Dollars Claims Pending: " S X=FBTDCLPN,X2="2$",X3=20 D COMMA^%DTC W ?50,X I $Y>(IOSL-2) D PAUSE S FBPSW=1 Q:$D(FBQ)
- I FBNCLMS=0 W !!,"Average Processing Time: ",$J(0,3,2)," Days" D:$Y>(IOSL-14) PAUSE Q
- S FBAVGD=FBDAYS/FBNCLMS W !!,"Average Processing Time: ",$J(FBAVGD,3,2)," Days" I $Y>(IOSL-2) D PAUSE S FBPSW=1 Q:$D(FBQ)
- I '$D(FBPSW) D PAUSE
- Q
- ;
- KIL ;
- K FBTNCL,FBTDCL,FBTCLMTS,FBTNCLPD,FBTDCLPD,FBTNCLR,FBTDCLR,FBTNCLPN,FBTDCLPN,FBTREAS,FBNCLMS,FBDAYS,FBPSDT,FBSDT,FBPEDT,FBEDT,FBDA,FBAMTCL,FBDISPO,FBREAS,FBSIEN
- K %DT,%IS,POP,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK,FBAVGD,FBCLMT,FBCLMTS,FBDENIAL,FBPRDT,FBRDT,X,X1,X2,X3,Y,FBPSW,FBQ,DIR,DIRUT,DUOUT,FBPD1,FBTDSUPD,FBUCL0,FBDIS0,FBTDSU
- K ^TMP($J)
- D ^%ZISC
- Q
- ;
- AMTPD(FBDA) ;Determine the amount paid an unauthorized claim
- ;Input: FBDA -- IEN of record in the unauthorized claim file 162.7
- ;Output: Amount paid, or 0 if the claim cannot be identified
- ;
- N FBTAMT,FBX,FBUCPAY,FBFILE,FBIENS,FBAMT
- ;
- ; - initialize total amount paid
- S FBTAMT=0
- ;
- ; - check for valid input
- I '$G(^FB583(FBDA,0)) G AMTPDQ
- ;
- ; - get list of payments for the claim
- S FBX=$$PAYST^FBUCUTL(FBDA,"FBUCPAY")
- ;
- ; - loop thru payments to get total amount approved
- S FBTAMT=0
- F FBFILE=162.03,162.11,162.5 D
- . S FBIENS="" F S FBIENS=$O(FBUCPAY(FBDA,FBFILE,FBIENS)) Q:FBIENS="" D
- .. I FBFILE=162.03 Q:$P($G(^FBAAC($P(FBIENS,",",4),1,$P(FBIENS,",",3),1,$P(FBIENS,",",2),1,$P(FBIENS,",",1),"FBREJ")),"^",1)'="" S FBAMT=$$GET1^DIQ(FBFILE,FBIENS,2)
- .. I FBFILE=162.11 Q:$P($G(^FBAA(162.1,$P(FBIENS,",",2),"RX",$P(FBIENS,",",1),"FBREJ")),"^",1)'="" S FBAMT=$$GET1^DIQ(FBFILE,FBIENS,16.5)
- .. I FBFILE=162.5 Q:$P($G(^FBAAI(+FBIENS,"FBREJ")),"^",1)'="" S FBAMT=$$GET1^DIQ(FBFILE,FBIENS,8)
- .. S FBTAMT=FBTAMT+FBAMT
- ;
- AMTPDQ Q FBTAMT
- ;
- PAUSE ; - Page break
- I $E(IOST,1,2)'="C-" Q
- S DIR(0)="E" D ^DIR I $D(DIRUT) S FBQ=1 Q
- W @IOF
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCMBS 6038 printed Jan 18, 2025@03:01:33 Page 2
- FBUCMBS ;LEX/WRC - MILLENNIUM ACT EMERGENCY CARE SUMMARY REPORT ;07/07/03
- +1 ;;3.5;FEE BASIS;**62,90**;JAN 30, 1995
- +2 ;
- SDT SET %DT="EA"
- SET %DT("A")="Start Date: "
- DO ^%DT
- +1 SET FBSDT=Y
- IF FBSDT<0
- DO KIL
- QUIT
- +2 IF FBSDT>DT
- WRITE !,"Start date cannot be in the future."
- GOTO SDT
- +3 ;
- EDT SET %DT="EA"
- SET %DT("A")="End Date: "
- DO ^%DT
- +1 SET FBEDT=Y
- IF FBEDT<0
- DO KIL
- QUIT
- +2 IF FBEDT<FBSDT
- WRITE !,"End date cannot be prior to the Start date."
- GOTO EDT
- +3 ;
- ZIS SET %IS="Q"
- DO ^%ZIS
- +1 KILL %H,%T
- IF POP=1
- DO KIL
- QUIT
- +2 IF '$DATA(IO("Q"))
- USE IO
- DO STRT
- QUIT
- +3 SET ZTRTN="STRT^FBUCMBS"
- SET ZTIO=ION
- SET ZTSAVE("FBEDT")=""
- SET ZTSAVE("FBSDT")=""
- +4 DO ^%ZTLOAD
- +5 if '$DATA(ZTQUEUED)
- WRITE !,"Request Queued!",!,"Task Number: "_$GET(ZTSK),!
- +6 DO KIL
- QUIT
- +7 ;
- STRT ;
- +1 SET (FBTNCL,FBTDCL,FBTCLMTS,FBTNCLPD,FBTDCLPD,FBTNCLR,FBTDCLR,FBTNCLPN,FBTDCLPN,FBTREAS,FBNCLMS,FBDAYS,FBTDSUPD)=0
- +2 SET Y=FBSDT
- DO DD^%DT
- SET FBPSDT=Y
- +3 SET FBDA=""
- SET FBSDT=FBSDT-1
- +4 FOR
- SET FBSDT=$ORDER(^FB583("B",FBSDT))
- if FBSDT>FBEDT!(FBSDT="")
- QUIT
- Begin DoDot:1
- +5 FOR
- SET FBDA=$ORDER(^FB583("B",FBSDT,FBDA))
- if FBDA=""
- QUIT
- Begin DoDot:2
- +6 IF $PIECE($GET(^FB583(FBDA,0)),"^",28)'=1
- QUIT
- +7 SET FBUCL0=$GET(^FB583(FBDA,0))
- +8 SET FBTNCL=FBTNCL+1
- +9 SET FBAMTCL=$PIECE(FBUCL0,"^",9)
- +10 SET FBTDCL=FBTDCL+FBAMTCL
- +11 SET FBCLMT=$PIECE(FBUCL0,"^",23)
- +12 IF FBCLMT'=""
- IF ($DATA(^TMP($JOB,"FBUCMBS","CLMT",FBCLMT))=0)
- SET ^TMP($JOB,"FBUCMBS","CLMT",FBCLMT)=""
- SET FBTCLMTS=FBTCLMTS+1
- +13 SET FBDISPO=$PIECE(FBUCL0,"^",11)
- +14 IF FBDISPO=""
- SET FBTNCLPN=FBTNCLPN+1
- SET FBTDCLPN=FBTDCLPN+$PIECE(FBUCL0,"^",9)
- QUIT
- +15 IF $DATA(^FB(162.91,FBDISPO,0))=0
- SET FBTNCLPN=FBTNCLPN+1
- SET FBTDCLPN=FBTDCLPN+$PIECE(FBUCL0,"^",9)
- QUIT
- +16 SET FBDIS0=$PIECE($GET(^FB(162.91,FBDISPO,0)),"^",1)
- +17 IF $EXTRACT($PIECE(FBDIS0,"^",1),1,8)="APPROVED"
- Begin DoDot:3
- +18 SET FBPD1=$$AMTPD(FBDA)
- +19 SET FBTNCLPD=FBTNCLPD+1
- SET FBTDCLPD=FBTDCLPD+FBPD1
- SET FBTDSUPD=FBTDSUPD+FBAMTCL
- DO AVGTM
- End DoDot:3
- QUIT
- +20 SET FBTNCLR=FBTNCLR+1
- SET FBTDCLR=FBTDCLR+$PIECE(FBUCL0,"^",9)
- +21 DO REAS
- DO ADD
- DO STATUS
- DO AVGTM
- End DoDot:2
- End DoDot:1
- +22 DO PRT
- SET FBDENIAL=""
- DO DENIAL
- IF $DATA(FBQ)
- DO KIL
- QUIT
- +23 DO PAVG
- IF $DATA(FBQ)
- DO KIL
- QUIT
- +24 DO KIL
- +25 QUIT
- +26 ;
- REAS NEW X
- SET FBREAS=""
- +1 SET X=$ORDER(^FB583(FBDA,"D",0))
- +2 IF X
- SET X=+$GET(^FB583(FBDA,"D",X,0))
- +3 IF X
- SET FBREAS=$PIECE($GET(^FB(162.94,X,0)),"^")
- +4 SET FBREAS=$SELECT(FBREAS="":"OTHER",1:FBREAS)
- +5 QUIT
- ADD ;
- +1 IF $DATA(^TMP($JOB,"FBUCMBS","REAS",FBREAS))=1
- SET $PIECE(^TMP($JOB,"FBUCMBS","REAS",FBREAS),"^",1)=$PIECE(^TMP($JOB,"FBUCMBS","REAS",FBREAS),"^",1)+1
- QUIT
- +2 SET ^TMP($JOB,"FBUCMBS","REAS",FBREAS)=1
- +3 QUIT
- +4 ;
- STATUS IF $PIECE(FBUCL0,"^",24)=""
- QUIT
- +1 SET FBSIEN=$PIECE(FBUCL0,"^",24)
- +2 IF $DATA(^FB(162.92,FBSIEN,0))=0
- QUIT
- +3 IF $PIECE(^FB(162.92,FBSIEN,0),"^",1)["PENDING"
- SET FBTNCLPN=FBTNCLPN+1
- SET FBTDCLPN=FBTDCLPN+$PIECE(FBUCL0,"^",9)
- +4 QUIT
- +5 ;
- AVGTM ;
- +1 IF $PIECE(FBUCL0,"^",1)=""
- QUIT
- +2 IF $PIECE(FBUCL0,"^",12)=""
- QUIT
- +3 SET FBNCLMS=FBNCLMS+1
- SET X1=$PIECE(FBUCL0,"^",12)
- SET X2=$PIECE(FBUCL0,"^",1)
- DO ^%DTC
- SET FBDAYS=FBDAYS+X
- +4 QUIT
- +5 ;
- PRT ;
- +1 SET Y=DT
- DO DD^%DT
- SET FBPRDT=Y
- +2 SET Y=FBEDT
- DO DD^%DT
- SET FBPEDT=Y
- +3 WRITE @IOF,!,?25,"MILLENNIUM ACT EMERGENCY CARE"
- +4 SET FBTDSU=FBTDSUPD-FBTDCLPD
- +5 WRITE !,?32,"SUMMARY REPORT"
- +6 WRITE !,?23,FBPSDT," THROUGH ",FBPEDT
- +7 WRITE !,?29,"RUN DATE: ",FBPRDT,!!
- +8 WRITE !,"Total Number Claims Received: "
- SET X=FBTNCL
- SET X2=0
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- +9 WRITE !,"Total Dollars Claims Received: "
- SET X=FBTDCL
- SET X2="2$"
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- +10 WRITE !!,"Total Claimants: "
- SET X=FBTCLMTS
- SET X2=0
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- +11 WRITE !!,"Total Claims Paid: "
- SET X=FBTNCLPD
- SET X2=0
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- +12 WRITE !,"Total Dollars Claims Paid: "
- SET X=FBTDCLPD
- SET X2="2$"
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- +13 WRITE !!,"Total Dollars Suspended: "
- SET X=FBTDSU
- SET X2="2$"
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- +14 WRITE !!,"Total Number Claims Rejected: "
- SET X=FBTNCLR
- SET X2=0
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- +15 WRITE !,"Total Dollars Claims Rejected: "
- SET X=FBTDCLR
- SET X2="2$"
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X,!
- +16 WRITE !,?32,"REASONS REJECTED",!
- +17 QUIT
- +18 ;
- DENIAL FOR
- SET FBDENIAL=$ORDER(^TMP($JOB,"FBUCMBS","REAS",FBDENIAL))
- if FBDENIAL=""!($DATA(FBQ))
- QUIT
- Begin DoDot:1
- +1 WRITE !,?5,FBDENIAL,":"
- SET X=$PIECE(^TMP($JOB,"FBUCMBS","REAS",FBDENIAL),"^",1)
- SET X2=0
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- +2 IF $Y>(IOSL-2)
- DO PAUSE
- if $DATA(FBQ)
- QUIT
- +3 SET FBTREAS=FBTREAS+$PIECE(^TMP($JOB,"FBUCMBS","REAS",FBDENIAL),"^",1)
- End DoDot:1
- +4 QUIT
- +5 ;
- PAVG WRITE !,?59,"----------"
- IF $Y>(IOSL-2)
- DO PAUSE
- SET FBPSW=1
- if $DATA(FBQ)
- QUIT
- +1 SET X=FBTREAS
- SET X2=0
- SET X3=20
- DO COMMA^%DTC
- WRITE !,?50,X
- IF $Y>(IOSL-2)
- DO PAUSE
- SET FBPSW=1
- if $DATA(FBQ)
- QUIT
- +2 WRITE !!,"Total Number Claims Pending: "
- SET X=FBTNCLPN
- SET X2=0
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- IF $Y>(IOSL-2)
- DO PAUSE
- SET FBPSW=1
- if $DATA(FBQ)
- QUIT
- +3 WRITE !,"Total Dollars Claims Pending: "
- SET X=FBTDCLPN
- SET X2="2$"
- SET X3=20
- DO COMMA^%DTC
- WRITE ?50,X
- IF $Y>(IOSL-2)
- DO PAUSE
- SET FBPSW=1
- if $DATA(FBQ)
- QUIT
- +4 IF FBNCLMS=0
- WRITE !!,"Average Processing Time: ",$JUSTIFY(0,3,2)," Days"
- if $Y>(IOSL-14)
- DO PAUSE
- QUIT
- +5 SET FBAVGD=FBDAYS/FBNCLMS
- WRITE !!,"Average Processing Time: ",$JUSTIFY(FBAVGD,3,2)," Days"
- IF $Y>(IOSL-2)
- DO PAUSE
- SET FBPSW=1
- if $DATA(FBQ)
- QUIT
- +6 IF '$DATA(FBPSW)
- DO PAUSE
- +7 QUIT
- +8 ;
- KIL ;
- +1 KILL FBTNCL,FBTDCL,FBTCLMTS,FBTNCLPD,FBTDCLPD,FBTNCLR,FBTDCLR,FBTNCLPN,FBTDCLPN,FBTREAS,FBNCLMS,FBDAYS,FBPSDT,FBSDT,FBPEDT,FBEDT,FBDA,FBAMTCL,FBDISPO,FBREAS,FBSIEN
- +2 KILL %DT,%IS,POP,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK,FBAVGD,FBCLMT,FBCLMTS,FBDENIAL,FBPRDT,FBRDT,X,X1,X2,X3,Y,FBPSW,FBQ,DIR,DIRUT,DUOUT,FBPD1,FBTDSUPD,FBUCL0,FBDIS0,FBTDSU
- +3 KILL ^TMP($JOB)
- +4 DO ^%ZISC
- +5 QUIT
- +6 ;
- AMTPD(FBDA) ;Determine the amount paid an unauthorized claim
- +1 ;Input: FBDA -- IEN of record in the unauthorized claim file 162.7
- +2 ;Output: Amount paid, or 0 if the claim cannot be identified
- +3 ;
- +4 NEW FBTAMT,FBX,FBUCPAY,FBFILE,FBIENS,FBAMT
- +5 ;
- +6 ; - initialize total amount paid
- +7 SET FBTAMT=0
- +8 ;
- +9 ; - check for valid input
- +10 IF '$GET(^FB583(FBDA,0))
- GOTO AMTPDQ
- +11 ;
- +12 ; - get list of payments for the claim
- +13 SET FBX=$$PAYST^FBUCUTL(FBDA,"FBUCPAY")
- +14 ;
- +15 ; - loop thru payments to get total amount approved
- +16 SET FBTAMT=0
- +17 FOR FBFILE=162.03,162.11,162.5
- Begin DoDot:1
- +18 SET FBIENS=""
- FOR
- SET FBIENS=$ORDER(FBUCPAY(FBDA,FBFILE,FBIENS))
- if FBIENS=""
- QUIT
- Begin DoDot:2
- +19 IF FBFILE=162.03
- if $PIECE($GET(^FBAAC($PIECE(FBIENS,",",4),1,$PIECE(FBIENS,",",3),1,$PIECE(FBIENS,",",2),1,$PIECE(FBIENS,",",1),"FBREJ")),"^",1)'=""
- QUIT
- SET FBAMT=$$GET1^DIQ(FBFILE,FBIENS,2)
- +20 IF FBFILE=162.11
- if $PIECE($GET(^FBAA(162.1,$PIECE(FBIENS,",",2),"RX",$PIECE(FBIENS,",",1),"FBREJ")),"^",1)'=""
- QUIT
- SET FBAMT=$$GET1^DIQ(FBFILE,FBIENS,16.5)
- +21 IF FBFILE=162.5
- if $PIECE($GET(^FBAAI(+FBIENS,"FBREJ")),"^",1)'=""
- QUIT
- SET FBAMT=$$GET1^DIQ(FBFILE,FBIENS,8)
- +22 SET FBTAMT=FBTAMT+FBAMT
- End DoDot:2
- End DoDot:1
- +23 ;
- AMTPDQ QUIT FBTAMT
- +1 ;
- PAUSE ; - Page break
- +1 IF $EXTRACT(IOST,1,2)'="C-"
- QUIT
- +2 SET DIR(0)="E"
- DO ^DIR
- IF $DATA(DIRUT)
- SET FBQ=1
- QUIT
- +3 WRITE @IOF
- +4 QUIT