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