| 1 | FBCHPSA ;AISC/DMK-CALCULATES COSTS BY PSA ;13JUN90
|
|---|
| 2 | ;;3.5;FEE BASIS;;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | EN S FBPSA=0
|
|---|
| 5 | S DIR(0)="Y",DIR("A")="Do you want this report for all PSAs",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT),SELECT:'Y
|
|---|
| 6 | ASKDT D PROG^FBCHPSA1 G END:'$O(FBPROG(0))
|
|---|
| 7 | D DATE^FBAAUTL G END:FBPOP S FBBEG=9999999-ENDDATE,FBEND=9999999-BEGDATE
|
|---|
| 8 | S VAR="FBBEG^FBEND^FBPSA^BEGDATE^ENDDATE^FBPROG(",PGM="START^FBCHPSA" S IOP="Q" D ZIS^FBAAUTL G END:FBPOP
|
|---|
| 9 | ;
|
|---|
| 10 | START ; start output
|
|---|
| 11 | S BEGDATE=$$DATX^FBAAUTL(BEGDATE),ENDDATE=$$DATX^FBAAUTL(ENDDATE)
|
|---|
| 12 | S:$E(IOST,1,2)'="C-" FBPG=1
|
|---|
| 13 | S (FBAAOUT,FBCNT)=0,QQ="=",$P(QQ,"=",80)="=",Q="-",$P(Q,"-",80)="-"
|
|---|
| 14 | K ^TMP("FBPSA",$J)
|
|---|
| 15 | S FBPROG=0
|
|---|
| 16 | S FBHPSA=FBPSA
|
|---|
| 17 | F S FBPROG=$O(FBPROG(FBPROG)) Q:'FBPROG!($G(FBAAOUT)) D G END:$G(FBAAOUT) S FBPSA=FBHPSA
|
|---|
| 18 | . I FBPROG=6 D REPORT Q:$G(FBAAOUT)
|
|---|
| 19 | . I FBPROG=7 D REPORT Q:$G(FBAAOUT)
|
|---|
| 20 | . I FBPROG=3 D ^FBCHPSA1 Q:$G(FBAAOUT)
|
|---|
| 21 | . I FBPROG=2 D ^FBCHPSA0 Q:$G(FBAAOUT)
|
|---|
| 22 | ;
|
|---|
| 23 | G END:$G(FBAAOUT)
|
|---|
| 24 | D PSATOT^FBCHPSA0
|
|---|
| 25 | G END
|
|---|
| 26 | REPORT U IO
|
|---|
| 27 | K ^TMP("FBPSA",$J) D HED
|
|---|
| 28 | I FBPSA>0 F FBI=FBBEG-.1:0 S FBI=$O(^FBAAI("AP",FBPSA,FBI)) Q:FBI'>0!(FBI>FBEND)!(FBAAOUT) F FBJ=0:0 S FBJ=$O(^FBAAI("AP",FBPSA,FBI,FBJ)) Q:FBJ'>0!(FBAAOUT) I $D(^FBAAI(FBJ,0)) S FBY(0)=^(0) D MORE
|
|---|
| 29 | I FBPSA=0 F FBPSA=0:0 S FBPSA=$O(^FBAAI("AP",FBPSA)) Q:FBPSA'>0!(FBAAOUT) F FBI=FBBEG-.1:0 S FBI=$O(^FBAAI("AP",FBPSA,FBI)) Q:FBI'>0!(FBI>FBEND)!(FBAAOUT) F FBJ=0:0 S FBJ=$O(^FBAAI("AP",FBPSA,FBI,FBJ)) Q:FBJ'>0!(FBAAOUT) D MORE1
|
|---|
| 30 | Q:FBAAOUT
|
|---|
| 31 | I $D(^TMP("FBPSA",$J)) D HED1 F I=0:0 S I=$O(^TMP("FBPSA",$J,I)) Q:I'>0 S FBSTA=$S($D(^DIC(4,I,0)):$P(^(0),"^"),1:"Unknown") W !?2,FBSTA,?44,"$ ",$P(^TMP("FBPSA",$J,I),"^")
|
|---|
| 32 | I '$D(^TMP("FBPSA",$J)) D NONE^FBCHPSA1
|
|---|
| 33 | D HANG
|
|---|
| 34 | Q
|
|---|
| 35 | ;
|
|---|
| 36 | END K DFN,DIR,DIRUT,ENDDATE,BEGDATE,FBAAOUT,FBAMTPD,FBBEG,FBDFN,FBCNT,FBCOUNTY,FBEND,FBI,FBJ,FBINV,FBNAME,FBPDDT,FBPPSA,FBPSA,FBSSN,FBSTA,FBY,Q,QQ,VAERR,VAPA,VAL,I,X,^TMP("FBPSA",$J),I,J,K,L,FBAMT,FB7078,FBZ,FBPROG,FBHPSA,IOP
|
|---|
| 37 | K FBK,FBL,FBM,VA,VADM,Y,ZZ,FBOBL,^TMP("FBTOT",$J) D CLOSE^FBAAUTL
|
|---|
| 38 | Q
|
|---|
| 39 | MORE1 Q:'$D(^FBAAI(FBJ,0)) S FBY(0)=^(0)
|
|---|
| 40 | MORE S (FBDFN,DFN)=$P(FBY(0),"^",4),FBINV=$P(FBY(0),"^"),FBPPSA=$P(FBY(0),"^",20),FBAMTPD=$P(FBY(0),"^",9),FBPDDT=$P(FBY(0),"^",16),FBPDDT=$$DATX^FBAAUTL(FBPDDT) S VAPA("P")="" D ADD^VADPT S FBCOUNTY=$P(VAPA(7),"^",2)
|
|---|
| 41 | Q:$P(FBY(0),"^",12)'=FBPROG
|
|---|
| 42 | S FB7078=$P(FBY(0),"^",5) Q:FB7078="" D EN1 S FBAMTPD=FBAMTPD+FBAMT
|
|---|
| 43 | S FBNAME=$$NAME^FBCHREQ2(FBDFN),FBSSN=$$SSN^FBAAUTL(FBDFN)
|
|---|
| 44 | S FBSTA=$S($D(^DIC(4,FBPPSA,0)):$P(^(0),"^"),1:"Unknown")
|
|---|
| 45 | S FBOBL=$P(FBY(0),"^",17),FBOBL=$S(FBOBL="":"Unknown",1:$S($D(^FBAA(161.7,FBOBL,0)):$P(^(0),"^",2),1:"Unknown"))
|
|---|
| 46 | I $Y+4>IOSL D HANG Q:FBAAOUT D HED
|
|---|
| 47 | W !,$E(FBNAME,1,30)," -",$$SSN^FBAAUTL(FBDFN,1),?42,FBOBL,?57,FBCOUNTY,!,?4,FBINV,?21,FBAMTPD,?39,FBPDDT,?60,FBSTA,!,Q,!
|
|---|
| 48 | S:'$D(^TMP("FBPSA",$J,FBPPSA)) ^TMP("FBPSA",$J,FBPPSA)=0
|
|---|
| 49 | S ^TMP("FBPSA",$J,FBPPSA)=^TMP("FBPSA",$J,FBPPSA)+FBAMTPD
|
|---|
| 50 | S:'$D(^TMP("FBTOT",$J,FBPPSA)) ^TMP("FBTOT",$J,FBPPSA)=0
|
|---|
| 51 | S ^TMP("FBTOT",$J,FBPPSA)=^TMP("FBTOT",$J,FBPPSA)+FBAMTPD
|
|---|
| 52 | Q
|
|---|
| 53 | HED W:'$G(FBPG) @IOF I $G(FBPG) K FBPG
|
|---|
| 54 | W !?25,$S(FBPROG=6:"CIVIL HOSPITAL PSA REPORT",FBPROG=2:"OUTPATIENT MEDICAL PSA REPORT",FBPROG=3:"PHARMACY PSA REPORT",1:"COMMUNITY N.H. PSA REPORT")
|
|---|
| 55 | W !?24,"-------------------------------",!,"Patient Name",?40,"Obligation #",?56,"County Code",!
|
|---|
| 56 | W ?3,"Invoice #",?20,"Amount Paid",?38,"Date Finalized",?59,"PSA",!,QQ
|
|---|
| 57 | Q
|
|---|
| 58 | SELECT S DIR(0)="161.01,101" D ^DIR G END:$D(DUOUT),H^XUS:$D(DTOUT),EN:X="" S FBPSA=+Y G ASKDT
|
|---|
| 59 | HANG I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1
|
|---|
| 60 | Q
|
|---|
| 61 | HED1 W !,QQ,!?7,"Total Dollars spent by PSA for the dates of ",BEGDATE," to ",ENDDATE,". ",!!?5,"PSA",?40,"TOTAL AMOUNT PAID",!,?4,"-----",?39,"--------------------" Q
|
|---|
| 62 | EN1 S FBAMT=0 Q:'$D(^FBAAC("AM",FB7078))
|
|---|
| 63 | F I=0:0 S I=$O(^FBAAC("AM",FB7078,I)) Q:I'>0 F J=0:0 S J=$O(^FBAAC("AM",FB7078,I,J)) Q:J'>0 F K=0:0 S K=$O(^FBAAC("AM",FB7078,I,J,K)) Q:K'>0 F L=0:0 S L=$O(^FBAAC("AM",FB7078,I,J,K,L)) Q:L'>0 I $D(^FBAAC(I,1,J,1,K,1,L,0)) S FBZ(0)=^(0) D GT
|
|---|
| 64 | Q
|
|---|
| 65 | GT S FBAMT=FBAMT+$P(FBZ(0),"^",3) Q
|
|---|
