- FBCHPSA ;AISC/DMK-CALCULATES COSTS BY PSA ;13JUN90
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- EN S FBPSA=0
- 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
- ASKDT D PROG^FBCHPSA1 G END:'$O(FBPROG(0))
- D DATE^FBAAUTL G END:FBPOP S FBBEG=9999999-ENDDATE,FBEND=9999999-BEGDATE
- S VAR="FBBEG^FBEND^FBPSA^BEGDATE^ENDDATE^FBPROG(",PGM="START^FBCHPSA" S IOP="Q" D ZIS^FBAAUTL G END:FBPOP
- ;
- START ; start output
- S BEGDATE=$$DATX^FBAAUTL(BEGDATE),ENDDATE=$$DATX^FBAAUTL(ENDDATE)
- S:$E(IOST,1,2)'="C-" FBPG=1
- S (FBAAOUT,FBCNT)=0,QQ="=",$P(QQ,"=",80)="=",Q="-",$P(Q,"-",80)="-"
- K ^TMP("FBPSA",$J)
- S FBPROG=0
- S FBHPSA=FBPSA
- F S FBPROG=$O(FBPROG(FBPROG)) Q:'FBPROG!($G(FBAAOUT)) D G END:$G(FBAAOUT) S FBPSA=FBHPSA
- . I FBPROG=6 D REPORT Q:$G(FBAAOUT)
- . I FBPROG=7 D REPORT Q:$G(FBAAOUT)
- . I FBPROG=3 D ^FBCHPSA1 Q:$G(FBAAOUT)
- . I FBPROG=2 D ^FBCHPSA0 Q:$G(FBAAOUT)
- ;
- G END:$G(FBAAOUT)
- D PSATOT^FBCHPSA0
- G END
- REPORT U IO
- K ^TMP("FBPSA",$J) D HED
- 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
- 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
- Q:FBAAOUT
- 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),"^")
- I '$D(^TMP("FBPSA",$J)) D NONE^FBCHPSA1
- D HANG
- Q
- ;
- 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
- K FBK,FBL,FBM,VA,VADM,Y,ZZ,FBOBL,^TMP("FBTOT",$J) D CLOSE^FBAAUTL
- Q
- MORE1 Q:'$D(^FBAAI(FBJ,0)) S FBY(0)=^(0)
- 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)
- Q:$P(FBY(0),"^",12)'=FBPROG
- S FB7078=$P(FBY(0),"^",5) Q:FB7078="" D EN1 S FBAMTPD=FBAMTPD+FBAMT
- S FBNAME=$$NAME^FBCHREQ2(FBDFN),FBSSN=$$SSN^FBAAUTL(FBDFN)
- S FBSTA=$S($D(^DIC(4,FBPPSA,0)):$P(^(0),"^"),1:"Unknown")
- S FBOBL=$P(FBY(0),"^",17),FBOBL=$S(FBOBL="":"Unknown",1:$S($D(^FBAA(161.7,FBOBL,0)):$P(^(0),"^",2),1:"Unknown"))
- I $Y+4>IOSL D HANG Q:FBAAOUT D HED
- W !,$E(FBNAME,1,30)," -",$$SSN^FBAAUTL(FBDFN,1),?42,FBOBL,?57,FBCOUNTY,!,?4,FBINV,?21,FBAMTPD,?39,FBPDDT,?60,FBSTA,!,Q,!
- S:'$D(^TMP("FBPSA",$J,FBPPSA)) ^TMP("FBPSA",$J,FBPPSA)=0
- S ^TMP("FBPSA",$J,FBPPSA)=^TMP("FBPSA",$J,FBPPSA)+FBAMTPD
- S:'$D(^TMP("FBTOT",$J,FBPPSA)) ^TMP("FBTOT",$J,FBPPSA)=0
- S ^TMP("FBTOT",$J,FBPPSA)=^TMP("FBTOT",$J,FBPPSA)+FBAMTPD
- Q
- HED W:'$G(FBPG) @IOF I $G(FBPG) K FBPG
- 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")
- W !?24,"-------------------------------",!,"Patient Name",?40,"Obligation #",?56,"County Code",!
- W ?3,"Invoice #",?20,"Amount Paid",?38,"Date Finalized",?59,"PSA",!,QQ
- Q
- SELECT S DIR(0)="161.01,101" D ^DIR G END:$D(DUOUT),H^XUS:$D(DTOUT),EN:X="" S FBPSA=+Y G ASKDT
- HANG I $E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1
- Q
- 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
- EN1 S FBAMT=0 Q:'$D(^FBAAC("AM",FB7078))
- 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
- Q
- GT S FBAMT=FBAMT+$P(FBZ(0),"^",3) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHPSA 4120 printed Feb 18, 2025@23:24:15 Page 2
- FBCHPSA ;AISC/DMK-CALCULATES COSTS BY PSA ;13JUN90
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- EN SET FBPSA=0
- +1 SET DIR(0)="Y"
- SET DIR("A")="Do you want this report for all PSAs"
- SET DIR("B")="YES"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- if 'Y
- GOTO SELECT
- ASKDT DO PROG^FBCHPSA1
- if '$ORDER(FBPROG(0))
- GOTO END
- +1 DO DATE^FBAAUTL
- if FBPOP
- GOTO END
- SET FBBEG=9999999-ENDDATE
- SET FBEND=9999999-BEGDATE
- +2 SET VAR="FBBEG^FBEND^FBPSA^BEGDATE^ENDDATE^FBPROG("
- SET PGM="START^FBCHPSA"
- SET IOP="Q"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO END
- +3 ;
- START ; start output
- +1 SET BEGDATE=$$DATX^FBAAUTL(BEGDATE)
- SET ENDDATE=$$DATX^FBAAUTL(ENDDATE)
- +2 if $EXTRACT(IOST,1,2)'="C-"
- SET FBPG=1
- +3 SET (FBAAOUT,FBCNT)=0
- SET QQ="="
- SET $PIECE(QQ,"=",80)="="
- SET Q="-"
- SET $PIECE(Q,"-",80)="-"
- +4 KILL ^TMP("FBPSA",$JOB)
- +5 SET FBPROG=0
- +6 SET FBHPSA=FBPSA
- +7 FOR
- SET FBPROG=$ORDER(FBPROG(FBPROG))
- if 'FBPROG!($GET(FBAAOUT))
- QUIT
- Begin DoDot:1
- +8 IF FBPROG=6
- DO REPORT
- if $GET(FBAAOUT)
- QUIT
- +9 IF FBPROG=7
- DO REPORT
- if $GET(FBAAOUT)
- QUIT
- +10 IF FBPROG=3
- DO ^FBCHPSA1
- if $GET(FBAAOUT)
- QUIT
- +11 IF FBPROG=2
- DO ^FBCHPSA0
- if $GET(FBAAOUT)
- QUIT
- End DoDot:1
- if $GET(FBAAOUT)
- GOTO END
- SET FBPSA=FBHPSA
- +12 ;
- +13 if $GET(FBAAOUT)
- GOTO END
- +14 DO PSATOT^FBCHPSA0
- +15 GOTO END
- REPORT USE IO
- +1 KILL ^TMP("FBPSA",$JOB)
- DO HED
- +2 IF FBPSA>0
- FOR FBI=FBBEG-.1:0
- SET FBI=$ORDER(^FBAAI("AP",FBPSA,FBI))
- if FBI'>0!(FBI>FBEND)!(FBAAOUT)
- QUIT
- FOR FBJ=0:0
- SET FBJ=$ORDER(^FBAAI("AP",FBPSA,FBI,FBJ))
- if FBJ'>0!(FBAAOUT)
- QUIT
- IF $DATA(^FBAAI(FBJ,0))
- SET FBY(0)=^(0)
- DO MORE
- +3 IF FBPSA=0
- FOR FBPSA=0:0
- SET FBPSA=$ORDER(^FBAAI("AP",FBPSA))
- if FBPSA'>0!(FBAAOUT)
- QUIT
- FOR FBI=FBBEG-.1:0
- SET FBI=$ORDER(^FBAAI("AP",FBPSA,FBI))
- if FBI'>0!(FBI>FBEND)!(FBAAOUT)
- QUIT
- FOR FBJ=0:0
- SET FBJ=$ORDER(^FBAAI("AP",FBPSA,FBI,FBJ))
- if FBJ'>0!(FBAAOUT)
- QUIT
- DO MORE1
- +4 if FBAAOUT
- QUIT
- +5 IF $DATA(^TMP("FBPSA",$JOB))
- DO HED1
- FOR I=0:0
- SET I=$ORDER(^TMP("FBPSA",$JOB,I))
- if I'>0
- QUIT
- SET FBSTA=$SELECT($DATA(^DIC(4,I,0)):$PIECE(^(0),"^"),1:"Unknown")
- WRITE !?2,FBSTA,?44,"$ ",$PIECE(^TMP("FBPSA",$JOB,I),"^")
- +6 IF '$DATA(^TMP("FBPSA",$JOB))
- DO NONE^FBCHPSA1
- +7 DO HANG
- +8 QUIT
- +9 ;
- END KILL 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",$JOB),I,J,K,L,FBAMT,FB7078,FBZ,FBPROG,FBHPSA,IOP
- +1 KILL FBK,FBL,FBM,VA,VADM,Y,ZZ,FBOBL,^TMP("FBTOT",$JOB)
- DO CLOSE^FBAAUTL
- +2 QUIT
- MORE1 if '$DATA(^FBAAI(FBJ,0))
- QUIT
- SET FBY(0)=^(0)
- MORE SET (FBDFN,DFN)=$PIECE(FBY(0),"^",4)
- SET FBINV=$PIECE(FBY(0),"^")
- SET FBPPSA=$PIECE(FBY(0),"^",20)
- SET FBAMTPD=$PIECE(FBY(0),"^",9)
- SET FBPDDT=$PIECE(FBY(0),"^",16)
- SET FBPDDT=$$DATX^FBAAUTL(FBPDDT)
- SET VAPA("P")=""
- DO ADD^VADPT
- SET FBCOUNTY=$PIECE(VAPA(7),"^",2)
- +1 if $PIECE(FBY(0),"^",12)'=FBPROG
- QUIT
- +2 SET FB7078=$PIECE(FBY(0),"^",5)
- if FB7078=""
- QUIT
- DO EN1
- SET FBAMTPD=FBAMTPD+FBAMT
- +3 SET FBNAME=$$NAME^FBCHREQ2(FBDFN)
- SET FBSSN=$$SSN^FBAAUTL(FBDFN)
- +4 SET FBSTA=$SELECT($DATA(^DIC(4,FBPPSA,0)):$PIECE(^(0),"^"),1:"Unknown")
- +5 SET FBOBL=$PIECE(FBY(0),"^",17)
- SET FBOBL=$SELECT(FBOBL="":"Unknown",1:$SELECT($DATA(^FBAA(161.7,FBOBL,0)):$PIECE(^(0),"^",2),1:"Unknown"))
- +6 IF $Y+4>IOSL
- DO HANG
- if FBAAOUT
- QUIT
- DO HED
- +7 WRITE !,$EXTRACT(FBNAME,1,30)," -",$$SSN^FBAAUTL(FBDFN,1),?42,FBOBL,?57,FBCOUNTY,!,?4,FBINV,?21,FBAMTPD,?39,FBPDDT,?60,FBSTA,!,Q,!
- +8 if '$DATA(^TMP("FBPSA",$JOB,FBPPSA))
- SET ^TMP("FBPSA",$JOB,FBPPSA)=0
- +9 SET ^TMP("FBPSA",$JOB,FBPPSA)=^TMP("FBPSA",$JOB,FBPPSA)+FBAMTPD
- +10 if '$DATA(^TMP("FBTOT",$JOB,FBPPSA))
- SET ^TMP("FBTOT",$JOB,FBPPSA)=0
- +11 SET ^TMP("FBTOT",$JOB,FBPPSA)=^TMP("FBTOT",$JOB,FBPPSA)+FBAMTPD
- +12 QUIT
- HED if '$GET(FBPG)
- WRITE @IOF
- IF $GET(FBPG)
- KILL FBPG
- +1 WRITE !?25,$SELECT(FBPROG=6:"CIVIL HOSPITAL PSA REPORT",FBPROG=2:"OUTPATIENT MEDICAL PSA REPORT",FBPROG=3:"PHARMACY PSA REPORT",1:"COMMUNITY N.H. PSA REPORT")
- +2 WRITE !?24,"-------------------------------",!,"Patient Name",?40,"Obligation #",?56,"County Code",!
- +3 WRITE ?3,"Invoice #",?20,"Amount Paid",?38,"Date Finalized",?59,"PSA",!,QQ
- +4 QUIT
- SELECT SET DIR(0)="161.01,101"
- DO ^DIR
- if $DATA(DUOUT)
- GOTO END
- if $DATA(DTOUT)
- GOTO H^XUS
- if X=""
- GOTO EN
- SET FBPSA=+Y
- GOTO ASKDT
- HANG IF $EXTRACT(IOST,1,2)["C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET FBAAOUT=1
- +1 QUIT
- HED1 WRITE !,QQ,!?7,"Total Dollars spent by PSA for the dates of ",BEGDATE," to ",ENDDATE,". ",!!?5,"PSA",?40,"TOTAL AMOUNT PAID",!,?4,"-----",?39,"--------------------"
- QUIT
- EN1 SET FBAMT=0
- if '$DATA(^FBAAC("AM",FB7078))
- QUIT
- +1 FOR I=0:0
- SET I=$ORDER(^FBAAC("AM",FB7078,I))
- if I'>0
- QUIT
- FOR J=0:0
- SET J=$ORDER(^FBAAC("AM",FB7078,I,J))
- if J'>0
- QUIT
- FOR K=0:0
- SET K=$ORDER(^FBAAC("AM",FB7078,I,J,K))
- if K'>0
- QUIT
- FOR L=0:0
- SET L=$ORDER(^FBAAC("AM",FB7078,I,J,K,L))
- if L'>0
- QUIT
- IF $DATA(^FBAAC(I,1,J,1,K,1,L,0))
- SET FBZ(0)=^(0)
- DO GT
- +2 QUIT
- GT SET FBAMT=FBAMT+$PIECE(FBZ(0),"^",3)
- QUIT