- FBCHPSA0 ;AISC/DMK-PSA OUTPUT CONTINUED ;13JUN90
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- D HED^FBCHPSA K ^TMP("FBPSA",$J)
- EN I FBPSA>0 F FBI=FBBEG-.1:0 S FBI=$O(^FBAAC("AQ",FBPSA,FBI)) Q:FBI'>0!(FBI>FBEND)!(FBAAOUT) F FBJ=0:0 S FBJ=$O(^FBAAC("AQ",FBPSA,FBI,FBJ)) Q:FBJ'>0!(FBAAOUT) F FBK=0:0 S FBK=$O(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK)) Q:FBK'>0!(FBAAOUT) D MORE
- I FBPSA=0 F FBPSA=0:0 S FBPSA=$O(^FBAAC("AQ",FBPSA)) Q:FBPSA'>0!(FBAAOUT) F FBI=FBBEG-.1:0 S FBI=$O(^FBAAC("AQ",FBPSA,FBI)) Q:FBI'>0!(FBI>FBEND)!(FBAAOUT) F FBJ=0:0 S FBJ=$O(^FBAAC("AQ",FBPSA,FBI,FBJ)) Q:FBJ'>0 D MORE1
- Q:FBAAOUT
- I $D(^TMP("FBPSA",$J)) D HED1^FBCHPSA 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^FBCHPSA
- Q
- ;
- PSATOT Q:'$O(^TMP("FBTOT",$J,0)) D HED2
- F I=0:0 S I=$O(^TMP("FBTOT",$J,I)) Q:I'>0 S FBSTA=$S($D(^DIC(4,I,0)):$P(^(0),"^"),1:"Unknown") W !?2,FBSTA,?44,"$ ",^TMP("FBTOT",$J,I)
- Q
- HED2 W @IOF,!?13,"TOTALS DOLLAR AMOUNT BY PSA FOR ALL SELECTED PROGRAMS",!?12,$E(Q,1,55),!!,"For Date Range: ",BEGDATE," to ",ENDDATE,!,QQ
- W !?5,"PSA",?40,"TOTAL AMOUNT",!,?4,"-----",?39,"--------------------"
- Q
- MORE F FBL=0:0 S FBL=$O(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK,FBL)) Q:FBL'>0!(FBAAOUT) F FBM=0:0 S FBM=$O(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK,FBL,FBM)) Q:FBM'>0 I $D(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,0)) S FBY(0)=^(0) D GET
- Q
- GET S DFN=FBJ,VAPA("P")="" D 4^VADPT S FBNAME=VADM(1),FBCOUNTY=$P(VAPA(7),"^",2),FBINV=$P(FBY(0),"^",16),FBAMTPD=$P(FBY(0),"^",3),FBPDDT=$P(FBY(0),"^",6),FBPDDT=$$DATX^FBAAUTL(FBPDDT),FBPPSA=$P(FBY(0),"^",12)
- S FBOBL=$S($P(FBY(0),"^",10)="":"Unknown",1:$P(FBY(0),"^",10))
- S FBSTA=$S($D(^DIC(4,FBPPSA,0)):$P(^(0),"^"),1:"Unknown")
- I $Y+4>IOSL D HANG^FBCHPSA Q:FBAAOUT D HED^FBCHPSA
- W !,$E(FBNAME,1,30)," -",VA("BID"),?42,FBOBL,?57,FBCOUNTY,!,?4,FBINV,?21,FBAMTPD,?39,FBPDDT,?60,FBSTA,!,Q,!
- S:'$D(^TMP("FBPSA",$J,FBPSA)) ^TMP("FBPSA",$J,FBPSA)=0
- S ^TMP("FBPSA",$J,FBPSA)=^TMP("FBPSA",$J,FBPSA)+FBAMTPD
- S:'$D(^TMP("FBTOT",$J,FBPSA)) ^TMP("FBTOT",$J,FBPSA)=0
- S ^TMP("FBTOT",$J,FBPSA)=^TMP("FBTOT",$J,FBPSA)+FBAMTPD
- Q
- MORE1 F FBK=0:0 S FBK=$O(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK)) Q:FBK'>0!(FBAAOUT) F FBL=0:0 S FBL=$O(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK,FBL)) Q:FBL'>0!(FBAAOUT) F FBM=0:0 S FBM=$O(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK,FBL,FBM)) Q:FBM'>0 D MORE2
- Q
- MORE2 I $D(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,0)) S FBY(0)=^(0) D GET
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHPSA0 2564 printed Jan 18, 2025@02:59:03 Page 2
- FBCHPSA0 ;AISC/DMK-PSA OUTPUT CONTINUED ;13JUN90
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO HED^FBCHPSA
- KILL ^TMP("FBPSA",$JOB)
- EN IF FBPSA>0
- FOR FBI=FBBEG-.1:0
- SET FBI=$ORDER(^FBAAC("AQ",FBPSA,FBI))
- if FBI'>0!(FBI>FBEND)!(FBAAOUT)
- QUIT
- FOR FBJ=0:0
- SET FBJ=$ORDER(^FBAAC("AQ",FBPSA,FBI,FBJ))
- if FBJ'>0!(FBAAOUT)
- QUIT
- FOR FBK=0:0
- SET FBK=$ORDER(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK))
- if FBK'>0!(FBAAOUT)
- QUIT
- DO MORE
- +1 IF FBPSA=0
- FOR FBPSA=0:0
- SET FBPSA=$ORDER(^FBAAC("AQ",FBPSA))
- if FBPSA'>0!(FBAAOUT)
- QUIT
- FOR FBI=FBBEG-.1:0
- SET FBI=$ORDER(^FBAAC("AQ",FBPSA,FBI))
- if FBI'>0!(FBI>FBEND)!(FBAAOUT)
- QUIT
- FOR FBJ=0:0
- SET FBJ=$ORDER(^FBAAC("AQ",FBPSA,FBI,FBJ))
- if FBJ'>0
- QUIT
- DO MORE1
- +2 if FBAAOUT
- QUIT
- +3 IF $DATA(^TMP("FBPSA",$JOB))
- DO HED1^FBCHPSA
- 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),"^")
- +4 IF '$DATA(^TMP("FBPSA",$JOB))
- DO NONE^FBCHPSA1
- +5 DO HANG^FBCHPSA
- +6 QUIT
- +7 ;
- PSATOT if '$ORDER(^TMP("FBTOT",$JOB,0))
- QUIT
- DO HED2
- +1 FOR I=0:0
- SET I=$ORDER(^TMP("FBTOT",$JOB,I))
- if I'>0
- QUIT
- SET FBSTA=$SELECT($DATA(^DIC(4,I,0)):$PIECE(^(0),"^"),1:"Unknown")
- WRITE !?2,FBSTA,?44,"$ ",^TMP("FBTOT",$JOB,I)
- +2 QUIT
- HED2 WRITE @IOF,!?13,"TOTALS DOLLAR AMOUNT BY PSA FOR ALL SELECTED PROGRAMS",!?12,$EXTRACT(Q,1,55),!!,"For Date Range: ",BEGDATE," to ",ENDDATE,!,QQ
- +1 WRITE !?5,"PSA",?40,"TOTAL AMOUNT",!,?4,"-----",?39,"--------------------"
- +2 QUIT
- MORE FOR FBL=0:0
- SET FBL=$ORDER(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK,FBL))
- if FBL'>0!(FBAAOUT)
- QUIT
- FOR FBM=0:0
- SET FBM=$ORDER(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK,FBL,FBM))
- if FBM'>0
- QUIT
- IF $DATA(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,0))
- SET FBY(0)=^(0)
- DO GET
- +1 QUIT
- GET SET DFN=FBJ
- SET VAPA("P")=""
- DO 4^VADPT
- SET FBNAME=VADM(1)
- SET FBCOUNTY=$PIECE(VAPA(7),"^",2)
- SET FBINV=$PIECE(FBY(0),"^",16)
- SET FBAMTPD=$PIECE(FBY(0),"^",3)
- SET FBPDDT=$PIECE(FBY(0),"^",6)
- SET FBPDDT=$$DATX^FBAAUTL(FBPDDT)
- SET FBPPSA=$PIECE(FBY(0),"^",12)
- +1 SET FBOBL=$SELECT($PIECE(FBY(0),"^",10)="":"Unknown",1:$PIECE(FBY(0),"^",10))
- +2 SET FBSTA=$SELECT($DATA(^DIC(4,FBPPSA,0)):$PIECE(^(0),"^"),1:"Unknown")
- +3 IF $Y+4>IOSL
- DO HANG^FBCHPSA
- if FBAAOUT
- QUIT
- DO HED^FBCHPSA
- +4 WRITE !,$EXTRACT(FBNAME,1,30)," -",VA("BID"),?42,FBOBL,?57,FBCOUNTY,!,?4,FBINV,?21,FBAMTPD,?39,FBPDDT,?60,FBSTA,!,Q,!
- +5 if '$DATA(^TMP("FBPSA",$JOB,FBPSA))
- SET ^TMP("FBPSA",$JOB,FBPSA)=0
- +6 SET ^TMP("FBPSA",$JOB,FBPSA)=^TMP("FBPSA",$JOB,FBPSA)+FBAMTPD
- +7 if '$DATA(^TMP("FBTOT",$JOB,FBPSA))
- SET ^TMP("FBTOT",$JOB,FBPSA)=0
- +8 SET ^TMP("FBTOT",$JOB,FBPSA)=^TMP("FBTOT",$JOB,FBPSA)+FBAMTPD
- +9 QUIT
- MORE1 FOR FBK=0:0
- SET FBK=$ORDER(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK))
- if FBK'>0!(FBAAOUT)
- QUIT
- FOR FBL=0:0
- SET FBL=$ORDER(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK,FBL))
- if FBL'>0!(FBAAOUT)
- QUIT
- FOR FBM=0:0
- SET FBM=$ORDER(^FBAAC("AQ",FBPSA,FBI,FBJ,FBK,FBL,FBM))
- if FBM'>0
- QUIT
- DO MORE2
- +1 QUIT
- MORE2 IF $DATA(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,0))
- SET FBY(0)=^(0)
- DO GET
- +1 QUIT