FBCHCR1 ;AISC/CMR-CH & CNH COST REPORT CONT. ;7/4/01
 ;;3.5;FEE BASIS;**32**;JAN 30, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
ANCIL S J="",(K,L,M,N)=0,FBDT=BEGDATE
 F  S J=$O(^FBAAC("AM",J)) Q:J=""  I J[FBREF F  S K=$O(^FBAAC("AM",J,K)) Q:K'>0  F  S L=$O(^FBAAC("AM",J,K,L)) Q:L'>0  F  S M=$O(^FBAAC("AM",J,K,L,M)) Q:M'>0  F  S N=$O(^FBAAC("AM",J,K,L,M,N)) Q:N'>0  D
 .S FBINV=$G(^FBAAC(K,1,L,1,M,1,N,0))
 .I $P(FBINV,"^",9)=FBTP,$P(FBINV,"^",6)>(FBDT-1),$P(FBINV,"^",6)<(ENDDATE+1) D
 ..;if UC and user requested just Mill Bill or just non-Mill Bill then
 ..;check claim and skip when appropriate
 ..I FBTP=6,FBREF="FB583","^M^N^"[(U_FB1725R_U),$P(FBINV,"^",13)[FBREF S FB1725=+$P($G(^FB583(+$P(FBINV,U,13),0)),U,28) Q:$S(FB1725R="M"&'FB1725:1,FB1725R="N"&FB1725:1,1:0)
 ..S FBPTC=$P(FBINV,"^",17) S:FBPTC="" FBPTC="99" S DFN=K,FBNAME=$$NAME^FBCHREQ2(DFN),FBAMT=$P(FBINV,"^",3),FBREF1=$P(J,";")
 ..S FBSUM=$G(^TMP($J,"FBCHCR","SUM","ANC")),$P(FBSUM,"^")=($P(FBSUM,"^")+1),$P(FBSUM,"^",2)=($P(FBSUM,"^",2)+FBAMT) S ^TMP($J,"FBCHCR","SUM","ANC")=FBSUM
 ..S ^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L,M,N)=DFN_"^"_FBAMT_"^^"
 Q
SUMMARY I FBRT="D",($E(IOST,1,2)["C-") S DIR(0)="E" D ^DIR K DIR Q:'Y
 W @IOF S FBEND=1 D HED^FBCHCR
 S (FBPTC,FBLOS)=0,FBCHK=""
 F  S FBPTC=$O(^TMP($J,"FBCHCR","SUM",FBPTC)) Q:FBPTC=""!(FBAAOUT)  F  S FBLOS=$O(^TMP($J,"FBCHCR","SUM",FBPTC,FBLOS)) Q:FBLOS=""!(FBAAOUT)  S FBSUM=^(FBLOS),FBSUM1=+FBSUM,FBSUM2=$P(FBSUM,"^",2) D
 .D PGCHK^FBCHCR Q:$G(FBAAOUT)
 .I FBPTC'=FBCHK D HED1^FBCHCR S FBCHK=FBPTC
 .W !?20,$J(FBLOS,5),?40,$J(FBSUM1,5),?60,$J((FBSUM2/FBSUM1),10,2)
 W !!,QQ,!!?4,"TOTAL CASES:  ",FBCTR,?24,"AVERAGE AMOUNT PAID:  ",$S($G(FBTAMT):$FN((FBTAMT/FBCTR),",",2),1:""),?56,"AVERAGE LOS:  ",$S($G(FBTLOS):$FN((FBTLOS/FBCTR),",",2),1:"")
 I $D(^TMP($J,"FBCHCR","SUM","ANC")) S FBSUM=^("ANC"),FBSUM1=+FBSUM,FBSUM2=$P(FBSUM,"^",2) W !!?4,"TOTAL ANCILLARY PAYMENTS:  ",$J(FBSUM1,5),?40,"AVERAGE AMOUNT PAID:  ",$J((FBSUM2/FBSUM1),10,2)
 Q