FBCHCR ;AISC/CMR-CIVIL HOSPITAL COST REPORT ;7/23/01
;;3.5;FEE BASIS;**32**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;FBTP SET IN OPTION ENTRANCE ACTION (6=CH/7=CNH)
;FBREF SET IN OPTION ENTRANCE ACTION (FBREF="FB7078" OR "FB583")
D DATE^FBAAUTL G END:FBPOP
; if UC ask if report for just mill-bill (1725) or just non-mill bill
S FB1725R=""
I FBTP=6,FBREF="FB583" S FB1725R=$$ASKMB^FBUCUTL9 I FB1725R="" G END
S DIR(0)="S^D:DETAILED REPORT;S:SUMMARY ONLY",DIR("A")="Choose Report Type",DIR("B")="S" D ^DIR K DIR G END:$D(DIRUT) S FBRT=Y W !
S VAR="BEGDATE^ENDDATE^FBTP^FBREF^FBRT^FB1725R",VAL=BEGDATE_"^"_ENDDATE_"^"_FBTP_"^"_FBREF_"^"_FBRT,PGM="START^FBCHCR",IOP="Q" D ZIS^FBAAUTL G END:FBPOP
START K ^TMP($J,"FBCHCR") S (FBIEN,FBCTR,FBTAMT,FBTLOS,FBAAOUT)=0,BEGDT=BEGDATE-1,Q="-",$P(Q,"-",30)="-",QQ="=",$P(QQ,"=",80)="="
F FBDT=BEGDT:0 S FBDT=$O(^FBAAI("AD",FBDT)) Q:FBDT'>0!(FBDT>ENDDATE) F S FBIEN=$O(^FBAAI("AD",FBDT,FBIEN)) Q:FBIEN'>0 S FBTYPE=$P($G(^FBAAI(FBIEN,0)),"^",12) I FBTYPE]"",(FBTP=FBTYPE) D
.S FBINV=^FBAAI(FBIEN,0),FBPTC=$P(FBINV,"^",19) S:FBPTC="" FBPTC="99" S @FBREF=$S($P(FBINV,"^",5)[FBREF:+$P(FBINV,"^",5),1:"") Q:@FBREF<1
.;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,"^",5)[FBREF S FB1725=+$P($G(^FB583(+$P(FBINV,U,5),0)),U,28) Q:$S(FB1725R="M"&'FB1725:1,FB1725R="N"&FB1725:1,1:0)
.S DFN=$P(FBINV,"^",4) Q:'$G(DFN) S FBNAME=$$NAME^FBCHREQ2(DFN),FBAMT=$P(FBINV,"^",9),FBDRG=$P(FBINV,"^",24),X1=$P(FBINV,"^",7),X2=$P(FBINV,"^",6) D ^%DTC S FBLOS=$S(X>0:X,1:1)
.I FBLOS>0 S FBSUM=$G(^TMP($J,"FBCHCR","SUM",FBPTC,FBLOS)),$P(FBSUM,"^")=($P(FBSUM,"^")+1),$P(FBSUM,"^",2)=($P(FBSUM,"^",2)+FBAMT) D
..S ^TMP($J,"FBCHCR","SUM",FBPTC,FBLOS)=FBSUM
.S ^TMP($J,"FBCHCR",FBPTC,FBNAME,@FBREF,"INV",FBIEN)=DFN_"^"_FBAMT_"^"_FBDRG_"^"_FBLOS
D ANCIL^FBCHCR1
U IO W:$E(IOST,1,2)["C-" @IOF I '$D(^TMP($J,"FBCHCR")) S FBEND=1 D HED W !!,"No payments found within specified timeframe!" G END
DETAIL S (FBIEN,FBPTC,FBREF1,DFN,FBAMT,FBLOS,FBANC,L,M,N)=0,(FBNAME,FBDRG,FBCHK)=""
I FBRT="D" D HED
F S FBPTC=$O(^TMP($J,"FBCHCR",FBPTC)) Q:FBPTC=""!(FBAAOUT) F S FBNAME=$O(^TMP($J,"FBCHCR",FBPTC,FBNAME)) Q:FBNAME=""!(FBAAOUT) F S FBREF1=$O(^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1)) Q:FBREF1'>0!(FBAAOUT) D
.I $D(^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"INV")) D
..F S FBIEN=$O(^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"INV",FBIEN)) Q:FBIEN=""!(FBAAOUT) S FBCTR=FBCTR+1 D
...S FBINV=^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"INV",FBIEN),DFN=+FBINV,FBAMT=$P(FBINV,"^",2),FBDRG=$P(FBINV,"^",3),FBLOS=$P(FBINV,"^",4),FBTAMT=FBTAMT+FBAMT,FBTLOS=FBTLOS+FBLOS D PRINT:FBRT="D"
.I $D(^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC")) F S L=$O(^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L)) Q:'L!(FBAAOUT) D
..F S M=$O(^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L,M)) Q:'M!(FBAAOUT) F S N=$O(^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L,M,N)) Q:'N!(FBAAOUT) D
...S FBANC=1,FBINV=^TMP($J,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L,M,N),DFN=+FBINV,FBAMT=$P(FBINV,"^",2),FBDRG="",FBLOS="" D PRINT:FBRT="D" S FBANC=0
G END:FBAAOUT I FBRT="D" W !!!,?22,"** Indicates an Ancillary Payment"
D SUMMARY^FBCHCR1
END K FBNAME,FBPTC,FBIEN,DFN,FBAMT,FBDRG,FBCHK,FBLOS,FB7078,FBANC,Q,QQ,FBCTR,FBTAMT,FBTLOS,FBDT,BEGDATE,ENDDATE,BEGDT,FBTP,FBTYPE,FBINV,FBAAOUT,I,J,K,L,M,N,FBJ,FBREF,FBREF1,FB583,FB7078,FBEND,FBSUM,FBSUM1,FBSUM2,FBRT,FB1725,FB1725R
K ^TMP($J,"FBCHCR") D CLOSE^FBAAUTL
Q
PRINT I $Y+5>IOSL W !!!?22,"** Indicates an Ancillary Payment"
D PGCHK Q:FBAAOUT
I FBPTC'=FBCHK D HED1 S FBCHK=FBPTC
W !,$E(FBNAME,1,23),?24,$$SSN^FBAAUTL(DFN),?40,$S(FBREF="FB7078":$P(^FB7078(FBREF1,0),"^"),1:$$DATX^FBAAUTL($P(^FB583(FBREF1,0),"^"))),?53,$S($G(FBAMT):$J($FN(FBAMT,",",2),10),1:""),?63,$S(FBANC:"**",1:""),?71,FBDRG,?75,$J(FBLOS,5)
Q
HED I FBREF="FB583" W !?22,$S(FB1725R="M":"MILL BILL (1725) ",FB1725R="N":" NON-MILL BILL ",1:" "),"UNAUTHORIZED CLAIMS"
W !,@$S(FBTP=6:"?25",1:"?22"),"COST REPORT FOR ",$S(FBTP=6:"CIVIL HOSPITAL",1:"CONTRACT NURSING HOME"),!?28,$$DATX^FBAAUTL(BEGDATE)," THROUGH ",$$DATX^FBAAUTL(ENDDATE),!,@$S(FBTP=6:"?25",1:"?22"),Q I FBTP=7 F J=1:1:7 W "-"
I $G(FBEND) D HED2 Q
W !!!,"PATIENT NAME",?25,"PATIENT ID"
I FBREF="FB583" W ?40,"DT CLAIM REC"
I FBREF="FB7078" W ?40,"ASSOC 7078"
W ?55,"AMT PAID",?66,"FINAL DRG",?77,"LOS",!,QQ
Q
HED1 W !!?5,"TREATING SPECIALTY: " F I=1:1:8 S J=$T(TEXT+I) I $P(J,";",3)=FBPTC W $P(J,";",4) Q
Q
HED2 W !!,?35,"SUMMARY",!!?22,"LOS",?40,"# CASES",?60,"AVE. AMT. PAID",!,QQ
Q
PGCHK 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
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[HFBCHCR 4970 printed Apr 09, 2024@21:01:01 Page 2
FBCHCR ;AISC/CMR-CIVIL HOSPITAL COST REPORT ;7/23/01
+1 ;;3.5;FEE BASIS;**32**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;FBTP SET IN OPTION ENTRANCE ACTION (6=CH/7=CNH)
+4 ;FBREF SET IN OPTION ENTRANCE ACTION (FBREF="FB7078" OR "FB583")
+5 DO DATE^FBAAUTL
if FBPOP
GOTO END
+6 ; if UC ask if report for just mill-bill (1725) or just non-mill bill
+7 SET FB1725R=""
+8 IF FBTP=6
IF FBREF="FB583"
SET FB1725R=$$ASKMB^FBUCUTL9
IF FB1725R=""
GOTO END
+9 SET DIR(0)="S^D:DETAILED REPORT;S:SUMMARY ONLY"
SET DIR("A")="Choose Report Type"
SET DIR("B")="S"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END
SET FBRT=Y
WRITE !
+10 SET VAR="BEGDATE^ENDDATE^FBTP^FBREF^FBRT^FB1725R"
SET VAL=BEGDATE_"^"_ENDDATE_"^"_FBTP_"^"_FBREF_"^"_FBRT
SET PGM="START^FBCHCR"
SET IOP="Q"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
START KILL ^TMP($JOB,"FBCHCR")
SET (FBIEN,FBCTR,FBTAMT,FBTLOS,FBAAOUT)=0
SET BEGDT=BEGDATE-1
SET Q="-"
SET $PIECE(Q,"-",30)="-"
SET QQ="="
SET $PIECE(QQ,"=",80)="="
+1 FOR FBDT=BEGDT:0
SET FBDT=$ORDER(^FBAAI("AD",FBDT))
if FBDT'>0!(FBDT>ENDDATE)
QUIT
FOR
SET FBIEN=$ORDER(^FBAAI("AD",FBDT,FBIEN))
if FBIEN'>0
QUIT
SET FBTYPE=$PIECE($GET(^FBAAI(FBIEN,0)),"^",12)
IF FBTYPE]""
IF (FBTP=FBTYPE)
Begin DoDot:1
+2 SET FBINV=^FBAAI(FBIEN,0)
SET FBPTC=$PIECE(FBINV,"^",19)
if FBPTC=""
SET FBPTC="99"
SET @FBREF=$SELECT($PIECE(FBINV,"^",5)[FBREF:+$PIECE(FBINV,"^",5),1:"")
if @FBREF<1
QUIT
+3 ;if UC and user requested just Mill Bill or just non-Mill Bill then
+4 ;check claim and skip when appropriate
+5 IF FBTP=6
IF FBREF="FB583"
IF "^M^N^"[(U_FB1725R_U)
IF $PIECE(FBINV,"^",5)[FBREF
SET FB1725=+$PIECE($GET(^FB583(+$PIECE(FBINV,U,5),0)),U,28)
if $SELECT(FB1725R="M"&'FB1725
QUIT
+6 SET DFN=$PIECE(FBINV,"^",4)
if '$GET(DFN)
QUIT
SET FBNAME=$$NAME^FBCHREQ2(DFN)
SET FBAMT=$PIECE(FBINV,"^",9)
SET FBDRG=$PIECE(FBINV,"^",24)
SET X1=$PIECE(FBINV,"^",7)
SET X2=$PIECE(FBINV,"^",6)
DO ^%DTC
SET FBLOS=$SELECT(X>0:X,1:1)
+7 IF FBLOS>0
SET FBSUM=$GET(^TMP($JOB,"FBCHCR","SUM",FBPTC,FBLOS))
SET $PIECE(FBSUM,"^")=($PIECE(FBSUM,"^")+1)
SET $PIECE(FBSUM,"^",2)=($PIECE(FBSUM,"^",2)+FBAMT)
Begin DoDot:2
+8 SET ^TMP($JOB,"FBCHCR","SUM",FBPTC,FBLOS)=FBSUM
End DoDot:2
+9 SET ^TMP($JOB,"FBCHCR",FBPTC,FBNAME,@FBREF,"INV",FBIEN)=DFN_"^"_FBAMT_"^"_FBDRG_"^"_FBLOS
End DoDot:1
+10 DO ANCIL^FBCHCR1
+11 USE IO
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
IF '$DATA(^TMP($JOB,"FBCHCR"))
SET FBEND=1
DO HED
WRITE !!,"No payments found within specified timeframe!"
GOTO END
DETAIL SET (FBIEN,FBPTC,FBREF1,DFN,FBAMT,FBLOS,FBANC,L,M,N)=0
SET (FBNAME,FBDRG,FBCHK)=""
+1 IF FBRT="D"
DO HED
+2 FOR
SET FBPTC=$ORDER(^TMP($JOB,"FBCHCR",FBPTC))
if FBPTC=""!(FBAAOUT)
QUIT
FOR
SET FBNAME=$ORDER(^TMP($JOB,"FBCHCR",FBPTC,FBNAME))
if FBNAME=""!(FBAAOUT)
QUIT
FOR
SET FBREF1=$ORDER(^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1))
if FBREF1'>0!(FBAAOUT)
QUIT
Begin DoDot:1
+3 IF $DATA(^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"INV"))
Begin DoDot:2
+4 FOR
SET FBIEN=$ORDER(^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"INV",FBIEN))
if FBIEN=""!(FBAAOUT)
QUIT
SET FBCTR=FBCTR+1
Begin DoDot:3
+5 SET FBINV=^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"INV",FBIEN)
SET DFN=+FBINV
SET FBAMT=$PIECE(FBINV,"^",2)
SET FBDRG=$PIECE(FBINV,"^",3)
SET FBLOS=$PIECE(FBINV,"^",4)
SET FBTAMT=FBTAMT+FBAMT
SET FBTLOS=FBTLOS+FBLOS
if FBRT="D"
DO PRINT
End DoDot:3
End DoDot:2
+6 IF $DATA(^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC"))
FOR
SET L=$ORDER(^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L))
if 'L!(FBAAOUT)
QUIT
Begin DoDot:2
+7 FOR
SET M=$ORDER(^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L,M))
if 'M!(FBAAOUT)
QUIT
FOR
SET N=$ORDER(^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L,M,N))
if 'N!(FBAAOUT)
QUIT
Begin DoDot:3
+8 SET FBANC=1
SET FBINV=^TMP($JOB,"FBCHCR",FBPTC,FBNAME,FBREF1,"ANC",L,M,N)
SET DFN=+FBINV
SET FBAMT=$PIECE(FBINV,"^",2)
SET FBDRG=""
SET FBLOS=""
if FBRT="D"
DO PRINT
SET FBANC=0
End DoDot:3
End DoDot:2
End DoDot:1
+9 if FBAAOUT
GOTO END
IF FBRT="D"
WRITE !!!,?22,"** Indicates an Ancillary Payment"
+10 DO SUMMARY^FBCHCR1
END KILL FBNAME,FBPTC,FBIEN,DFN,FBAMT,FBDRG,FBCHK,FBLOS,FB7078,FBANC,Q,QQ,FBCTR,FBTAMT,FBTLOS,FBDT,BEGDATE,ENDDATE,BEGDT,FBTP,FBTYPE,FBINV,FBAAOUT,I,J,K,L,M,N,FBJ,FBREF,FBREF1,FB583,FB7078,FBEND,FBSUM,FBSUM1,FBSUM2,FBRT,FB1725,FB1725R
+1 KILL ^TMP($JOB,"FBCHCR")
DO CLOSE^FBAAUTL
+2 QUIT
PRINT IF $Y+5>IOSL
WRITE !!!?22,"** Indicates an Ancillary Payment"
+1 DO PGCHK
if FBAAOUT
QUIT
+2 IF FBPTC'=FBCHK
DO HED1
SET FBCHK=FBPTC
+3 WRITE !,$EXTRACT(FBNAME,1,23),?24,$$SSN^FBAAUTL(DFN),?40,$SELECT(FBREF="FB7078":$PIECE(^FB7078(FBREF1,0),"^"),1:$$DATX^FBAAUTL($PIECE(^FB583(FBREF1,0),"^"))),?53,...
... $SELECT($GET(FBAMT):$JUSTIFY($FNUMBER(FBAMT,",",2),10),1:""),?63,$SELECT(FBANC:"**",1:""),?71,FBDRG,?75,$JUSTIFY(FBLOS,5)
+4 QUIT
HED IF FBREF="FB583"
WRITE !?22,$SELECT(FB1725R="M":"MILL BILL (1725) ",FB1725R="N":" NON-MILL BILL ",1:" "),"UNAUTHORIZED CLAIMS"
+1 WRITE !,@$SELECT(FBTP=6:"?25",1:"?22"),"COST REPORT FOR ",$SELECT(FBTP=6:"CIVIL HOSPITAL",1:"CONTRACT NURSING HOME"),!?28,$$DATX^FBAAUTL(BEGDATE)," THROUGH ",$$DATX^FBAAUTL(ENDDATE),!,@$SELECT(FBTP=6:"?25",1:"?22"),Q
IF FBTP=7
FOR J=1:1:7
WRITE "-"
+2 IF $GET(FBEND)
DO HED2
QUIT
+3 WRITE !!!,"PATIENT NAME",?25,"PATIENT ID"
+4 IF FBREF="FB583"
WRITE ?40,"DT CLAIM REC"
+5 IF FBREF="FB7078"
WRITE ?40,"ASSOC 7078"
+6 WRITE ?55,"AMT PAID",?66,"FINAL DRG",?77,"LOS",!,QQ
+7 QUIT
HED1 WRITE !!?5,"TREATING SPECIALTY: "
FOR I=1:1:8
SET J=$TEXT(TEXT+I)
IF $PIECE(J,";",3)=FBPTC
WRITE $PIECE(J,";",4)
QUIT
+1 QUIT
HED2 WRITE !!,?35,"SUMMARY",!!?22,"LOS",?40,"# CASES",?60,"AVE. AMT. PAID",!,QQ
+1 QUIT
PGCHK 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
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
