FBCHSTAT ;AISC/DMK-REQUEST STATS ;04MAY90
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
EN D DATE^FBAAUTL G END:FBPOP S FBFRDT=BEGDATE,FBTODT=ENDDATE+.99999
S VAR="FBFRDT^FBTODT",VAL=FBFRDT_"^"_FBTODT,PGM="START^FBCHSTAT" D ZIS^FBAAUTL G END:FBPOP
START U IO W:$E(IOST,1,2)="C-" @IOF S (FBTOT,FBINEL,FBAAOUT,FBPCNT)=0,FB(1)="" D HED
F I=FBFRDT:0 S I=$O(^FBAA(162.2,"B",I)) Q:I'>0!(I>FBTODT)!(FBAAOUT) F J=0:0 S J=$O(^FBAA(162.2,"B",I,J)) Q:J'>0!(FBAAOUT) I $D(^FBAA(162.2,J,0)) S FB(0)=^(0) D GET
W:'FBAAOUT !!,"Total Requests: ",FBTOT,!,"# of Requests Denied: ",FBINEL,!,"# of Requests Pending: ",FBPCNT
END K ENDDATE,FB,FBPCNT,FBAAOUT,FBDATE,FBFRDT,FBTODT,FBINEL,FBTOT,FBVEN,FBVET,I,J,Q,QQ,X,Y D CLOSE^FBAAUTL Q
GET Q:'$P(FB(0),U,4) S FBVET=+$P(FB(0),"^",4),FBVET=$P($G(^DPT(FBVET,0)),U) S:FBVET']"" FBVET="UNKNOWN" S FBVEN=+$P(FB(0),"^",2),FBVEN=$P($G(^FBAAV(FBVEN,0)),U),FBVEN=$S(FBVEN]"":$E(FBVEN,1,35),1:"UNKNOWN")
S FBTOT=FBTOT+1,FBINEL=FBINEL+$S($P(FB(0),"^",9)="N":1,$P(FB(0),"^",12)="N":1,1:0),FB(1)=""
I $P(FB(0),"^",9)="N" S FB(1)="!"
I $P(FB(0),"^",12)="N" S FB(1)="!"
S Y=$P(FB(0),"^",5) X ^DD("DD") S FBDATE=$P(Y,"@")
I $P(FB(0),"^",15)'=3 S FBPCNT=FBPCNT+1,FB(1)="+"
W !,FB(1),?3,FBVET,?32,FBVEN,?69,FBDATE
I $Y+4>IOSL,$E(IOST)="C" D HANG^FBAAUTL1 Q:FBAAOUT W @IOF D HED
E I $Y+4>IOSL W @IOF D HED
Q
HED S Q="",$P(Q,"=",80)="=",QQ="",$P(QQ,"-",38)="-"
W !,?16,"CONTRACT HOSPITAL REQUEST STATISTICS",!,?15,QQ,!,?22,"('+' Request Pending)",!,?22,"('!' Request Denied)",!
W ?1,"VETERAN",?32,"VENDOR",?69,"ADMISSION",!,Q,!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHSTAT 1635 printed Dec 13, 2024@01:58:02 Page 2
FBCHSTAT ;AISC/DMK-REQUEST STATS ;04MAY90
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
EN DO DATE^FBAAUTL
if FBPOP
GOTO END
SET FBFRDT=BEGDATE
SET FBTODT=ENDDATE+.99999
+1 SET VAR="FBFRDT^FBTODT"
SET VAL=FBFRDT_"^"_FBTODT
SET PGM="START^FBCHSTAT"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
START USE IO
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
SET (FBTOT,FBINEL,FBAAOUT,FBPCNT)=0
SET FB(1)=""
DO HED
+1 FOR I=FBFRDT:0
SET I=$ORDER(^FBAA(162.2,"B",I))
if I'>0!(I>FBTODT)!(FBAAOUT)
QUIT
FOR J=0:0
SET J=$ORDER(^FBAA(162.2,"B",I,J))
if J'>0!(FBAAOUT)
QUIT
IF $DATA(^FBAA(162.2,J,0))
SET FB(0)=^(0)
DO GET
+2 if 'FBAAOUT
WRITE !!,"Total Requests: ",FBTOT,!,"# of Requests Denied: ",FBINEL,!,"# of Requests Pending: ",FBPCNT
END KILL ENDDATE,FB,FBPCNT,FBAAOUT,FBDATE,FBFRDT,FBTODT,FBINEL,FBTOT,FBVEN,FBVET,I,J,Q,QQ,X,Y
DO CLOSE^FBAAUTL
QUIT
GET if '$PIECE(FB(0),U,4)
QUIT
SET FBVET=+$PIECE(FB(0),"^",4)
SET FBVET=$PIECE($GET(^DPT(FBVET,0)),U)
if FBVET']""
SET FBVET="UNKNOWN"
SET FBVEN=+$PIECE(FB(0),"^",2)
SET FBVEN=$PIECE($GET(^FBAAV(FBVEN,0)),U)
SET FBVEN=$SELECT(FBVEN]"":$EXTRACT(FBVEN,1,35),1:"UNKNOWN")
+1 SET FBTOT=FBTOT+1
SET FBINEL=FBINEL+$SELECT($PIECE(FB(0),"^",9)="N":1,$PIECE(FB(0),"^",12)="N":1,1:0)
SET FB(1)=""
+2 IF $PIECE(FB(0),"^",9)="N"
SET FB(1)="!"
+3 IF $PIECE(FB(0),"^",12)="N"
SET FB(1)="!"
+4 SET Y=$PIECE(FB(0),"^",5)
XECUTE ^DD("DD")
SET FBDATE=$PIECE(Y,"@")
+5 IF $PIECE(FB(0),"^",15)'=3
SET FBPCNT=FBPCNT+1
SET FB(1)="+"
+6 WRITE !,FB(1),?3,FBVET,?32,FBVEN,?69,FBDATE
+7 IF $Y+4>IOSL
IF $EXTRACT(IOST)="C"
DO HANG^FBAAUTL1
if FBAAOUT
QUIT
WRITE @IOF
DO HED
+8 IF '$TEST
IF $Y+4>IOSL
WRITE @IOF
DO HED
+9 QUIT
HED SET Q=""
SET $PIECE(Q,"=",80)="="
SET QQ=""
SET $PIECE(QQ,"-",38)="-"
+1 WRITE !,?16,"CONTRACT HOSPITAL REQUEST STATISTICS",!,?15,QQ,!,?22,"('+' Request Pending)",!,?22,"('!' Request Denied)",!
+2 WRITE ?1,"VETERAN",?32,"VENDOR",?69,"ADMISSION",!,Q,!!
+3 QUIT
