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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHCR1 2031 printed Sep 23, 2025@19:33:40 Page 2
FBCHCR1 ;AISC/CMR-CH & CNH COST REPORT CONT. ;7/4/01
+1 ;;3.5;FEE BASIS;**32**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
ANCIL SET J=""
SET (K,L,M,N)=0
SET FBDT=BEGDATE
+1 FOR
SET J=$ORDER(^FBAAC("AM",J))
if J=""
QUIT
IF J[FBREF
FOR
SET K=$ORDER(^FBAAC("AM",J,K))
if K'>0
QUIT
FOR
SET L=$ORDER(^FBAAC("AM",J,K,L))
if L'>0
QUIT
FOR
SET M=$ORDER(^FBAAC("AM",J,K,L,M))
if M'>0
QUIT
FOR
SET N=$ORDER(^FBAAC("AM",J,K,L,M,N))
if N'>0
QUIT
Begin DoDot:1
+2 SET FBINV=$GET(^FBAAC(K,1,L,1,M,1,N,0))
+3 IF $PIECE(FBINV,"^",9)=FBTP
IF $PIECE(FBINV,"^",6)>(FBDT-1)
IF $PIECE(FBINV,"^",6)<(ENDDATE+1)
Begin DoDot:2
+4 ;if UC and user requested just Mill Bill or just non-Mill Bill then
+5 ;check claim and skip when appropriate
+6 IF FBTP=6
IF FBREF="FB583"
IF "^M^N^"[(U_FB1725R_U)
IF $PIECE(FBINV,"^",13)[FBREF
SET FB1725=+$PIECE($GET(^FB583(+$PIECE(FBINV,U,13),0)),U,28)
if $SELECT(FB1725R="M"&'FB1725
QUIT
+7 SET FBPTC=$PIECE(FBINV,"^",17)
if FBPTC=""
SET FBPTC="99"
SET DFN=K
SET FBNAME=$$NAME^FBCHREQ2(DFN)
SET FBAMT=$PIECE(FBINV,"^",3)
SET FBREF1=$PIECE(J,";")
+8 SET FBSUM=$GET(^TMP($JOB,"FBCHCR","SUM","ANC"))
SET $PIECE(FBSUM,"^")=($PIECE(FBSUM,"^")+1)
SET $PIECE(FBSUM,"^",2)=($PIECE(FBSUM,"^",2)+FBAMT)
SET ^TMP($JOB,"FBCHCR","SUM","ANC")=FBSUM
+9 SET ^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L,M,N)=DFN_"^"_FBAMT_"^^"
End DoDot:2
End DoDot:1
+10 QUIT
SUMMARY IF FBRT="D"
IF ($EXTRACT(IOST,1,2)["C-")
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
QUIT
+1 WRITE @IOF
SET FBEND=1
DO HED^FBCHCR
+2 SET (FBPTC,FBLOS)=0
SET FBCHK=""
+3 FOR
SET FBPTC=$ORDER(^TMP($JOB,"FBCHCR","SUM",FBPTC))
if FBPTC=""!(FBAAOUT)
QUIT
FOR
SET FBLOS=$ORDER(^TMP($JOB,"FBCHCR","SUM",FBPTC,FBLOS))
if FBLOS=""!(FBAAOUT)
QUIT
SET FBSUM=^(FBLOS)
SET FBSUM1=+FBSUM
SET FBSUM2=$PIECE(FBSUM,"^",2)
Begin DoDot:1
+4 DO PGCHK^FBCHCR
if $GET(FBAAOUT)
QUIT
+5 IF FBPTC'=FBCHK
DO HED1^FBCHCR
SET FBCHK=FBPTC
+6 WRITE !?20,$JUSTIFY(FBLOS,5),?40,$JUSTIFY(FBSUM1,5),?60,$JUSTIFY((FBSUM2/FBSUM1),10,2)
End DoDot:1
+7 WRITE !!,QQ,!!?4,"TOTAL CASES: ",FBCTR,?24,"AVERAGE AMOUNT PAID: ",$SELECT($GET(FBTAMT):$FNUMBER((FBTAMT/FBCTR),",",2),1:""),?56,"AVERAGE LOS: ",$SELECT($GET(FBTLOS):$FNUMBER((FBTLOS/FBCTR),",",2),1:"")
+8 IF $DATA(^TMP($JOB,"FBCHCR","SUM","ANC"))
SET FBSUM=^("ANC")
SET FBSUM1=+FBSUM
SET FBSUM2=$PIECE(FBSUM,"^",2)
WRITE !!?4,"TOTAL ANCILLARY PAYMENTS: ",$JUSTIFY(FBSUM1,5),?40,"AVERAGE AMOUNT PAID: ",$JUSTIFY((FBSUM2/FBSUM1),10,2)
+9 QUIT
