FBCHACT ;AISC/DMK-CALCULATES NON-VA HOSP ACTIVITY ;01JUL01
;;3.5;FEE BASIS;**25,28**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
S Q="",$P(Q,"-",80)="-"
W !!?18,"NON-VA HOSPITAL ACTIVITY REPORTS",!?17,$E(Q,1,34),!
S DIR(0)="S^1:PUBLIC HOSPITAL;2:PRIVATE HOSPITAL;3:FEDERAL HOSPITAL" D ^DIR K DIR G END:$D(DUOUT),H^XUS:$D(DTOUT) S FBK=+Y
S FBK=$S(FBK=1:1,FBK=2:9,FBK=3:10,1:"")
G END:FBK="" S FBHED=Y(0)
EN W !!,?5,"This option will calculate the ",FBHED," Activity Report. ",!!
ASKDT S FBTYPE=6,%DT="EAP",%DT("A")="Enter Month and Year: " D ^%DT G END:X="^"!(X="") S X=Y X $S($E(X,6,7)'="00":"K X W !,""Do not specify day of month""",X>DT:"K X W !,""Not future dates""",1:"") I '$D(X) G ASKDT
S FBCHDT=X D DAYS^FBAAUTL1 S FBENDDT=FBCHDT+X
S VAR="FBCHDT^FBENDDT^FBK^FBHED",VAL=FBCHDT_"^"_FBENDDT_"^"_FBK_"^"_FBHED,PGM="START^FBCHACT" D ZIS^FBAAUTL G:FBPOP END
START U IO W:$E(IOST,1,2)["C-" @IOF S DCNT=0,FBTYPE=6 K ^TMP("FBCH",$J)
F I=FBCHDT:0 S I=$O(^FB7078("AD",FBTYPE,I)) Q:I'>0!(I>FBENDDT) F J=0:0 S J=$O(^FB7078("AD",FBTYPE,I,J)) Q:J'>0 D VENTYPE I FBVENTP S DCNT=DCNT+1,^TMP("FBCH",$J,"AD",FBVENTP,J,I)=""
S ACNT=0
F I=FBCHDT:0 S I=$O(^FB7078("AA",FBTYPE,I)) Q:I'>0!(I>FBENDDT) F J=0:0 S J=$O(^FB7078("AA",FBTYPE,I,J)) Q:J'>0 D VENTYPE I FBVENTP S ACNT=ACNT+1,^TMP("FBCH",$J,"AA",FBVENTP,J,I)=""
S RCNT=0
F K=0:0 S K=$O(^FB7078("AA",FBTYPE,K)) Q:K'>0!(K>FBENDDT) F J=0:0 S J=$O(^FB7078("AA",FBTYPE,K,J)) Q:J'>0 I $P(^FB7078(J,0),"^",5)]""&($P(^(0),"^",5)>FBENDDT) D VENTYPE I FBVENTP S RCNT=RCNT+1,^TMP("FBCH",$J,"AR",FBVENTP,J,K)=""
I $D(^FB7078("AC","I")) F I=0:0 S I=$O(^FB7078("AC","I",I)) Q:I'>0 F J=0:0 S J=$O(^FB7078("AC","I",I,J)) Q:J'>0 D VENTYPE I FBVENTP S RCNT=RCNT+1
D ^FBCHACT1,^FBCHACT0
END K ACNT,DCNT,RCNT,DUOUT,DTOUT,DIRUT,I,J,K,L,Q,QQ,FBK,FBHED,X,Y,FBCHDT,FBENDDT,^TMP("FBCH",$J),ZZ,FBADMIT,FB,FBBED,PTYPE,VTYPE,DAYS,^TMP("FB",$J),FBVENTP
D CLOSE^FBAAUTL Q
VENTYPE ;GET VENDOR TYPE
S FBVENTP="" Q:'J Q:'$D(^FB7078(J,0))
Q:$P($G(^FB7078(J,0)),U,9)="DC"
S FBVENTP=$S($P($P(^FB7078(J,0),"^",2),";",2)="FBAAV(":$P($P(^(0),"^",2),";",1),1:""),FBVENTP=$S(FBVENTP="":"",1:$S($D(^FBAAV(FBVENTP,0)):$P(^(0),"^",7),1:""))
I FBVENTP="" S FBVENTP=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHACT 2260 printed Oct 16, 2024@17:58:19 Page 2
FBCHACT ;AISC/DMK-CALCULATES NON-VA HOSP ACTIVITY ;01JUL01
+1 ;;3.5;FEE BASIS;**25,28**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET Q=""
SET $PIECE(Q,"-",80)="-"
+4 WRITE !!?18,"NON-VA HOSPITAL ACTIVITY REPORTS",!?17,$EXTRACT(Q,1,34),!
+5 SET DIR(0)="S^1:PUBLIC HOSPITAL;2:PRIVATE HOSPITAL;3:FEDERAL HOSPITAL"
DO ^DIR
KILL DIR
if $DATA(DUOUT)
GOTO END
if $DATA(DTOUT)
GOTO H^XUS
SET FBK=+Y
+6 SET FBK=$SELECT(FBK=1:1,FBK=2:9,FBK=3:10,1:"")
+7 if FBK=""
GOTO END
SET FBHED=Y(0)
EN WRITE !!,?5,"This option will calculate the ",FBHED," Activity Report. ",!!
ASKDT SET FBTYPE=6
SET %DT="EAP"
SET %DT("A")="Enter Month and Year: "
DO ^%DT
if X="^"!(X="")
GOTO END
SET X=Y
XECUTE $SELECT($EXTRACT(X,6,7)'="00":"K X W !,""Do not specify day of month""",X>DT:"K X W !,""Not future dates""",1:"")
IF '$DATA(X)
GOTO ASKDT
+1 SET FBCHDT=X
DO DAYS^FBAAUTL1
SET FBENDDT=FBCHDT+X
+2 SET VAR="FBCHDT^FBENDDT^FBK^FBHED"
SET VAL=FBCHDT_"^"_FBENDDT_"^"_FBK_"^"_FBHED
SET PGM="START^FBCHACT"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
START USE IO
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
SET DCNT=0
SET FBTYPE=6
KILL ^TMP("FBCH",$JOB)
+1 FOR I=FBCHDT:0
SET I=$ORDER(^FB7078("AD",FBTYPE,I))
if I'>0!(I>FBENDDT)
QUIT
FOR J=0:0
SET J=$ORDER(^FB7078("AD",FBTYPE,I,J))
if J'>0
QUIT
DO VENTYPE
IF FBVENTP
SET DCNT=DCNT+1
SET ^TMP("FBCH",$JOB,"AD",FBVENTP,J,I)=""
+2 SET ACNT=0
+3 FOR I=FBCHDT:0
SET I=$ORDER(^FB7078("AA",FBTYPE,I))
if I'>0!(I>FBENDDT)
QUIT
FOR J=0:0
SET J=$ORDER(^FB7078("AA",FBTYPE,I,J))
if J'>0
QUIT
DO VENTYPE
IF FBVENTP
SET ACNT=ACNT+1
SET ^TMP("FBCH",$JOB,"AA",FBVENTP,J,I)=""
+4 SET RCNT=0
+5 FOR K=0:0
SET K=$ORDER(^FB7078("AA",FBTYPE,K))
if K'>0!(K>FBENDDT)
QUIT
FOR J=0:0
SET J=$ORDER(^FB7078("AA",FBTYPE,K,J))
if J'>0
QUIT
IF $PIECE(^FB7078(J,0),"^",5)]""&($PIECE(^(0),"^",5)>FBENDDT)
DO VENTYPE
IF FBVENTP
SET RCNT=RCNT+1
SET ^TMP("FBCH",$JOB,"AR",FBVENTP,J,K)=""
+6 IF $DATA(^FB7078("AC","I"))
FOR I=0:0
SET I=$ORDER(^FB7078("AC","I",I))
if I'>0
QUIT
FOR J=0:0
SET J=$ORDER(^FB7078("AC","I",I,J))
if J'>0
QUIT
DO VENTYPE
IF FBVENTP
SET RCNT=RCNT+1
+7 DO ^FBCHACT1
DO ^FBCHACT0
END KILL ACNT,DCNT,RCNT,DUOUT,DTOUT,DIRUT,I,J,K,L,Q,QQ,FBK,FBHED,X,Y,FBCHDT,FBENDDT,^TMP("FBCH",$JOB),ZZ,FBADMIT,FB,FBBED,PTYPE,VTYPE,DAYS,^TMP("FB",$JOB),FBVENTP
+1 DO CLOSE^FBAAUTL
QUIT
VENTYPE ;GET VENDOR TYPE
+1 SET FBVENTP=""
if 'J
QUIT
if '$DATA(^FB7078(J,0))
QUIT
+2 if $PIECE($GET(^FB7078(J,0)),U,9)="DC"
QUIT
+3 SET FBVENTP=$SELECT($PIECE($PIECE(^FB7078(J,0),"^",2),";",2)="FBAAV(":$PIECE($PIECE(^(0),"^",2),";",1),1:"")
SET FBVENTP=$SELECT(FBVENTP="":"",1:$SELECT($DATA(^FBAAV(FBVENTP,0)):$PIECE(^(0),"^",7),1:""))
+4 IF FBVENTP=""
SET FBVENTP=1
+5 QUIT
