Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBPAY671

FBPAY671.m

Go to the documentation of this file.
  1. FBPAY671 ;AISC/DMK,TET,BPOIFO/MEC - CH/CNH PAYMENT HISTORY PRINT ; 9/14/09 3:34pm
  1. ;;3.5;FEE BASIS;**4,32,55,69,101,108**;JAN 30, 1995;Build 115
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. PRINT ;print data from tmp global
  1. S FBOUT=0 D:FBCRT&(FBPG) CR Q:FBOUT
  1. S FBHEAD=$S(FBSORT:"VETERAN",1:"VENDOR")
  1. EN1 N FBI,FBINV ;entry point from fbchdi
  1. D HDR S FBVI="" F S FBVI=$O(^TMP($J,"FB",FBPI,FBVI)) Q:FBVI']""!(FBOUT) D:FBSORT SH Q:FBOUT S FBPT="" F S FBPT=$O(^TMP($J,"FB",FBPI,FBVI,FBPT)) Q:FBPT']""!(FBOUT) D Q:FBOUT D CKANC Q:FBOUT
  1. .D:'FBSORT SH Q:FBOUT S FBDT=0 F S FBDT=$O(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT)) Q:'FBDT!(FBOUT) S FBI=0 F S FBI=$O(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,FBI)) Q:'FBI!(FBOUT) D Q:FBOUT
  1. ..I ($Y+5)>IOSL D PAGE Q:FBOUT
  1. ..S FBDATA=^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,FBI),A2=$$EXTRL^FBMRASVR($P(FBDATA,U,3))
  1. ..S FBINV=^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,FBI,"FBINV")
  1. ..W ! W:$P(FBDATA,U,8)["R" "*" W:$P(FBDATA,U,9)]"" "#"
  1. ..W ?2,$P(FBDATA,U,1),?15,$P(FBDATA,U,5),?31,$P(FBDATA,U,6)
  1. ..W ?47,$P(FBDATA,U,7),?57,$P(FBINV,U,2)
  1. ..W !?2,$P(FBDATA,U,2),?15,$P(FBDATA,U,3),?25,$P(FBINV,U,1)
  1. .. ;Print adj reasons, if null then print suspend code
  1. ..W ?36,$S($P(FBINV,U,5)]"":$P(FBINV,U,5),1:$P(FBDATA,U,4))
  1. ..W ?46,$S($P(FBINV,U,5)]"":$J($P(FBINV,U,6),14),1:$J($P(FBDATA,U,10),14))
  1. ..W ?63,$P(FBINV,U,7)
  1. .. ;If FPPS Claim ID exists then print it.
  1. ..I $P(FBINV,U,3)]"" D
  1. ...W !?5,"FPPS Claim ID: ",$P(FBINV,U,3)," FPPS Line Item: ",$P(FBINV,U,4)
  1. .. ; write admitting diagnosis if present
  1. ..I $P(FBINV,U,8)'="" W !?6,"Admit Dx: ",$P(FBINV,U,8)
  1. ..I $D(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,FBI,"DX")) S FBDATA=^("DX"),FBSL=$L(FBDATA,"^") F I=1:1:FBSL D WRTDX
  1. ..I $D(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,FBI,"PROC")) S FBDATA=^("PROC"),FBSL=$L(FBDATA,"^") F I=1:1:FBSL D WRTPC
  1. ..I $D(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,FBI,"FBCK")) D EFBCK^FBPAY21(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,FBI,"FBCK")) D PMNT^FBAACCB2 K A2
  1. Q
  1. CKANC I +$O(^TMP($J,"FB",FBPI,FBVI,FBPT,"A",0)) D PANC(FBI) Q:FBOUT W !,FBDASH1
  1. Q
  1. PANC(FBI) ;print anc data - FBI = unique number; called by fbpay3
  1. S (FBOV,FBK)=0,FBSL=8,FBLOC=1_U_12_U_23_U_33_U_43_U_56_U_62_U_71 D SHA Q:FBOUT
  1. F S FBK=$O(^TMP($J,"FB",FBPI,FBVI,FBPT,"A",FBK)) Q:'FBK!(FBOUT) S FBL=0 F S FBL=$O(^TMP($J,"FB",FBPI,FBVI,FBPT,"A",FBK,FBL)) Q:'FBL!(FBOUT) S FBM=0 F S FBM=$O(^TMP($J,"FB",FBPI,FBVI,FBPT,"A",FBK,FBL,FBM)) Q:'FBM!(FBOUT) D
  1. .S FBDATA=^TMP($J,"FB",FBPI,FBVI,FBPT,"A",FBK,FBL,FBM)
  1. .S FBV=$P(FBDATA,U,12)_";"_$P(FBDATA,U,13)
  1. .D WRT
  1. K FBK,FBL,FBM Q
  1. WRT ;write ancillary info
  1. I ($Y+6)>IOSL D PAGE Q:FBOUT D SHA Q:FBOUT D SHA2 Q:FBOUT
  1. D:FBOV'=FBV SHA2
  1. S FBCKIN=$G(^TMP($J,"FB",FBPI,FBVI,FBPT,"A",FBK,FBL,FBM,"FBCK")) D EFBCK^FBPAY21(FBCKIN)
  1. S FBADJ=$G(^TMP($J,"FB",FBPI,FBVI,FBPT,"A",FBK,FBL,FBM,"FBADJ"))
  1. W ! W:$G(FBCAN)]"" "+"
  1. W ?1,$P(FBDATA,U,1)
  1. W ?11,$P($P(FBDATA,U,2),",")
  1. W ?22,$P(FBADJ,U,9)
  1. W ?31,$J($P(FBADJ,U,2),10)
  1. W ?43,$P(FBDATA,U,6)
  1. W ?54,$P(FBDATA,U,7)
  1. W ?64,$P(FBDATA,U,8)
  1. I $P($P(FBDATA,U,2),",",2)]"" D Q:FBOUT
  1. . N FBI,FBMOD
  1. . F FBI=2:1 S FBMOD=$P($P(FBDATA,U,2),",",FBI) Q:FBMOD="" D Q:FBOUT
  1. . . I $Y+7>IOSL D PAGE Q:FBOUT D SHA Q:FBOUT D SHA2 Q:FBOUT W !," (continued)"
  1. . . W !?16,"-",FBMOD
  1. W !,$P(FBDATA,U,3)
  1. W ?13,$P(FBDATA,U,4)
  1. W ?23,$S($P(FBADJ,U,3)]"":$P(FBADJ,U,3),1:$P(FBDATA,U,5))
  1. W ?33,$J($S($P(FBADJ,U,4)]"":$J($P(FBADJ,U,4),14),1:$P(FBADJ,U,1)),14)
  1. W ?48,$P(FBADJ,U,5)
  1. W ?60,$P(FBADJ,U,6)
  1. ;If FPPS Claim ID exists then print it.
  1. I $P(FBADJ,U,7)]"" D
  1. .W !?5,"FPPS Claim ID: ",$P(FBADJ,U,7)," FPPS Line Item: ",$P(FBADJ,U,8)
  1. W !?4,"Primary Dx: ",$P(FBDATA,U,10),?40,"S/C Condition? ",$P(FBDATA,U,9),?66,"Obl.#: ",$P(FBDATA,U,11)
  1. N A2 S A2=$$EXTRL^FBMRASVR($P(FBDATA,U,4))
  1. D PMNT^FBAACCB2
  1. Q
  1. HDR ;main header
  1. I FBPG>0!FBCRT W @IOF
  1. S FBPG=FBPG+1
  1. I $D(FBHEAD) D
  1. .W !?25,FBHEAD_" PAYMENT HISTORY"
  1. .I $G(FB1725R)]"",FB1725R'="A" W " ",$S(FB1725R="M":"for 38 U.S.C. 1725 Claims",1:"excluding 38 U.S.C. 1725 Claims")
  1. .W !,?24,$E(FBDASH,1,24),?71,"Page: ",FBPG,!?48,"Date Range: ",$$DATX^FBAAUTL(FBBDATE)," to ",$$DATX^FBAAUTL(FBEDATE)
  1. I '$D(FBHEAD) W !?30,"INVOICE DISPLAY",!?29,$E(FBDASH,1,17),!
  1. W ! W:FBSORT "Patient: ",FBPNAME,?41,"Patient ID: ",FBPID W:'FBSORT "Vendor: ",FBVNAME,?41,"Vendor ID: ",FBVID
  1. W !?(IOM-(13+$L(FBPROG(+FBPI)))/2),"FEE PROGRAM: ",FBPROG(+FBPI)
  1. W !?3,"('*' Reimb. to Patient '+' Cancel. Activity '#' Voided Payment)"
  1. W !,?3,"(paid symbol: 'R' RBRVS 'F' 75th percentile 'C' contract 'M' Mill Bill"
  1. W !,?3," 'U' U&C)"
  1. W !?1,"Invoice Date",?15,"Invoice No.",?31,"From Date",?48,"To Date",?57,"Patient Control #"
  1. W !?1,"Amt Claimed",?15,"Amt Paid",?25,"Cov Days",?36,"Adj Codes",?49,"Adj Amounts",?63,"Remit Remarks",!,FBDASH
  1. Q
  1. SH ;subheader - vendor if fbsort; patient if 'fbsort, prints when name changed
  1. I ($Y+7)>IOSL D:FBCRT CR Q:FBOUT D HDR
  1. I FBSORT W !!,"Vendor: ",$P(FBVI,";"),?41,"Vendor ID: ",$P(FBVI,";",2)
  1. I 'FBSORT W !!,"Patient: ",$P(FBPT,";"),?41,"Patient ID: ",$$SSNL4^FBAAUTL($$SSN^FBAAUTL($P(FBPT,";",2)))
  1. Q
  1. SHA ;ancillary subheader
  1. I ($Y+14)>IOSL D PAGE Q:FBOUT
  1. W !?20,">>> ANCILLARY SERVICE PAYMENTS <<<",!
  1. SHA1 ;subheader for ancillary data
  1. W !,?1,"Svc Date",?11,"CPT-MOD ",?21,"Rev Code",?31,"Units Paid",?43,"Batch No.",?54,"Inv No.",?64,"Voucher Date"
  1. W !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36,"Adj Amounts",?48,"Remit Remark",?61,"Patient Account No",!,FBDASH
  1. Q
  1. SHA2 ;subheader for vendor name
  1. I ($Y+5)>IOSL D:FBCRT CR Q:FBOUT D HDR,SH,SHA
  1. I FBOV'=FBV S FBOV=FBV
  1. W !!,"Vendor: ",$P(FBV,";"),?41,"Vendor ID: ",$P(FBV,";",2)
  1. Q
  1. CR ;read for display
  1. Q:'FBPG S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1
  1. Q
  1. PAGE ;new page
  1. I FBCRT D CR Q:FBOUT
  1. D HDR,SH
  1. Q
  1. WRTDX ; inputs
  1. ; FBDATA contains node from ^TMP
  1. ; I contains piece to be written
  1. I I=1!($X+$L($P(FBDATA,"^",I))+2>IOM) W !,?4,"DX/POA: "
  1. W $P(FBDATA,"^",I)," "
  1. Q
  1. WRTPC ; inputs
  1. ; FBDATA contains node from ^TMP
  1. ; I contains piece to be written
  1. I I=1!($X+$L($P(FBDATA,"^",I))+2>IOM) W !,?4,"PROC: "
  1. W $P(FBDATA,"^",I)," "
  1. Q
  1. WRTSC ;write service connected
  1. W !,"SERVICE CONNECTED? ",$S(+VAEL(3):"YES",1:"NO"),!
  1. Q
  1. TRAV ;write out travel payments, (FBPAT,FBSORT) must be defined
  1. S FBTRDT=0
  1. F S FBTRDT=$O(^TMP($J,"FBTR",FBPAT,FBTRDT)) Q:'FBTRDT S FBTRX=0 F S FBTRX=$O(^TMP($J,"FBTR",FBPAT,FBTRDT,FBTRX)) Q:'FBTRX S FBCKIN=^(FBTRX),A2=$P(FBCKIN,"^") D TRCK Q:FBOUT W:$G(FBTRCK) !,?5,"TRAVEL PAYMENTS: " D K FBTRCK
  1. .W ?22,$$DATX^FBAAUTL(FBTRDT),?35,A2
  1. .S A2=$$EXTRL^FBMRASVR(A2) D EFBCK^FBPAY21(FBCKIN),PMNT^FBAACCB2
  1. .K A2 W ! Q
  1. Q
  1. TRCK I ($Y+5)>IOSL D:FBCRT CR Q:FBOUT D HDR^FBPAY21
  1. Q