- 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 Mar 13, 2025@20:59:57 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
