- FBPAY21 ;AISC/CMR-OUTPATIENT PAYMENT HISTORY SORT/PRINT ; 9/13/12 10:30am
- ;;3.5;FEE BASIS;**4,32,69,101,143**;JAN 30, 1995;Build 20
- ;;Per VA Directive 6402, this routine should not be modified.
- PRINT ;write output
- S FBOUT=0 D:FBCRT&(FBPG) CR Q:FBOUT
- D HDR I FBSORT S FBPAT=FBPNAME I $D(^TMP($J,"FBTR")) S FBTRCK=1 D TRAV^FBPAY671
- S FBVI="" F S FBVI=$O(^TMP($J,"FB",FBPI,FBVI)) Q:FBVI']""!(FBOUT) D:FBSORT SH Q:FBOUT S FBPT="" D Q:FBOUT
- .F S FBPT=$O(^TMP($J,"FB",FBPI,FBVI,FBPT)) Q:FBPT']""!(FBOUT) D:'FBSORT SH,SH1 Q:FBOUT S FBDT=0 F S FBDT=$O(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT)) Q:'FBDT!(FBOUT) D
- ..S L=0 F S L=$O(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,L)) Q:'L!(FBOUT) S M=0 F S M=$O(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,L,M)) Q:'M!(FBOUT) D
- ...I ($Y+6)>IOSL D PAGE Q:FBOUT
- ...S FBDATA=^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,L,M)
- ...S FBCKIN=$G(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,L,M,"FBCK")) D EFBCK(FBCKIN)
- ...S FBADJ=$G(^TMP($J,"FB",FBPI,FBVI,FBPT,FBDT,L,M,"FBADJ"))
- ...W !,$S($G(FBCAN)]"":"+",1:"")
- ...W !,$S($P(FBDATA,U,12)="VP":"#",1:"")
- ...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 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)
- ...I $P(FBADJ,U,7)]"" W !?5,"FPPS Claim ID: ",$P(FBADJ,U,7)," FPPS Line Item: ",$P(FBADJ,U,8)
- ...S A2=$$EXTRL^FBMRASVR($P(FBDATA,U,4))
- ...W !?4,"Primary Dx: ",$P(FBDATA,U,10),?40,"S/C Condition? ",$P(FBDATA,U,9) W ?63,"Obl.#: ",$P(FBDATA,U,11)
- ...D PMNT^FBAACCB2 K A2
- Q
- HDR ;main header
- I FBPG>0!FBCRT W @IOF
- S FBPG=FBPG+1
- W !?25,$S($G(FBSORT):"VETERAN",1:"VENDOR")," 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,!
- W:FBSORT "Patient: ",FBPNAME,?41,"Patient ID: ",FBPID W:'FBSORT "Vendor: ",FBVNAME,?41,"Vendor ID: ",FBVID
- ;W ?71,"Page: ",FBPG
- 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,"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
- SH ;subheader - vendor if fbsort; patient if 'fbsort, prints when name changed
- I ($Y+8)>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
- SH1 S FBPAT=$P(FBPT,";") I $D(^TMP($J,"FBTR",FBPAT)) S FBTRCK=1 D TRAV^FBPAY671
- Q
- CR ;read for display
- 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
- EFBCK(FBCKIN) ;extract check information from ^TMP
- I $G(FBCKIN)']"" S (FBCK,FBCKDT,FBCANDT,FBCANR,FBCAN,FBDIS,FBCKINT)="" Q
- S U="^",FBCK=$P(FBCKIN,U,2),FBCKDT=$P(FBCKIN,U,3),FBCANDT=$P(FBCKIN,U,4),FBCANR=$P(FBCKIN,U,5),FBCAN=$P(FBCKIN,U,6),FBDIS=$P(FBCKIN,U,7),FBCKINT=$P(FBCKIN,U,8)
- K FBCKIN
- Q
- ;
- EN ;entry from fbpay67 to set '*' if ancillary payment is
- ;a reimbursement. returns FBRP=to '*' or " "
- ;'Y' passed in equal to zero node of 162.03 look at $P(Y,U,20)
- ;
- S FBR=$P($G(Y),U,20),FBR=$S(FBR="R":"*",1:" ")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPAY21 3998 printed Jan 18, 2025@03:00:43 Page 2
- FBPAY21 ;AISC/CMR-OUTPATIENT PAYMENT HISTORY SORT/PRINT ; 9/13/12 10:30am
- +1 ;;3.5;FEE BASIS;**4,32,69,101,143**;JAN 30, 1995;Build 20
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- PRINT ;write output
- +1 SET FBOUT=0
- if FBCRT&(FBPG)
- DO CR
- if FBOUT
- QUIT
- +2 DO HDR
- IF FBSORT
- SET FBPAT=FBPNAME
- IF $DATA(^TMP($JOB,"FBTR"))
- SET FBTRCK=1
- DO TRAV^FBPAY671
- +3 SET FBVI=""
- FOR
- SET FBVI=$ORDER(^TMP($JOB,"FB",FBPI,FBVI))
- if FBVI']""!(FBOUT)
- QUIT
- if FBSORT
- DO SH
- if FBOUT
- QUIT
- SET FBPT=""
- Begin DoDot:1
- +4 FOR
- SET FBPT=$ORDER(^TMP($JOB,"FB",FBPI,FBVI,FBPT))
- if FBPT']""!(FBOUT)
- QUIT
- if 'FBSORT
- DO SH
- DO SH1
- if FBOUT
- QUIT
- SET FBDT=0
- FOR
- SET FBDT=$ORDER(^TMP($JOB,"FB",FBPI,FBVI,FBPT,FBDT))
- if 'FBDT!(FBOUT)
- QUIT
- Begin DoDot:2
- +5 SET L=0
- FOR
- SET L=$ORDER(^TMP($JOB,"FB",FBPI,FBVI,FBPT,FBDT,L))
- if 'L!(FBOUT)
- QUIT
- SET M=0
- FOR
- SET M=$ORDER(^TMP($JOB,"FB",FBPI,FBVI,FBPT,FBDT,L,M))
- if 'M!(FBOUT)
- QUIT
- Begin DoDot:3
- +6 IF ($Y+6)>IOSL
- DO PAGE
- if FBOUT
- QUIT
- +7 SET FBDATA=^TMP($JOB,"FB",FBPI,FBVI,FBPT,FBDT,L,M)
- +8 SET FBCKIN=$GET(^TMP($JOB,"FB",FBPI,FBVI,FBPT,FBDT,L,M,"FBCK"))
- DO EFBCK(FBCKIN)
- +9 SET FBADJ=$GET(^TMP($JOB,"FB",FBPI,FBVI,FBPT,FBDT,L,M,"FBADJ"))
- +10 WRITE !,$SELECT($GET(FBCAN)]"":"+",1:"")
- +11 WRITE !,$SELECT($PIECE(FBDATA,U,12)="VP":"#",1:"")
- +12 WRITE ?1,$PIECE(FBDATA,U,1)
- +13 WRITE ?11,$PIECE($PIECE(FBDATA,U,2),",")
- +14 WRITE ?22,$PIECE(FBADJ,U,9)
- +15 WRITE ?31,$JUSTIFY($PIECE(FBADJ,U,2),10)
- +16 WRITE ?43,$PIECE(FBDATA,U,6)
- +17 WRITE ?54,$PIECE(FBDATA,U,7)
- +18 WRITE ?64,$PIECE(FBDATA,U,8)
- +19 IF $PIECE($PIECE(FBDATA,U,2),",",2)]""
- Begin DoDot:4
- +20 NEW FBI,FBMOD
- +21 FOR FBI=2:1
- SET FBMOD=$PIECE($PIECE(FBDATA,U,2),",",FBI)
- if FBMOD=""
- QUIT
- Begin DoDot:5
- +22 IF $Y+7>IOSL
- DO PAGE
- if FBOUT
- QUIT
- WRITE !," (continued)"
- +23 WRITE !?16,"-",FBMOD
- End DoDot:5
- if FBOUT
- QUIT
- End DoDot:4
- if FBOUT
- QUIT
- +24 WRITE !,$PIECE(FBDATA,U,3)
- +25 WRITE ?13,$PIECE(FBDATA,U,4)
- +26 WRITE ?23,$SELECT($PIECE(FBADJ,U,3)]"":$PIECE(FBADJ,U,3),1:$PIECE(FBDATA,U,5))
- +27 WRITE ?33,$JUSTIFY($SELECT($PIECE(FBADJ,U,4)]"":$JUSTIFY($PIECE(FBADJ,U,4),14),1:$PIECE(FBADJ,U,1)),14)
- +28 WRITE ?48,$PIECE(FBADJ,U,5)
- +29 WRITE ?60,$PIECE(FBADJ,U,6)
- +30 IF $PIECE(FBADJ,U,7)]""
- WRITE !?5,"FPPS Claim ID: ",$PIECE(FBADJ,U,7)," FPPS Line Item: ",$PIECE(FBADJ,U,8)
- +31 SET A2=$$EXTRL^FBMRASVR($PIECE(FBDATA,U,4))
- +32 WRITE !?4,"Primary Dx: ",$PIECE(FBDATA,U,10),?40,"S/C Condition? ",$PIECE(FBDATA,U,9)
- WRITE ?63,"Obl.#: ",$PIECE(FBDATA,U,11)
- +33 DO PMNT^FBAACCB2
- KILL A2
- End DoDot:3
- End DoDot:2
- End DoDot:1
- if FBOUT
- QUIT
- +34 QUIT
- HDR ;main header
- +1 IF FBPG>0!FBCRT
- WRITE @IOF
- +2 SET FBPG=FBPG+1
- +3 WRITE !?25,$SELECT($GET(FBSORT):"VETERAN",1:"VENDOR")," PAYMENT HISTORY"
- +4 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")
- +5 WRITE !?24,$EXTRACT(FBDASH,1,24),?71,"Page: ",FBPG,!
- +6 if FBSORT
- WRITE "Patient: ",FBPNAME,?41,"Patient ID: ",FBPID
- if 'FBSORT
- WRITE "Vendor: ",FBVNAME,?41,"Vendor ID: ",FBVID
- +7 ;W ?71,"Page: ",FBPG
- +8 WRITE !?(IOM-(13+$LENGTH(FBPROG(+FBPI)))/2),"FEE PROGRAM: ",FBPROG(+FBPI)
- +9 WRITE !,?3,"('*' Reimb. to Patient '+' Cancel. Activity '#' Voided Payment)"
- +10 WRITE !,?3,"(paid symbol: 'R' RBRVS 'F' 75th percentile 'C' contract 'M' Mill Bill"
- +11 WRITE !,?3," 'U' U&C)"
- +12 WRITE !,?1,"Svc Date",?11,"CPT-MOD ",?21,"Rev Code",?31,"Units Paid",?43,"Batch No.",?54,"Inv No.",?64,"Voucher Date"
- +13 WRITE !,"Amt Claimed",?13,"Amt Paid",?23,"Adj Code",?36,"Adj Amounts",?48,"Remit Remark",?61,"Patient Account No",!,FBDASH
- +14 QUIT
- SH ;subheader - vendor if fbsort; patient if 'fbsort, prints when name changed
- +1 IF ($Y+8)>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
- SH1 SET FBPAT=$PIECE(FBPT,";")
- IF $DATA(^TMP($JOB,"FBTR",FBPAT))
- SET FBTRCK=1
- DO TRAV^FBPAY671
- +1 QUIT
- CR ;read for display
- +1 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
- EFBCK(FBCKIN) ;extract check information from ^TMP
- +1 IF $GET(FBCKIN)']""
- SET (FBCK,FBCKDT,FBCANDT,FBCANR,FBCAN,FBDIS,FBCKINT)=""
- QUIT
- +2 SET U="^"
- SET FBCK=$PIECE(FBCKIN,U,2)
- SET FBCKDT=$PIECE(FBCKIN,U,3)
- SET FBCANDT=$PIECE(FBCKIN,U,4)
- SET FBCANR=$PIECE(FBCKIN,U,5)
- SET FBCAN=$PIECE(FBCKIN,U,6)
- SET FBDIS=$PIECE(FBCKIN,U,7)
- SET FBCKINT=$PIECE(FBCKIN,U,8)
- +3 KILL FBCKIN
- +4 QUIT
- +5 ;
- EN ;entry from fbpay67 to set '*' if ancillary payment is
- +1 ;a reimbursement. returns FBRP=to '*' or " "
- +2 ;'Y' passed in equal to zero node of 162.03 look at $P(Y,U,20)
- +3 ;
- +4 SET FBR=$PIECE($GET(Y),U,20)
- SET FBR=$SELECT(FBR="R":"*",1:" ")
- +5 QUIT