- 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 Mar 13, 2025@21:02:18 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
