- FBCHPSA1 ;AISC/DMK-PSA OUTPUT CONTINUED ; 18JUN90
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- RX ;
- D HED^FBCHPSA K ^TMP("FBPSA",$J)
- I FBPSA>0 F FBI=FBBEG-.1:0 S FBI=$O(^FBAA(162.1,"AI",FBPSA,FBI)) Q:FBI'>0!(FBI>FBEND)!(FBAAOUT) D MORE
- I FBPSA=0 F FBPSA=0:0 S FBPSA=$O(^FBAA(162.1,"AI",FBPSA)) Q:FBPSA'>0!(FBAAOUT) F FBI=FBBEG-.1:0 S FBI=$O(^FBAA(162.1,"AI",FBPSA,FBI)) Q:FBI'>0!(FBI>FBEND)!(FBAAOUT) D MORE
- 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
- D HANG^FBCHPSA
- Q
- MORE F FBK=0:0 S FBK=$O(^FBAA(162.1,"AI",FBPSA,FBI,FBK)) Q:FBK'>0!(FBAAOUT) F FBL=0:0 S FBL=$O(^FBAA(162.1,"AI",FBPSA,FBI,FBK,FBL)) Q:FBL'>0!(FBAAOUT) I $D(^FBAA(162.1,FBK,"RX",FBL,0)) S FBI(0)=^(0),FBK(0)=^(2) D WRT
- Q
- WRT S DFN=$P(FBI(0),"^",5) D 4^VADPT S FBNAME=VADM(1),FBCOUNTY=$P(VAPA(7),"^",2),FBINV=FBK,FBAMTPD=$P(FBI(0),"^",16),FBPDDT=$P(FBI(0),"^",19),FBPDDT=$$DATX^FBAAUTL(FBPDDT),FBPPSA=$P(FBK(0),"^",5)
- S FBOBL=$S($P(FBI(0),"^",18)="":"Unknown",1:$P(FBI(0),"^",18))
- 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
- ;
- PROG ;one/many/all fee programs
- ; returns FBPROG(ien)=external value
- ;
- N DIC,VAUTSTR,VAUTNI,VAUTVB
- S DIC="^FBAA(161.8,",DIC("S")="I $P(^(0),U,3)"
- S VAUTSTR="FEE PROGRAM",VAUTNI=2,VAUTVB="FBPROG"
- D FIRST^VAUTOMA
- I 'FBPROG&('$O(FBPROG(0))) Q
- I FBPROG D
- . N X S X=0
- . F S X=$O(^FBAA(161.8,X)) Q:'X S X(0)=$G(^(X,0)) I $P(X(0),U,3) S FBPROG(X)=$P(X(0),U)
- Q
- ;
- NONE ;write no payments found for this program and quit
- W !!,"No payments found for this Fee Program.",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHPSA1 2176 printed Jan 18, 2025@02:59:04 Page 2
- FBCHPSA1 ;AISC/DMK-PSA OUTPUT CONTINUED ; 18JUN90
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- RX ;
- +1 DO HED^FBCHPSA
- KILL ^TMP("FBPSA",$JOB)
- +2 IF FBPSA>0
- FOR FBI=FBBEG-.1:0
- SET FBI=$ORDER(^FBAA(162.1,"AI",FBPSA,FBI))
- if FBI'>0!(FBI>FBEND)!(FBAAOUT)
- QUIT
- DO MORE
- +3 IF FBPSA=0
- FOR FBPSA=0:0
- SET FBPSA=$ORDER(^FBAA(162.1,"AI",FBPSA))
- if FBPSA'>0!(FBAAOUT)
- QUIT
- FOR FBI=FBBEG-.1:0
- SET FBI=$ORDER(^FBAA(162.1,"AI",FBPSA,FBI))
- if FBI'>0!(FBI>FBEND)!(FBAAOUT)
- QUIT
- DO MORE
- +4 if FBAAOUT
- QUIT
- +5 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),"^")
- +6 IF '$DATA(^TMP("FBPSA",$JOB))
- DO NONE
- +7 DO HANG^FBCHPSA
- +8 QUIT
- MORE FOR FBK=0:0
- SET FBK=$ORDER(^FBAA(162.1,"AI",FBPSA,FBI,FBK))
- if FBK'>0!(FBAAOUT)
- QUIT
- FOR FBL=0:0
- SET FBL=$ORDER(^FBAA(162.1,"AI",FBPSA,FBI,FBK,FBL))
- if FBL'>0!(FBAAOUT)
- QUIT
- IF $DATA(^FBAA(162.1,FBK,"RX",FBL,0))
- SET FBI(0)=^(0)
- SET FBK(0)=^(2)
- DO WRT
- +1 QUIT
- WRT SET DFN=$PIECE(FBI(0),"^",5)
- DO 4^VADPT
- SET FBNAME=VADM(1)
- SET FBCOUNTY=$PIECE(VAPA(7),"^",2)
- SET FBINV=FBK
- SET FBAMTPD=$PIECE(FBI(0),"^",16)
- SET FBPDDT=$PIECE(FBI(0),"^",19)
- SET FBPDDT=$$DATX^FBAAUTL(FBPDDT)
- SET FBPPSA=$PIECE(FBK(0),"^",5)
- +1 SET FBOBL=$SELECT($PIECE(FBI(0),"^",18)="":"Unknown",1:$PIECE(FBI(0),"^",18))
- +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
- +10 ;
- PROG ;one/many/all fee programs
- +1 ; returns FBPROG(ien)=external value
- +2 ;
- +3 NEW DIC,VAUTSTR,VAUTNI,VAUTVB
- +4 SET DIC="^FBAA(161.8,"
- SET DIC("S")="I $P(^(0),U,3)"
- +5 SET VAUTSTR="FEE PROGRAM"
- SET VAUTNI=2
- SET VAUTVB="FBPROG"
- +6 DO FIRST^VAUTOMA
- +7 IF 'FBPROG&('$ORDER(FBPROG(0)))
- QUIT
- +8 IF FBPROG
- Begin DoDot:1
- +9 NEW X
- SET X=0
- +10 FOR
- SET X=$ORDER(^FBAA(161.8,X))
- if 'X
- QUIT
- SET X(0)=$GET(^(X,0))
- IF $PIECE(X(0),U,3)
- SET FBPROG(X)=$PIECE(X(0),U)
- End DoDot:1
- +11 QUIT
- +12 ;
- NONE ;write no payments found for this program and quit
- +1 WRITE !!,"No payments found for this Fee Program.",!
- +2 QUIT