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 Dec 13, 2024@01:57:51 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
