40 lines
3.0 KiB
Mathematica
40 lines
3.0 KiB
Mathematica
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
|