| [613] | 1 | FBCHACT ;AISC/DMK-CALCULATES NON-VA HOSP ACTIVITY ;01JUL01
|
|---|
| 2 | ;;3.5;FEE BASIS;**25,28**;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | S Q="",$P(Q,"-",80)="-"
|
|---|
| 5 | W !!?18,"NON-VA HOSPITAL ACTIVITY REPORTS",!?17,$E(Q,1,34),!
|
|---|
| 6 | 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
|
|---|
| 7 | S FBK=$S(FBK=1:1,FBK=2:9,FBK=3:10,1:"")
|
|---|
| 8 | G END:FBK="" S FBHED=Y(0)
|
|---|
| 9 | EN W !!,?5,"This option will calculate the ",FBHED," Activity Report. ",!!
|
|---|
| 10 | 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
|
|---|
| 11 | S FBCHDT=X D DAYS^FBAAUTL1 S FBENDDT=FBCHDT+X
|
|---|
| 12 | S VAR="FBCHDT^FBENDDT^FBK^FBHED",VAL=FBCHDT_"^"_FBENDDT_"^"_FBK_"^"_FBHED,PGM="START^FBCHACT" D ZIS^FBAAUTL G:FBPOP END
|
|---|
| 13 | START U IO W:$E(IOST,1,2)["C-" @IOF S DCNT=0,FBTYPE=6 K ^TMP("FBCH",$J)
|
|---|
| 14 | 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)=""
|
|---|
| 15 | S ACNT=0
|
|---|
| 16 | 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)=""
|
|---|
| 17 | S RCNT=0
|
|---|
| 18 | 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)=""
|
|---|
| 19 | 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
|
|---|
| 20 | D ^FBCHACT1,^FBCHACT0
|
|---|
| 21 | 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
|
|---|
| 22 | D CLOSE^FBAAUTL Q
|
|---|
| 23 | VENTYPE ;GET VENDOR TYPE
|
|---|
| 24 | S FBVENTP="" Q:'J Q:'$D(^FB7078(J,0))
|
|---|
| 25 | Q:$P($G(^FB7078(J,0)),U,9)="DC"
|
|---|
| 26 | 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:""))
|
|---|
| 27 | I FBVENTP="" S FBVENTP=1
|
|---|
| 28 | Q
|
|---|
