- 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 Jan 18, 2025@02:58:47 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