FBAACR ;AISC/CMR-OPT MED Cost Report ;6/1/1999
;;3.5;FEE BASIS;**4,77**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
D DATE^FBAAUTL Q:FBPOP
S VAR="BEGDATE^ENDDATE",VAL=BEGDATE_"^"_ENDDATE,PGM="START^FBAACR" D ZIS^FBAAUTL G END:FBPOP
START K ^TMP($J,"FBAACR") S (FBAAOUT,DFN,FBA,FBB,FBC)=0,BEGDT=BEGDATE-1,Q="-",$P(Q,"-",25)="-",QQ="=",$P(QQ,"=",80)="=" U IO W:$E(IOST,1,2)["C-" @IOF D HED
F FBDT=BEGDT:0 S FBDT=$O(^FBAAC("AK",FBDT)) Q:FBDT'>0!(FBDT>ENDDATE) F S DFN=$O(^FBAAC("AK",FBDT,DFN)) Q:DFN'>0 F S FBA=$O(^FBAAC("AK",FBDT,DFN,FBA)) Q:FBA'>0 D
.F S FBB=$O(^FBAAC("AK",FBDT,DFN,FBA,FBB)) Q:FBB'>0 F S FBC=$O(^FBAAC("AK",FBDT,DFN,FBA,FBB,FBC)) Q:FBC'>0 S FBPMT=^FBAAC(DFN,1,FBA,1,FBB,1,FBC,0),FBSRVDT=+$G(^FBAAC(DFN,1,FBA,1,FBB,0)) I $P(FBPMT,"^",13)="" D
..S FBPTC=$P(FBPMT,"^",17),FBAMT=$P(FBPMT,"^",3),FBNAME=$$NAME^FBCHREQ2(DFN),FBCPT=$P(FBPMT,"^"),^TMP($J,"FBAACR",FBNAME)=DFN,^TMP($J,"FBAACR",FBNAME,FBA,FBB,FBC)=FBPTC_"^"_FBAMT_"^"_FBCPT_"^"_FBSRVDT
S (FBNAME,FBNM)="",(FBA,FBB,FBC,DFN,FBPTC,FBAMT,FBPAMT,FBTAMT,FBCPT,FBCTR,FBTPT)=0
F S FBNAME=$O(^TMP($J,"FBAACR",FBNAME)) Q:FBNAME=""!(FBAAOUT) S DFN=+^TMP($J,"FBAACR",FBNAME) S FBTPT=FBTPT+1,FBPCTR=0 D D PSUM
.F S FBA=$O(^TMP($J,"FBAACR",FBNAME,FBA)) Q:FBA'>0!(FBAAOUT) F S FBB=$O(^TMP($J,"FBAACR",FBNAME,FBA,FBB)) Q:FBB'>0!(FBAAOUT) F S FBC=$O(^TMP($J,"FBAACR",FBNAME,FBA,FBB,FBC)) Q:FBC'>0!(FBAAOUT) S FBCTR=FBCTR+1,FBPCTR=FBPCTR+1 D
..S FBPMT=^TMP($J,"FBAACR",FBNAME,FBA,FBB,FBC),FBPTC=$P(FBPMT,"^"),FBAMT=$P(FBPMT,"^",2),FBCPT=$$CPT^FBAAUTL4(+$P(FBPMT,"^",3),1,+$P(FBPMT,"^",4)),FBPAMT=FBPAMT+FBAMT,FBTAMT=FBTAMT+FBAMT D PRINT
G END:FBAAOUT
W !!,QQ,!!,"TOTAL PAYMENTS: ",?25,$J(FBCTR,7),?40,"TOTAL PATIENTS: ",?65,$J(FBTPT,7),!,"AVE. PAID FOR A PAYMENT:",?25 W:FBCTR>0 $J($FN(FBTAMT/FBCTR,",",2),10) W ?40,"AVE. PAID FOR A PATIENT:",?65 W:FBTPT>0 $J($FN(FBTAMT/FBTPT,",",2),10)
END K FBSRVDT,FBPMT,FBNAME,DFN,FBAAOUT,FBA,FBB,FBC,FBAMT,FBPTC,FBPAMT,FBTAMT,FBCTR,FBDT,FBCPT,FBNM,FBPCTR,FBPTC1,FBTPT,BEGDT,BEGDATE,ENDDATE,J,Q,QQ,^TMP($J,"FBAACR") D CLOSE^FBAAUTL
Q
PRINT D CHK Q:FBAAOUT S FBPTC1=""
S:FBPTC="" FBPTC="99" F I=1:1:8 S J=$T(TEXT+I) I $P(J,";;",2)=FBPTC S FBPTC1=$P(J,";;",3) Q
I FBNAME=FBNM W !?30,$E(FBPTC1,1,16),?48,$E(FBCPT,1,20),?70,$J($FN(FBAMT,",",2),10)
I FBNAME'=FBNM W !!,$E(FBNAME,1,20),?22,$$SSN^FBAAUTL(DFN,1),?30,$E(FBPTC1,1,16),?48,$E(FBCPT,1,20),?70,$J($FN(FBAMT,",",2),10) S FBNM=FBNAME
Q
HED W !?25,"OUTPATIENT COST REPORT",!?24,$$DATX^FBAAUTL(BEGDATE)," THROUGH ",$$DATX^FBAAUTL(ENDDATE),!,?24,Q,!!!,?21,"PATIENT",?31,"TREATING",!,"PATIENT NAME",?21," ID",?31,"SPECIALTY",?52,"CPT CODE",?69,"AMOUNT PAID",!,QQ
Q
CHK I $Y+5>IOSL,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
I $Y+5>IOSL W @IOF D HED
Q
PSUM W !?70,"----------",!?70,$J($FN(FBPAMT,",",2),10)
S FBPAMT=0
Q
TEXT ;
;;00;;SURGICAL
;;10;;MEDICAL
;;60;;HOME NURSING SERVICE
;;85;;PSYCHIATRIC-CONTRACT
;;86;;PSYCHIATRIC
;;95;;NEUROLOGICAL-CONTRACT
;;96;;NEUROLOGICAL
;;99;;UNKNOWN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACR 3079 printed Sep 23, 2025@19:31:18 Page 2
FBAACR ;AISC/CMR-OPT MED Cost Report ;6/1/1999
+1 ;;3.5;FEE BASIS;**4,77**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO DATE^FBAAUTL
if FBPOP
QUIT
+4 SET VAR="BEGDATE^ENDDATE"
SET VAL=BEGDATE_"^"_ENDDATE
SET PGM="START^FBAACR"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
START KILL ^TMP($JOB,"FBAACR")
SET (FBAAOUT,DFN,FBA,FBB,FBC)=0
SET BEGDT=BEGDATE-1
SET Q="-"
SET $PIECE(Q,"-",25)="-"
SET QQ="="
SET $PIECE(QQ,"=",80)="="
USE IO
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
DO HED
+1 FOR FBDT=BEGDT:0
SET FBDT=$ORDER(^FBAAC("AK",FBDT))
if FBDT'>0!(FBDT>ENDDATE)
QUIT
FOR
SET DFN=$ORDER(^FBAAC("AK",FBDT,DFN))
if DFN'>0
QUIT
FOR
SET FBA=$ORDER(^FBAAC("AK",FBDT,DFN,FBA))
if FBA'>0
QUIT
Begin DoDot:1
+2 FOR
SET FBB=$ORDER(^FBAAC("AK",FBDT,DFN,FBA,FBB))
if FBB'>0
QUIT
FOR
SET FBC=$ORDER(^FBAAC("AK",FBDT,DFN,FBA,FBB,FBC))
if FBC'>0
QUIT
SET FBPMT=^FBAAC(DFN,1,FBA,1,FBB,1,FBC,0)
SET FBSRVDT=+$GET(^FBAAC(DFN,1,FBA,1,FBB,0))
IF $PIECE(FBPMT,"^",13)=""
Begin DoDot:2
+3 SET FBPTC=$PIECE(FBPMT,"^",17)
SET FBAMT=$PIECE(FBPMT,"^",3)
SET FBNAME=$$NAME^FBCHREQ2(DFN)
SET FBCPT=$PIECE(FBPMT,"^")
SET ^TMP($JOB,"FBAACR",FBNAME)=DFN
SET ^TMP($JOB,"FBAACR",FBNAME,FBA,FBB,FBC)=FBPTC_"^"_FBAMT_"^"_FBCPT_"^"_FBSRVDT
End DoDot:2
End DoDot:1
+4 SET (FBNAME,FBNM)=""
SET (FBA,FBB,FBC,DFN,FBPTC,FBAMT,FBPAMT,FBTAMT,FBCPT,FBCTR,FBTPT)=0
+5 FOR
SET FBNAME=$ORDER(^TMP($JOB,"FBAACR",FBNAME))
if FBNAME=""!(FBAAOUT)
QUIT
SET DFN=+^TMP($JOB,"FBAACR",FBNAME)
SET FBTPT=FBTPT+1
SET FBPCTR=0
Begin DoDot:1
+6 FOR
SET FBA=$ORDER(^TMP($JOB,"FBAACR",FBNAME,FBA))
if FBA'>0!(FBAAOUT)
QUIT
FOR
SET FBB=$ORDER(^TMP($JOB,"FBAACR",FBNAME,FBA,FBB))
if FBB'>0!(FBAAOUT)
QUIT
FOR
SET FBC=$ORDER(^TMP($JOB,"FBAACR",FBNAME,FBA,FBB,FBC))
if FBC'>0!(FBAAOUT)
QUIT
SET FBCTR=FBCTR+1
SET FBPCTR=FBPCTR+1
Begin DoDot:2
+7 SET FBPMT=^TMP($JOB,"FBAACR",FBNAME,FBA,FBB,FBC)
SET FBPTC=$PIECE(FBPMT,"^")
SET FBAMT=$PIECE(FBPMT,"^",2)
SET FBCPT=$$CPT^FBAAUTL4(+$PIECE(FBPMT,"^",3),1,+$PIECE(FBPMT,"^",4))
SET FBPAMT=FBPAMT+FBAMT
SET FBTAMT=FBTAMT+FBAMT
DO PRINT
End DoDot:2
End DoDot:1
DO PSUM
+8 if FBAAOUT
GOTO END
+9 WRITE !!,QQ,!!,"TOTAL PAYMENTS: ",?25,$JUSTIFY(FBCTR,7),?40,"TOTAL PATIENTS: ",?65,$JUSTIFY(FBTPT,7),!,"AVE. PAID FOR A PAYMENT:",?25
if FBCTR>0
WRITE $JUSTIFY($FNUMBER(FBTAMT/FBCTR,",",2),10)
WRITE ?40,"AVE. PAID FOR A PATIENT:",?65
if FBTPT>0
WRITE $JUSTIFY($FNUMBER(FBTAMT/FBTPT,",",2),10)
END KILL FBSRVDT,FBPMT,FBNAME,DFN,FBAAOUT,FBA,FBB,FBC,FBAMT,FBPTC,FBPAMT,FBTAMT,FBCTR,FBDT,FBCPT,FBNM,FBPCTR,FBPTC1,FBTPT,BEGDT,BEGDATE,ENDDATE,J,Q,QQ,^TMP($JOB,"FBAACR")
DO CLOSE^FBAAUTL
+1 QUIT
PRINT DO CHK
if FBAAOUT
QUIT
SET FBPTC1=""
+1 if FBPTC=""
SET FBPTC="99"
FOR I=1:1:8
SET J=$TEXT(TEXT+I)
IF $PIECE(J,";;",2)=FBPTC
SET FBPTC1=$PIECE(J,";;",3)
QUIT
+2 IF FBNAME=FBNM
WRITE !?30,$EXTRACT(FBPTC1,1,16),?48,$EXTRACT(FBCPT,1,20),?70,$JUSTIFY($FNUMBER(FBAMT,",",2),10)
+3 IF FBNAME'=FBNM
WRITE !!,$EXTRACT(FBNAME,1,20),?22,$$SSN^FBAAUTL(DFN,1),?30,$EXTRACT(FBPTC1,1,16),?48,$EXTRACT(FBCPT,1,20),?70,$JUSTIFY($FNUMBER(FBAMT,",",2),10)
SET FBNM=FBNAME
+4 QUIT
HED WRITE !?25,"OUTPATIENT COST REPORT",!?24,$$DATX^FBAAUTL(BEGDATE)," THROUGH ",$$DATX^FBAAUTL(ENDDATE),!,?24,Q,!!!,?21,"PATIENT",?31,"TREATING",!,"PATIENT NAME",?21," ID",?31,"SPECIALTY",?52,"CPT CODE",?69,"AMOUNT PAID",!,QQ
+1 QUIT
CHK IF $Y+5>IOSL
IF $EXTRACT(IOST,1,2)["C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBAAOUT=1
QUIT
+1 IF $Y+5>IOSL
WRITE @IOF
DO HED
+2 QUIT
PSUM WRITE !?70,"----------",!?70,$JUSTIFY($FNUMBER(FBPAMT,",",2),10)
+1 SET FBPAMT=0
+2 QUIT
TEXT ;
+1 ;;00;;SURGICAL
+2 ;;10;;MEDICAL
+3 ;;60;;HOME NURSING SERVICE
+4 ;;85;;PSYCHIATRIC-CONTRACT
+5 ;;86;;PSYCHIATRIC
+6 ;;95;;NEUROLOGICAL-CONTRACT
+7 ;;96;;NEUROLOGICAL
+8 ;;99;;UNKNOWN
