- FBUCSTAT ;AISC/DMK-UNAUTHORIZED CLAIM STATS ;6/27/01
- ;;3.5;FEE BASIS;**32,64**;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- N FBPOP,PGM,Q,VAL,VAR S Q="",$P(Q,"-",80)="-"
- W !!?14,"UNAUTHORIZED CLAIM DISPOSITION AND STATUS STATISTICS",!?14,$E(Q,1,52),!
- ; ask if report for just mill-bill (1725) or just non-mill bill claims
- S FB1725R=$$ASKMB^FBUCUTL9 I FB1725R="" G END
- D DATE^FBAAUTL G END:FBPOP S FBBEG=BEGDATE,FBEND=ENDDATE
- S VAR="FBBEG^FBEND^FB1725R",VAL=FBBEG_"^"_FBEND,PGM="START^FBUCSTAT" D ZIS^FBAAUTL G END:FBPOP
- START ;Entry point for tasked job
- U IO S Q="",$P(Q,"-",80)="-"
- S Y=FBBEG D PDF^FBAAUTL S FBSTART=Y,Y=FBEND D PDF^FBAAUTL S FBFINISH=Y D HED
- S FBD(99)=0 F I=1:1:5 S FBD(I)=0 F J=40,70,90 S FBD(I,J)=0
- F I=5,10,20,30,50,55,60,80 S FBD(99,I)=0
- S FBUC=$$FBUC^FBUCUTL2(1)
- S FBBEG=FBBEG-.1 F I=FBBEG:0 S I=$O(^FB583("B",I)) Q:I'>0!(I>FBEND) F J=0:0 S J=$O(^FB583("B",I,J)) Q:J'>0 I $D(^FB583(J,0)) S FB(0)=^(0),FBS=$$ORDER^FBUCUTL(+$P(FB(0),"^",24)) I FBS D
- .; if user requested just mill-bill (1725) or non-mill bill claims then
- .; check claim and skip when appropriate
- .Q:$S(FB1725R="M"&'+$P(FB(0),U,28):1,FB1725R="N"&+$P(FB(0),U,28):1,1:0)
- .S FBD=+$P(FB(0),"^",11) S PSA=+$P(FB(0),"^",7) S:PSA=0 PSA="OTHER" S:'$D(FB(PSA)) FB(PSA)=0
- .I "^5^10^30^50^55^60^80^"[(U_FBS_U) S FBD(99,FBS)=FBD(99,FBS)+1,FBD(99)=FBD(99)+1
- .I "^40^70^90^"[(U_FBS_U) Q:'FBD S FBD(FBD,FBS)=FBD(FBD,FBS)+1,FBD(FBD)=FBD(FBD)+1
- .;Q:'$$PAY^FBUCUTL(J,"FB583")
- .S FB("PD")=$$AMTPD^FBUCMBS(J)
- .S FB(PSA)=FB(PSA)+FB("PD")
- W !?50,"CATEGORY OF DISPOSITION",!?3,"TYPE OF",?31,"# OF",!?3,"DISPOSITION",?31,"CLAIMS",?45,"INITIAL",?57,"APPEAL",?69,"COVA APPEAL",!,Q,!
- S FBD=0,FB="0^0^0^0"
- F S FBD=$O(^FB(162.91,FBD)) Q:FBD'>0 I $D(^FB(162.91,FBD,0)) W !,?3,$P(^(0),"^"),?32,$J(FBD(FBD),5) S $P(FB,"^")=$P(FB,"^")+FBD(FBD),FBS=0 D
- .F S FBS=$O(FBD(FBD,FBS)) Q:FBS'>0 W ?$S(FBS=40:45,FBS=70:57,1:69),$J(FBD(FBD,FBS),5) S X=$S(FBS=40:2,FBS=70:3,1:4),$P(FB,"^",X)=$P(FB,"^",X)+FBD(FBD,FBS)
- W !,?32,"-----",?45,"-----",?57,"-----",?69,"-----",!?9,"TOTAL DISPOSITIONED",?32,$J($P(FB,"^"),5),?45,$J($P(FB,"^",2),5),?57,$J($P(FB,"^",3),5),?69,$J($P(FB,"^",4),5)
- W !?5,"TOTAL NOT DISPOSITIONED",?32,$J(FBD(99),5),!?32,"-----",!?16,"TOTAL CLAIMS",?32,$J(FB+FBD(99),5)
- I $P(IOST,"-")="C" W ! D HANG^FBAAUTL1 G END:$D(DIRUT) D HED
- W !!?3,"STATUS OF CLAIMS NOT DISPOSITIONED",!!?3,"STATUS",?40,"# OF CLAIMS",!
- S FBS=0 F S FBS=$O(FBD(99,FBS)) Q:FBS'>0 D
- .I FBS=5,'$P(FBUC,U,7)&(FBD(99,FBS)=0) Q
- .W !?3,$P($G(^FB(162.92,$$STATUS^FBUCUTL(FBS),0)),"^"),?40,$J(FBD(99,FBS),5)
- I $P(IOST,"-")="C" W ! D HANG^FBAAUTL1 G END:$D(DIRUT) D HED
- W !!?3,"TOTAL DOLLARS APPROVED BY PSA:",!
- S FB=0,PSA=0 F S PSA=$O(FB(PSA)) Q:PSA="PD"!(PSA="") W !?3,$P($G(^DIC(4,PSA,0)),"^") W:PSA="OTHER" PSA S X=FB(PSA),X2="2$",FB=FB+X D COMMA^%DTC W ?34,X
- S X=FB,X2="2$",Y="" D COMMA^%DTC W !?32,"-------------",!?34,X
- END K DIRUT,I,J,Q,X,X2,PSA,FBBEG,FBEND,FBSTART,FBFINISH,FBD,FBUC,BEGDATE,ENDDATE,Y,FBS,FB1725R,FB
- D CLOSE^FBAAUTL Q
- HED W:$P(IOST,"-")="C" @IOF W !?14,"UNAUTHORIZED CLAIM DISPOSITION AND STATUS STATISTICS",!?14,$E(Q,1,52)
- MB I FB1725R'="A" W !?17,$S(FB1725R="M":"for 38 U.S.C. 1725 Claims",1:"excluding 38 U.S.C. 1725 Claims")
- DAT W !?17,"Date Range Selected: ",FBSTART," to ",FBFINISH,!?17,$E(Q,1,41),!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCSTAT 3390 printed Mar 13, 2025@21:05:20 Page 2
- FBUCSTAT ;AISC/DMK-UNAUTHORIZED CLAIM STATS ;6/27/01
- +1 ;;3.5;FEE BASIS;**32,64**;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 NEW FBPOP,PGM,Q,VAL,VAR
- SET Q=""
- SET $PIECE(Q,"-",80)="-"
- +4 WRITE !!?14,"UNAUTHORIZED CLAIM DISPOSITION AND STATUS STATISTICS",!?14,$EXTRACT(Q,1,52),!
- +5 ; ask if report for just mill-bill (1725) or just non-mill bill claims
- +6 SET FB1725R=$$ASKMB^FBUCUTL9
- IF FB1725R=""
- GOTO END
- +7 DO DATE^FBAAUTL
- if FBPOP
- GOTO END
- SET FBBEG=BEGDATE
- SET FBEND=ENDDATE
- +8 SET VAR="FBBEG^FBEND^FB1725R"
- SET VAL=FBBEG_"^"_FBEND
- SET PGM="START^FBUCSTAT"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO END
- START ;Entry point for tasked job
- +1 USE IO
- SET Q=""
- SET $PIECE(Q,"-",80)="-"
- +2 SET Y=FBBEG
- DO PDF^FBAAUTL
- SET FBSTART=Y
- SET Y=FBEND
- DO PDF^FBAAUTL
- SET FBFINISH=Y
- DO HED
- +3 SET FBD(99)=0
- FOR I=1:1:5
- SET FBD(I)=0
- FOR J=40,70,90
- SET FBD(I,J)=0
- +4 FOR I=5,10,20,30,50,55,60,80
- SET FBD(99,I)=0
- +5 SET FBUC=$$FBUC^FBUCUTL2(1)
- +6 SET FBBEG=FBBEG-.1
- FOR I=FBBEG:0
- SET I=$ORDER(^FB583("B",I))
- if I'>0!(I>FBEND)
- QUIT
- FOR J=0:0
- SET J=$ORDER(^FB583("B",I,J))
- if J'>0
- QUIT
- IF $DATA(^FB583(J,0))
- SET FB(0)=^(0)
- SET FBS=$$ORDER^FBUCUTL(+$PIECE(FB(0),"^",24))
- IF FBS
- Begin DoDot:1
- +7 ; if user requested just mill-bill (1725) or non-mill bill claims then
- +8 ; check claim and skip when appropriate
- +9 if $SELECT(FB1725R="M"&'+$PIECE(FB(0),U,28)
- QUIT
- +10 SET FBD=+$PIECE(FB(0),"^",11)
- SET PSA=+$PIECE(FB(0),"^",7)
- if PSA=0
- SET PSA="OTHER"
- if '$DATA(FB(PSA))
- SET FB(PSA)=0
- +11 IF "^5^10^30^50^55^60^80^"[(U_FBS_U)
- SET FBD(99,FBS)=FBD(99,FBS)+1
- SET FBD(99)=FBD(99)+1
- +12 IF "^40^70^90^"[(U_FBS_U)
- if 'FBD
- QUIT
- SET FBD(FBD,FBS)=FBD(FBD,FBS)+1
- SET FBD(FBD)=FBD(FBD)+1
- +13 ;Q:'$$PAY^FBUCUTL(J,"FB583")
- +14 SET FB("PD")=$$AMTPD^FBUCMBS(J)
- +15 SET FB(PSA)=FB(PSA)+FB("PD")
- End DoDot:1
- +16 WRITE !?50,"CATEGORY OF DISPOSITION",!?3,"TYPE OF",?31,"# OF",!?3,"DISPOSITION",?31,"CLAIMS",?45,"INITIAL",?57,"APPEAL",?69,"COVA APPEAL",!,Q,!
- +17 SET FBD=0
- SET FB="0^0^0^0"
- +18 FOR
- SET FBD=$ORDER(^FB(162.91,FBD))
- if FBD'>0
- QUIT
- IF $DATA(^FB(162.91,FBD,0))
- WRITE !,?3,$PIECE(^(0),"^"),?32,$JUSTIFY(FBD(FBD),5)
- SET $PIECE(FB,"^")=$PIECE(FB,"^")+FBD(FBD)
- SET FBS=0
- Begin DoDot:1
- +19 FOR
- SET FBS=$ORDER(FBD(FBD,FBS))
- if FBS'>0
- QUIT
- WRITE ?$SELECT(FBS=40:45,FBS=70:57,1:69),$JUSTIFY(FBD(FBD,FBS),5)
- SET X=$SELECT(FBS=40:2,FBS=70:3,1:4)
- SET $PIECE(FB,"^",X)=$PIECE(FB,"^",X)+FBD(FBD,FBS)
- End DoDot:1
- +20 WRITE !,?32,"-----",?45,"-----",?57,"-----",?69,"-----",!?9,"TOTAL DISPOSITIONED",?32,$JUSTIFY($PIECE(FB,"^"),5),?45,$JUSTIFY($PIECE(FB,"^",2),5),?57,$JUSTIFY($PIECE(FB,"^",3),5),?69,$JUSTIFY($PIECE(FB,"^",4),5)
- +21 WRITE !?5,"TOTAL NOT DISPOSITIONED",?32,$JUSTIFY(FBD(99),5),!?32,"-----",!?16,"TOTAL CLAIMS",?32,$JUSTIFY(FB+FBD(99),5)
- +22 IF $PIECE(IOST,"-")="C"
- WRITE !
- DO HANG^FBAAUTL1
- if $DATA(DIRUT)
- GOTO END
- DO HED
- +23 WRITE !!?3,"STATUS OF CLAIMS NOT DISPOSITIONED",!!?3,"STATUS",?40,"# OF CLAIMS",!
- +24 SET FBS=0
- FOR
- SET FBS=$ORDER(FBD(99,FBS))
- if FBS'>0
- QUIT
- Begin DoDot:1
- +25 IF FBS=5
- IF '$PIECE(FBUC,U,7)&(FBD(99,FBS)=0)
- QUIT
- +26 WRITE !?3,$PIECE($GET(^FB(162.92,$$STATUS^FBUCUTL(FBS),0)),"^"),?40,$JUSTIFY(FBD(99,FBS),5)
- End DoDot:1
- +27 IF $PIECE(IOST,"-")="C"
- WRITE !
- DO HANG^FBAAUTL1
- if $DATA(DIRUT)
- GOTO END
- DO HED
- +28 WRITE !!?3,"TOTAL DOLLARS APPROVED BY PSA:",!
- +29 SET FB=0
- SET PSA=0
- FOR
- SET PSA=$ORDER(FB(PSA))
- if PSA="PD"!(PSA="")
- QUIT
- WRITE !?3,$PIECE($GET(^DIC(4,PSA,0)),"^")
- if PSA="OTHER"
- WRITE PSA
- SET X=FB(PSA)
- SET X2="2$"
- SET FB=FB+X
- DO COMMA^%DTC
- WRITE ?34,X
- +30 SET X=FB
- SET X2="2$"
- SET Y=""
- DO COMMA^%DTC
- WRITE !?32,"-------------",!?34,X
- END KILL DIRUT,I,J,Q,X,X2,PSA,FBBEG,FBEND,FBSTART,FBFINISH,FBD,FBUC,BEGDATE,ENDDATE,Y,FBS,FB1725R,FB
- +1 DO CLOSE^FBAAUTL
- QUIT
- HED if $PIECE(IOST,"-")="C"
- WRITE @IOF
- WRITE !?14,"UNAUTHORIZED CLAIM DISPOSITION AND STATUS STATISTICS",!?14,$EXTRACT(Q,1,52)
- MB IF FB1725R'="A"
- WRITE !?17,$SELECT(FB1725R="M":"for 38 U.S.C. 1725 Claims",1:"excluding 38 U.S.C. 1725 Claims")
- DAT WRITE !?17,"Date Range Selected: ",FBSTART," to ",FBFINISH,!?17,$EXTRACT(Q,1,41),!
- +1 QUIT
