FBCHACT0 ;AISC/DMK-NON-VA HOSPITAL ACTIVITY CONT ;01JUL01
;;3.5;FEE BASIS;**28**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
ENT S (SCNT,MCNT,PCNT,SDED,MDED,PDED,ASCNT,AMCNT,APCNT,DSCNT,DMCNT,DPCNT,RSCNT,RMCNT,RPCNT,FBDAYS,FBMDAY,FBSDAY,FBPDAY)=0,FBBED=""
F J="AA","AD","AR" F I=0:0 S I=$O(^TMP("FBCH",$J,J,FBK,I)) Q:I'>0 I $D(^FBAAA("AG",I_";FB7078(")) D 161
D EN,WRT
K AMCNT,APCNT,ASCNT,DMCNT,DPCNT,DSCNT,FBADDT,FBCHDT,FBDA,FBDAYS,FBDED,FBFRDT,FBMDAY,FBPDAY,FBSDAY,FBTODT,FBTYPE,I,J,MCNT,PCNT,PDED,Q,QQ,RMCNT,RPCNT,RSCNT,SCNT,SDED,X,Y,MDED Q
161 S FBDA(1)=$O(^FBAAA("AG",I_";FB7078(",0)),FBDA=$O(^FBAAA("AG",I_";FB7078(",FBDA(1),0)) Q:'$D(^FBAAA(FBDA(1),1,FBDA,0)) S FBADDT=$P(^(0),"^",18),FBFRDT=$P(^(0),"^"),FBTODT=$P(^(0),"^",2)
S FBFRDT=$S(FBCHDT>FBFRDT:FBCHDT,1:FBFRDT),FBTODT=$S(FBTODT="":FBENDDT,FBTODT>FBENDDT:FBENDDT,1:FBTODT)
I FBADDT="00" S SCNT=SCNT+1
I FBADDT=10 S MCNT=MCNT+1
I FBADDT=86 S PCNT=PCNT+1
I J="AA" S ASCNT=ASCNT+SCNT,AMCNT=AMCNT+MCNT,APCNT=APCNT+PCNT D RESET Q
I J="AD" S DSCNT=DSCNT+SCNT,DMCNT=DMCNT+MCNT,DPCNT=DPCNT+PCNT D RESET Q
I J="AR" S RSCNT=RSCNT+SCNT,RMCNT=RMCNT+MCNT,RPCNT=RPCNT+PCNT D RESET Q
Q
WRT D HED
W !,"MEDICINE",!,"--------" D HED1
W ?3,AMCNT,?17,DMCNT-MDED,?32,MDED,?45,RMCNT,?59,FBMDAY,?73,^TMP("FB",$J,FBK,10),!
W !,"SURGERY",!,"-------" D HED1
W ?5,ASCNT,?20,DSCNT-SDED,?32,SDED,?45,RSCNT,?59,FBSDAY,?73,^TMP("FB",$J,FBK,"00"),!
W !,"PSYCHIATRY",!,"----------" D HED1
W ?5,APCNT,?20,DPCNT-PDED,?32,PDED,?45,RPCNT,?59,FBPDAY,?73,^TMP("FB",$J,FBK,86),!
Q
HED S Q="=",$P(Q,"=",79)="=",Y=FBCHDT X ^DD("DD") S FBCHDT=Y
W !,?21,FBHED_" ACTIVITY REPORT",!,?21,"----------------------------------",!,?1,"For the month of: ",FBCHDT,!,Q,! Q
RESET S (MCNT,SCNT,PCNT)=0 Q
DAYS S FBDAYS=0,X1=FBTODT,X2=FBFRDT D D^%DTC S FBDAYS=$S(X<1:1,1:X+1)
Q
HED1 W !?41,"PATIENTS",?57,"DAYS OF",?70,"DAYS OF",!?1,"ADMISSIONS",?15,"DISCHARGES",?30,"DEATHS",?40,"REMAINING",?58,"CARE",?69,"UNAUTH CARE",! F QQ=1:1:80 W "-"
W ! Q
EN F I=FBCHDT:0 S I=$O(^FB7078("AD",FBTYPE,I)) Q:I'>0 F J=0:0 S J=$O(^FB7078("AD",FBTYPE,I,J)) Q:J'>0 D VENTYPE^FBCHACT I FBVENTP=FBK I $D(^FB7078(J,0)) S FBADMIT=$P(^(0),"^",4),FBTODT=I D GETBED,CHK
Q
CHK Q:FBADMIT>FBENDDT S FBFRDT=$S(FBADMIT<FBCHDT:FBCHDT,1:FBADMIT)
S FBTODT=$S(FBTODT>FBENDDT:FBENDDT,1:FBTODT)
D DAYS I FBTODT'=FBENDDT S FBDAYS=FBDAYS-1
I FBBED="00" S FBSDAY=FBSDAY+FBDAYS I FBDED=2!(FBDED=3) S SDED=SDED+1 K FBDED
I FBBED=10 S FBMDAY=FBMDAY+FBDAYS I FBDED=2!(FBDED=3) S MDED=MDED+1 K FBDED
I FBBED=86 S FBPDAY=FBPDAY+FBDAYS I FBDED=2!(FBDED=3) S PDED=PDED+1 K FBDED
S FBBED="" Q
GETBED S FB(1)=$O(^FBAAA("AG",J_";FB7078(",0)) Q:FB(1)="" S FB=$O(^FBAAA("AG",J_";FB7078(",FB(1),0)) Q:FB="" I $D(^FBAAA(FB(1),1,FB,0)) S FBBED=$P(^(0),"^",18),FBDED=$P(^(0),"^",15)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHACT0 2855 printed Sep 23, 2025@19:33:34 Page 2
FBCHACT0 ;AISC/DMK-NON-VA HOSPITAL ACTIVITY CONT ;01JUL01
+1 ;;3.5;FEE BASIS;**28**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
ENT SET (SCNT,MCNT,PCNT,SDED,MDED,PDED,ASCNT,AMCNT,APCNT,DSCNT,DMCNT,DPCNT,RSCNT,RMCNT,RPCNT,FBDAYS,FBMDAY,FBSDAY,FBPDAY)=0
SET FBBED=""
+1 FOR J="AA","AD","AR"
FOR I=0:0
SET I=$ORDER(^TMP("FBCH",$JOB,J,FBK,I))
if I'>0
QUIT
IF $DATA(^FBAAA("AG",I_";FB7078("))
DO 161
+2 DO EN
DO WRT
+3 KILL AMCNT,APCNT,ASCNT,DMCNT,DPCNT,DSCNT,FBADDT,FBCHDT,FBDA,FBDAYS,FBDED,FBFRDT,FBMDAY,FBPDAY,FBSDAY,FBTODT,FBTYPE,I,J,MCNT,PCNT,PDED,Q,QQ,RMCNT,RPCNT,RSCNT,SCNT,SDED,X,Y,MDED
QUIT
161 SET FBDA(1)=$ORDER(^FBAAA("AG",I_";FB7078(",0))
SET FBDA=$ORDER(^FBAAA("AG",I_";FB7078(",FBDA(1),0))
if '$DATA(^FBAAA(FBDA(1),1,FBDA,0))
QUIT
SET FBADDT=$PIECE(^(0),"^",18)
SET FBFRDT=$PIECE(^(0),"^")
SET FBTODT=$PIECE(^(0),"^",2)
+1 SET FBFRDT=$SELECT(FBCHDT>FBFRDT:FBCHDT,1:FBFRDT)
SET FBTODT=$SELECT(FBTODT="":FBENDDT,FBTODT>FBENDDT:FBENDDT,1:FBTODT)
+2 IF FBADDT="00"
SET SCNT=SCNT+1
+3 IF FBADDT=10
SET MCNT=MCNT+1
+4 IF FBADDT=86
SET PCNT=PCNT+1
+5 IF J="AA"
SET ASCNT=ASCNT+SCNT
SET AMCNT=AMCNT+MCNT
SET APCNT=APCNT+PCNT
DO RESET
QUIT
+6 IF J="AD"
SET DSCNT=DSCNT+SCNT
SET DMCNT=DMCNT+MCNT
SET DPCNT=DPCNT+PCNT
DO RESET
QUIT
+7 IF J="AR"
SET RSCNT=RSCNT+SCNT
SET RMCNT=RMCNT+MCNT
SET RPCNT=RPCNT+PCNT
DO RESET
QUIT
+8 QUIT
WRT DO HED
+1 WRITE !,"MEDICINE",!,"--------"
DO HED1
+2 WRITE ?3,AMCNT,?17,DMCNT-MDED,?32,MDED,?45,RMCNT,?59,FBMDAY,?73,^TMP("FB",$JOB,FBK,10),!
+3 WRITE !,"SURGERY",!,"-------"
DO HED1
+4 WRITE ?5,ASCNT,?20,DSCNT-SDED,?32,SDED,?45,RSCNT,?59,FBSDAY,?73,^TMP("FB",$JOB,FBK,"00"),!
+5 WRITE !,"PSYCHIATRY",!,"----------"
DO HED1
+6 WRITE ?5,APCNT,?20,DPCNT-PDED,?32,PDED,?45,RPCNT,?59,FBPDAY,?73,^TMP("FB",$JOB,FBK,86),!
+7 QUIT
HED SET Q="="
SET $PIECE(Q,"=",79)="="
SET Y=FBCHDT
XECUTE ^DD("DD")
SET FBCHDT=Y
+1 WRITE !,?21,FBHED_" ACTIVITY REPORT",!,?21,"----------------------------------",!,?1,"For the month of: ",FBCHDT,!,Q,!
QUIT
RESET SET (MCNT,SCNT,PCNT)=0
QUIT
DAYS SET FBDAYS=0
SET X1=FBTODT
SET X2=FBFRDT
DO D^%DTC
SET FBDAYS=$SELECT(X<1:1,1:X+1)
+1 QUIT
HED1 WRITE !?41,"PATIENTS",?57,"DAYS OF",?70,"DAYS OF",!?1,"ADMISSIONS",?15,"DISCHARGES",?30,"DEATHS",?40,"REMAINING",?58,"CARE",?69,"UNAUTH CARE",!
FOR QQ=1:1:80
WRITE "-"
+1 WRITE !
QUIT
EN FOR I=FBCHDT:0
SET I=$ORDER(^FB7078("AD",FBTYPE,I))
if I'>0
QUIT
FOR J=0:0
SET J=$ORDER(^FB7078("AD",FBTYPE,I,J))
if J'>0
QUIT
DO VENTYPE^FBCHACT
IF FBVENTP=FBK
IF $DATA(^FB7078(J,0))
SET FBADMIT=$PIECE(^(0),"^",4)
SET FBTODT=I
DO GETBED
DO CHK
+1 QUIT
CHK if FBADMIT>FBENDDT
QUIT
SET FBFRDT=$SELECT(FBADMIT<FBCHDT:FBCHDT,1:FBADMIT)
+1 SET FBTODT=$SELECT(FBTODT>FBENDDT:FBENDDT,1:FBTODT)
+2 DO DAYS
IF FBTODT'=FBENDDT
SET FBDAYS=FBDAYS-1
+3 IF FBBED="00"
SET FBSDAY=FBSDAY+FBDAYS
IF FBDED=2!(FBDED=3)
SET SDED=SDED+1
KILL FBDED
+4 IF FBBED=10
SET FBMDAY=FBMDAY+FBDAYS
IF FBDED=2!(FBDED=3)
SET MDED=MDED+1
KILL FBDED
+5 IF FBBED=86
SET FBPDAY=FBPDAY+FBDAYS
IF FBDED=2!(FBDED=3)
SET PDED=PDED+1
KILL FBDED
+6 SET FBBED=""
QUIT
GETBED SET FB(1)=$ORDER(^FBAAA("AG",J_";FB7078(",0))
if FB(1)=""
QUIT
SET FB=$ORDER(^FBAAA("AG",J_";FB7078(",FB(1),0))
if FB=""
QUIT
IF $DATA(^FBAAA(FB(1),1,FB,0))
SET FBBED=$PIECE(^(0),"^",18)
SET FBDED=$PIECE(^(0),"^",15)
+1 QUIT
