FBPHON ;AISC/CMR-LIST PAYMENTS ;5/13/1999
;;3.5;FEE BASIS;**4,69**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
S DIR(0)="P^161.2:EMZ" D ^DIR K DIR Q:$D(DIRUT) S FBV=+Y
S DIR(0)="P^161:EMZ",DIR("A")="Payments for veteran" D ^DIR K DIR I $D(DIRUT) G FBPHON
S DFN=+Y
Q
START S U="^"
K ^TMP($J,"FBPHON"),^TMP("FBPHON",$J),^TMP("FBPHIDX",$J)
I '$G(DFN)!('$G(FBV)) S VALMQUIT="" Q
D GATHER^FBPHON1(DFN,FBV)
I '$D(^TMP($J,"FBPHON")),'$G(FBCP) W !!,*7,"There are no payments to this vendor for this patient." S DIR(0)="E" D ^DIR S VALMQUIT=1 G END ;FBCP set only if changing pt
OUTPUT ;
S (FBLINE,FBENTRY)=0,FBAADT="" F S FBAADT=$O(^TMP($J,"FBPHON",FBAADT)) Q:'FBAADT S FBI=0 F S FBI=$O(^TMP($J,"FBPHON",FBAADT,FBI)) Q:'FBI S FBX=^(FBI) D
.S FBBDT=$P($P(FBX,U,2),"-"),FBEDT=$P($P(FBX,U,2),"-",2)
.S FB1=$P(FBX,U,9) D FBCKI^FBAACCB1(FB1):$P(FBX,U)["C",FBCKP^FBAACCB1(+FB1,$P(FB1,",",2)):$P(FBX,U)="PHAR",FBCKO^FBAACCB2(+FB1,$P(FB1,",",2),$P(FB1,",",3),$P(FB1,",",4)):$P(FBX,U)="OPT"
.S FBLINE=FBLINE+1,FBENTRY=FBENTRY+1,FBFL=$P(FBX,U,10),FBFL=FBFL_$S($G(FBCAN)]"":"+",1:"")
.S FBTEXT=$S($L(FBENTRY)=1:" "_FBENTRY,1:FBENTRY)_FBFL,FBTEXT=$$SETSTR^VALM1($$DATE(FBBDT)_$S($G(FBEDT):" - "_$$DATE(FBEDT),1:""),FBTEXT,6,19)
.S FBTEXT=$$SETSTR^VALM1($S($P(FBX,U)="OPT":"CPT: ",$P(FBX,U)="PHAR":"RX # ",1:""),FBTEXT,25,5),FBTEXT=$$SETSTR^VALM1($P(FBX,U,3),FBTEXT,30,8)
.I $P($P(FBX,U,3),",",2)]"" S FBTEXT=$$SETSTR^VALM1("&",FBTEXT,38,1)
.S FBTEXT=$$SETSTR^VALM1($J($FN($P(FBX,U,4),",",2),10),FBTEXT,40,10),FBTEXT=$$SETSTR^VALM1($J($FN($P(FBX,U,5),",",2),10),FBTEXT,51,10),FBTEXT=$$SETSTR^VALM1($P(FBX,U,6),FBTEXT,62,6)
.S FBTEXT=$$SETSTR^VALM1($J($P(FBX,U,7),7)_" "_$S($G(^FBAA(161.7,+$P(FBX,U,8),0)):$J(+^(0),5),1:""),FBTEXT,66,15)
.S ^TMP("FBPHON",$J,FBLINE,0)=FBTEXT K FBTEXT
.D IDX S ^TMP("FBPHIDX",$J,FBENTRY)=FBX_"^"_$G(FBCK)
.S A2=$P(FBX,U,5) D PMNT
.K FBBDT,FBEDT,FB1,FBX,A2,^TMP($J,"FBPHON",FBAADT,FBI)
S VALMCNT=FBLINE,VALMBG=1
END ;
K FBAAOUT,FBX,FBBDT,FBEDT,FBI,FBAADT,FBFL,FBLINE,FBENTRY,^TMP($J,"FBPHON")
Q
HDR S VALMHDR(1)="VENDOR: "_$$VNAME^FBNHEXP(FBV),VALMHDR(1)=$$SETSTR^VALM1("Patient Name: "_$$NAME^FBCHREQ2(DFN),VALMHDR(1),40,40)
S VALMHDR(2)=" ID: "_$$VID^FBNHEXP(FBV),VALMHDR(2)=$$SETSTR^VALM1("SSN: "_$$SSN^FBAAUTL(DFN),VALMHDR(2),49,31)
S VALMHDR(3)="'*' Reimb. to Patient '+' Cancel Activity '#' Voided Payment '&' Addnl Codes"
Q
DATE(J) ;external date format
Q $S('$D(J):"",1:$E(J,4,5)_"/"_$E(J,6,7)_"/"_$E(J,2,3))
;
PMNT ;sets ^TMP with payment information if it exists
I $G(FBCK)]"" S FBLINE=FBLINE+1,^TMP("FBPHON",$J,FBLINE,0)=" >>>Check # "_FBCK I $G(FBCKDT) S ^(0)=^(0)_" Date Paid: "_$$DATX^FBAAUTL(FBCKDT)_$S(FBCKINT>0:" Interest: "_$FN(FBCKINT,",",2),1:"")_"<<<" D IDX D
.I FBDIS-FBCKINT'=+A2 S FBLINE=FBLINE+1,^TMP("FBPHON",$J,FBLINE,0)=" >>>Amount paid altered to $ "_$FN((FBDIS-FBCKINT),",",2)_" on the Fee Payment Voucher document.<<<" D IDX
I $G(FBCANDT)>0 S FBLINE=FBLINE+1,^TMP("FBPHON",$J,FBLINE,0)=" >>>Check cancelled on: "_$$DATX^FBAAUTL(FBCANDT)_" Reason: "_$P($G(^FB(162.95,+FBCANR,0)),"^")_"<<<" D IDX D
.S FBLINE=FBLINE+1,^TMP("FBPHON",$J,FBLINE,0)=$$SETSTR^VALM1($S(FBCAN="R":"Check WILL be replaced.",FBCAN="C":"Check WILL be re-issued.",FBCAN="X":"Check WILL NOT be replaced.",1:""),"",10,70) D IDX
K FBCAN,FBCK,FBCKDT,FBCANDT,FBCANR,FBCKINT,FBDIS,FBCKIN
Q
IDX ;sets IDX node
S ^TMP("FBPHON",$J,"IDX",FBLINE,FBENTRY)=""
Q
EXIT ;
K ^TMP("FBPHON",$J),^TMP("FBPHIDX",$J),VALMY,^TMP("VALMIDX",$J)
Q
HLP ;help text
S X="?" D DISP^XQORM1 W !!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPHON 3642 printed Oct 16, 2024@18:00:30 Page 2
FBPHON ;AISC/CMR-LIST PAYMENTS ;5/13/1999
+1 ;;3.5;FEE BASIS;**4,69**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET DIR(0)="P^161.2:EMZ"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET FBV=+Y
+4 SET DIR(0)="P^161:EMZ"
SET DIR("A")="Payments for veteran"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO FBPHON
+5 SET DFN=+Y
+6 QUIT
START SET U="^"
+1 KILL ^TMP($JOB,"FBPHON"),^TMP("FBPHON",$JOB),^TMP("FBPHIDX",$JOB)
+2 IF '$GET(DFN)!('$GET(FBV))
SET VALMQUIT=""
QUIT
+3 DO GATHER^FBPHON1(DFN,FBV)
+4 ;FBCP set only if changing pt
IF '$DATA(^TMP($JOB,"FBPHON"))
IF '$GET(FBCP)
WRITE !!,*7,"There are no payments to this vendor for this patient."
SET DIR(0)="E"
DO ^DIR
SET VALMQUIT=1
GOTO END
OUTPUT ;
+1 SET (FBLINE,FBENTRY)=0
SET FBAADT=""
FOR
SET FBAADT=$ORDER(^TMP($JOB,"FBPHON",FBAADT))
if 'FBAADT
QUIT
SET FBI=0
FOR
SET FBI=$ORDER(^TMP($JOB,"FBPHON",FBAADT,FBI))
if 'FBI
QUIT
SET FBX=^(FBI)
Begin DoDot:1
+2 SET FBBDT=$PIECE($PIECE(FBX,U,2),"-")
SET FBEDT=$PIECE($PIECE(FBX,U,2),"-",2)
+3 SET FB1=$PIECE(FBX,U,9)
if $PIECE(FBX,U)["C"
DO FBCKI^FBAACCB1(FB1)
if $PIECE(FBX,U)="PHAR"
DO FBCKP^FBAACCB1(+FB1,$PIECE(FB1,",",2))
if $PIECE(FBX,U)="OPT"
DO FBCKO^FBAACCB2(+FB1,$PIECE(FB1,",",2),$PIECE(FB1,",",3),$PIECE(FB1,",",4))
+4 SET FBLINE=FBLINE+1
SET FBENTRY=FBENTRY+1
SET FBFL=$PIECE(FBX,U,10)
SET FBFL=FBFL_$SELECT($GET(FBCAN)]"":"+",1:"")
+5 SET FBTEXT=$SELECT($LENGTH(FBENTRY)=1:" "_FBENTRY,1:FBENTRY)_FBFL
SET FBTEXT=$$SETSTR^VALM1($$DATE(FBBDT)_$SELECT($GET(FBEDT):" - "_$$DATE(FBEDT),1:""),FBTEXT,6,19)
+6 SET FBTEXT=$$SETSTR^VALM1($SELECT($PIECE(FBX,U)="OPT":"CPT: ",$PIECE(FBX,U)="PHAR":"RX # ",1:""),FBTEXT,25,5)
SET FBTEXT=$$SETSTR^VALM1($PIECE(FBX,U,3),FBTEXT,30,8)
+7 IF $PIECE($PIECE(FBX,U,3),",",2)]""
SET FBTEXT=$$SETSTR^VALM1("&",FBTEXT,38,1)
+8 SET FBTEXT=$$SETSTR^VALM1($JUSTIFY($FNUMBER($PIECE(FBX,U,4),",",2),10),FBTEXT,40,10)
SET FBTEXT=$$SETSTR^VALM1($JUSTIFY($FNUMBER($PIECE(FBX,U,5),",",2),10),FBTEXT,51,10)
SET FBTEXT=$$SETSTR^VALM1($PIECE(FBX,U,6),FBTEXT,62,6)
+9 SET FBTEXT=$$SETSTR^VALM1($JUSTIFY($PIECE(FBX,U,7),7)_" "_$SELECT($GET(^FBAA(161.7,+$PIECE(FBX,U,8),0)):$JUSTIFY(+^(0),5),1:""),FBTEXT,66,15)
+10 SET ^TMP("FBPHON",$JOB,FBLINE,0)=FBTEXT
KILL FBTEXT
+11 DO IDX
SET ^TMP("FBPHIDX",$JOB,FBENTRY)=FBX_"^"_$GET(FBCK)
+12 SET A2=$PIECE(FBX,U,5)
DO PMNT
+13 KILL FBBDT,FBEDT,FB1,FBX,A2,^TMP($JOB,"FBPHON",FBAADT,FBI)
End DoDot:1
+14 SET VALMCNT=FBLINE
SET VALMBG=1
END ;
+1 KILL FBAAOUT,FBX,FBBDT,FBEDT,FBI,FBAADT,FBFL,FBLINE,FBENTRY,^TMP($JOB,"FBPHON")
+2 QUIT
HDR SET VALMHDR(1)="VENDOR: "_$$VNAME^FBNHEXP(FBV)
SET VALMHDR(1)=$$SETSTR^VALM1("Patient Name: "_$$NAME^FBCHREQ2(DFN),VALMHDR(1),40,40)
+1 SET VALMHDR(2)=" ID: "_$$VID^FBNHEXP(FBV)
SET VALMHDR(2)=$$SETSTR^VALM1("SSN: "_$$SSN^FBAAUTL(DFN),VALMHDR(2),49,31)
+2 SET VALMHDR(3)="'*' Reimb. to Patient '+' Cancel Activity '#' Voided Payment '&' Addnl Codes"
+3 QUIT
DATE(J) ;external date format
+1 QUIT $SELECT('$DATA(J):"",1:$EXTRACT(J,4,5)_"/"_$EXTRACT(J,6,7)_"/"_$EXTRACT(J,2,3))
+2 ;
PMNT ;sets ^TMP with payment information if it exists
+1 IF $GET(FBCK)]""
SET FBLINE=FBLINE+1
SET ^TMP("FBPHON",$JOB,FBLINE,0)=" >>>Check # "_FBCK
IF $GET(FBCKDT)
SET ^(0)=^(0)_" Date Paid: "_$$DATX^FBAAUTL(FBCKDT)_$SELECT(FBCKINT>0:" Interest: "_$FNUMBER(FBCKINT,",",2),1:"")_"<<<"
DO IDX
Begin DoDot:1
+2 IF FBDIS-FBCKINT'=+A2
SET FBLINE=FBLINE+1
SET ^TMP("FBPHON",$JOB,FBLINE,0)=" >>>Amount paid altered to $ "_$FNUMBER((FBDIS-FBCKINT),",",2)_" on the Fee Payment Voucher document.<<<"
DO IDX
End DoDot:1
+3 IF $GET(FBCANDT)>0
SET FBLINE=FBLINE+1
SET ^TMP("FBPHON",$JOB,FBLINE,0)=" >>>Check cancelled on: "_$$DATX^FBAAUTL(FBCANDT)_" Reason: "_$PIECE($GET(^FB(162.95,+FBCANR,0)),"^")_"<<<"
DO IDX
Begin DoDot:1
+4 SET FBLINE=FBLINE+1
SET ^TMP("FBPHON",$JOB,FBLINE,0)=$$SETSTR^VALM1($SELECT(FBCAN="R":"Check WILL be replaced.",FBCAN="C":"Check WILL be re-issued.",FBCAN="X":"Check WILL NOT be replaced.",1:""),"",10,70)
DO IDX
End DoDot:1
+5 KILL FBCAN,FBCK,FBCKDT,FBCANDT,FBCANR,FBCKINT,FBDIS,FBCKIN
+6 QUIT
IDX ;sets IDX node
+1 SET ^TMP("FBPHON",$JOB,"IDX",FBLINE,FBENTRY)=""
+2 QUIT
EXIT ;
+1 KILL ^TMP("FBPHON",$JOB),^TMP("FBPHIDX",$JOB),VALMY,^TMP("VALMIDX",$JOB)
+2 QUIT
HLP ;help text
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
