29 lines
2.2 KiB
Mathematica
29 lines
2.2 KiB
Mathematica
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
|