FBCKDIS.m

FBCKDIS ;AISC/CMR-OUTPUT BY CHECK # ;7/NOV/2006

 ;;3.5;FEE BASIS;**4,61,101**;JAN 30, 1995;Build 2

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ;FBCN=Check Number               FBPROG=Fee payment type

 ;FBPR is set if called from the phone menu.  If this variable exists,

 ;     the user will not be returned to the TOP to select another ck #.

TOP W ! S DIR(0)="FO^1:8",DIR("A")="Select Check Number" D ^DIR K DIR Q:Y=""!(Y="^")  S FBCN=Y

 I '$D(^FBAAC("ACK",FBCN)),('$D(^FBAAC("ACKT",FBCN))),('$D(^FBAAI("ACK",FBCN))),('$D(^FBAA(162.1,"ACK",FBCN))) W !!,*7,"There is no record of that check number." G TOP

 S VAR="FBCN",VAL=FBCN,PGM="START^FBCKDIS" D ZIS^FBAAUTL G END:FBPOP

START S Q="-",$P(Q,"-",80)="-",QQ="=",$P(QQ,"=",80)="=",FBPG=1 K ^TMP($J,"FBCK")

 N FBV,DFN D ^FBCKDIS1

 U IO W:$E(IOST,1,2)["C-" @IOF

 F FBPROG="OPT","CH","CNH","PHAR","TRAV" I $D(^TMP($J,"FBCK",FBPROG)) D PGCHK D  Q:$G(FBAAOUT)

 .S FBV=0 F  S FBV=$O(^TMP($J,"FBCK",FBPROG,FBV)) Q:FBV']""!($G(FBAAOUT))  W:FBPROG'="TRAV" !!,"VENDOR:  ",$$VNAME^FBNHEXP(FBV),?40,"  VENDOR ID:  ",$$VID^FBNHEXP(FBV) D

 ..S DFN=0 F  S DFN=$O(^TMP($J,"FBCK",FBPROG,FBV,DFN)) Q:'DFN!($G(FBAAOUT))  D:$Y+8>IOSL PGCHK Q:$G(FBAAOUT)  W !!,"Patient:  ",$$NAME^FBCHREQ2(DFN),?40,"Patient ID:  ",$$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)) D

 ...N FBAARC,FBADJLA,FBADJLR,FBC,FBFPPSC,FBFPPSL,FBSUSPA,FBX

 ...S FBCNT=0 F  S FBCNT=$O(^TMP($J,"FBCK",FBPROG,FBV,DFN,FBCNT)) Q:'FBCNT!($G(FBAAOUT))  S FBDA=^(FBCNT) D @FBPROG,OUTPUT,CLEAN

END K FBCN,FBCNT,DFN,FBV,FBPROG,FBPG,DIRUT,DTOUT,DUOUT,Q,QQ,^TMP($J,"FBCK")

 D CLOSE^FBAAUTL

 I $G(FBAAOUT) K FBAAOUT Q

 Q:$G(FBPR)]""!($G(ZTQUEUED))

 W !! S DIR(0)="E" D ^DIR K DIR Q:'Y  G TOP

OPT ;gather payment line item for outpatient

 F I=1:1:4 S FB(I)=+$P(FBDA,U,I)

 S FBA=^FBAAC(FB(1),1,FB(2),1,FB(3),1,FB(4),0),FBB=^(2),FBC=$G(^(3))

 S FBDOS=+^FBAAC(FB(1),1,FB(2),1,FB(3),0)

 S FBSRV=$$CPT^FBAAUTL4($P(FBA,U))

 S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_FB(1)_",1,"_FB(2)_",1,"_FB(3)_",1,"_FB(4)_",""M"")","E")

 S FBSRV=FBSRV_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")

 S FBAMCL=$P(FBA,U,2),FBAMPD=$P(FBA,U,3)

 S FBSUSP=$P(FBA,U,5) D SUSP^FBCKDIS1

 S FBSUSPA=$FN($P(FBA,U,4),"",2)

 S FBFPPSC=$P(FBC,U)

 S FBFPPSL=$P(FBC,U,2)

 S FBAARCE=$$GET1^DIQ(162.03,FB(4)_","_FB(3)_","_FB(2)_","_FB(1)_",",48)

 S FBX=$$ADJLRA^FBAAFA(FB(4)_","_FB(3)_","_FB(2)_","_FB(1)_",")

 S FBADJLR=$P(FBX,U)

 S FBADJLA=$P(FBX,U,2)

 S FBVP=$P(FBA,U,21),FBREIM=$P(FBA,U,20),FBBAT=$P(FBA,U,8),FBINV=$P(FBA,U,16)

 D FBCKO^FBAACCB2(FB(1),FB(2),FB(3),FB(4))

 Q

CH ;gather payment line item for ch

CNH ;gather payment line item for cnh

 S FBA=^FBAAI(FBDA,0),FBB=^(2),FBC=$G(^(3)),FBDOS=$P(FBA,U,6)_"-"_$P(FBA,U,7),FBAMCL=$P(FBA,U,8),FBAMPD=$P(FBA,U,9),FBSUSP=$P(FBA,U,11) D SUSP^FBCKDIS1

 S FBVP=$P(FBA,U,14),FBREIM=$P(FBA,U,13),FBBAT=$P(FBA,U,17),FBINV=+FBA

 S FBSUSPA=$FN($P(FBA,U,10),"",2)

 S FBFPPSC=$P(FBC,U)

 S FBFPPSL=$P(FBC,U,2)

 S FBX=$$ADJLRA^FBCHFA(FBDA_",")

 S FBADJLR=$P(FBX,U)

 S FBADJLA=$P(FBX,U,2)

 D FBCKI^FBAACCB1(FBDA)

 Q

PHAR ;gather payment line item for pharmacy

 F I=1,2 S FB(I)=$P(FBDA,U,I)

 S FBA=^FBAA(162.1,FB(1),"RX",FB(2),0),FBB=^(2),FBC=$G(^(3)),FBDOS=$P(FBA,U,3),FBSRV=$P(FBA,"^"),FBAMCL=$P(FBA,U,4),FBAMPD=$P(FBA,U,16),FBSUSP=$P(FBA,U,8) D SUSP^FBCKDIS1

 S FBVP=$P(FBB,U,3),FBREIM=$P(FBA,U,20),FBBAT=$P($G(FBA),U,17),FBINV=+$G(^FBAA(162.1,FB(1),0))

 S FBSUSPA=$FN($P(FBA,U,7),"",2)

 S FBFPPSC=$P($G(^FBAA(162.1,FB(1),0)),U,13)

 S FBFPPSL=$P(FBC,U)

 S FBX=$$ADJLRA^FBRXFA(FB(2)_","_FB(1)_",")

 S FBADJLR=$P(FBX,U)

 S FBADJLA=$P(FBX,U,2)

 D FBCKP^FBAACCB1(FB(1),FB(2))

 Q

TRAV ;gather payment line item for travel

 F I=1,2 S FB(I)=$P(FBDA,U,I)

 S FBA=^FBAAC(FB(1),3,FB(2),0),FBDOS=+FBA,FBAMCL=$P(FBA,U,3),FBAMPD=FBAMCL,FBVP="",FBREIM="R",FBBAT=$P(FBA,U,2),FBINV=""

 D FBCKT^FBAACCB0(FB(1),FB(2))

 Q

CLEAN ;clean up variables

 K I,FB,FBA,FBB,FBDOS,FBSRV,FBMOD,FBAMCL,FBAMPD,FBSUSP,FBVP,FBREIM,FBBAT,FBINV,FBDA,FBMODLE

 Q

OUTPUT ;display line items for check number

 I $Y+5>IOSL D PGCHK Q:$G(FBAAOUT)

 W ! W:FBVP="VP" "#" W:FBREIM="R" "*" W:FBCAN]"" "+" D  Q:$G(FBAAOUT)

 . I FBPROG["C" D  Q

 . . W ?3,$$DATX^FBAAUTL($P(FBDOS,"-")),?15,$$DATX^FBAAUTL($P(FBDOS,"-",2)),?59,+$G(^FBAA(161.7,+FBBAT,0)),?68,FBINV

 . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD,",",2),10)

 . . ; write adjustment reasons, if null then write suspend code

 . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP)

 . . ; write adjustment amounts, if null then write amount suspended

 . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA)

 . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL

 . I FBPROG="OPT" D  Q

 . . W ?3,$$DATX^FBAAUTL(FBDOS),?13,$P(FBSRV,","),?23,FBAARCE

 . . W ?59,+$G(^FBAA(161.7,+FBBAT,0)),?68,FBINV

 . . I $P(FBSRV,",",2)]"" D  Q:$G(FBAAOUT)

 . . . N FBI,FBMOD

 . . . F FBI=2:1 S FBMOD=$P(FBSRV,",",FBI) Q:FBMOD=""  D  Q:$G(FBAAOUT)

 . . . . I $Y+5>IOSL D PGCHK Q:$G(FBAAOUT)  W !,"  (continued)"

 . . . . W !,?18,"-",FBMOD

 . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD,",",2),10)

 . . ; write adjustment reasons, if null then write suspend code

 . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP)

 . . ; write adjustment amounts, if null then write amount suspended

 . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA)

 . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL

 . I FBPROG="PHAR" D  Q

 . . W ?3,$$DATX^FBAAUTL(FBDOS),?13,FBSRV,?59,+$G(^FBAA(161.7,+FBBAT,0)),?68,FBINV

 . . W !?3,$J($FN(FBAMCL,",",2),10),?15,$J($FN(FBAMPD,",",2),10)

 . . ; write adjustment reasons, if null then write suspend code

 . . W ?28,$S(FBADJLR]"":FBADJLR,1:FBSUSP)

 . . ; write adjustment amounts, if null then write amount suspended

 . . W ?38,$S(FBADJLA]"":FBADJLA,1:FBSUSPA)

 . . I FBFPPSC]"" W !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL

 . W ?3,$$DATX^FBAAUTL(FBDOS) W:FBPROG'="TRAV" ?13,FBSRV W ?20,$J($FN(FBAMCL,",",2),10),?32,$J($FN(FBAMPD,",",2),10) W:FBPROG'="TRAV" ?47,FBSUSP W ?53,+$G(^FBAA(161.7,+FBBAT,0)),?65,FBINV

 S A2=FBAMPD D PMNT^FBAACCB2 K A2

 Q

HED W !?20,"PAYMENT HISTORY FOR CHECK # ",FBCN,!,?20,$E(Q,1,(28+$L(FBCN))),?70,"Page: ",FBPG

 W !!,?22,"FEE PROGRAM:  ",$S(FBPROG="OPT":"OUTPATIENT",FBPROG="CH":"CIVIL HOSPITAL",FBPROG="CNH":"COMMUNITY NURSING HOME",FBPROG="PHAR":"PHARMACY",FBPROG="TRAV":"TRAVEL",1:"")

 W !?1,"('*' Reimbursement to Patient  '#' Voided Payment  '+' Cancellation Activity)"

 I FBPROG["C" D  Q

 . W !?3,"From Date",?15,"To Date",?59,"Batch #",?68,"Invoice #"

 . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"

 . W !,QQ

 I FBPROG="TRAV" W !?3,"Travel Dt",?21,"Amount",?33,"Amount",?50,"Batch",?62,"Invoice",!,?21,"Claimed",?34,"Paid",?50,"Number",?62,"Number",!,QQ Q

 I FBPROG="OPT" D  Q

 . W !?3,"Svc Date",?13,"CPT-MOD",?23,"Rev.Code",?59,"Batch #",?68,"Invoice #"

 . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"

 . W !,QQ

 I FBPROG="PHAR" D  Q

 . W !?3,"Fill Dt",?13,"RX #",?56,"Batch #",?68,"Invoice #"

 . W !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"

 . W !,QQ

 Q

PGCHK I FBPG>1,($E(IOST,1,2)["C-") W !! S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q

 W:FBPG>1 @IOF D HED

 S FBPG=FBPG+1 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBCKDIS   7258     printed  Mar 13, 2025@21:02:59                                                                                                                                                                                                     Page 2

FBCKDIS   ;AISC/CMR-OUTPUT BY CHECK # ;7/NOV/2006

 +1       ;;3.5;FEE BASIS;**4,61,101**;JAN 30, 1995;Build 2

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;FBCN=Check Number               FBPROG=Fee payment type

 +4       ;FBPR is set if called from the phone menu.  If this variable exists,

 +5       ;     the user will not be returned to the TOP to select another ck #.

TOP        WRITE !

           SET DIR(0)="FO^1:8"

           SET DIR("A")="Select Check Number"

           DO ^DIR

           KILL DIR

           if Y=""!(Y="^")

               QUIT 

           SET FBCN=Y

 +1        IF '$DATA(^FBAAC("ACK",FBCN))

               IF ('$DATA(^FBAAC("ACKT",FBCN)))

                   IF ('$DATA(^FBAAI("ACK",FBCN)))

                       IF ('$DATA(^FBAA(162.1,"ACK",FBCN)))

                           WRITE !!,*7,"There is no record of that check number."

                           GOTO TOP

 +2        SET VAR="FBCN"

           SET VAL=FBCN

           SET PGM="START^FBCKDIS"

           DO ZIS^FBAAUTL

           if FBPOP

               GOTO END

START      SET Q="-"

           SET $PIECE(Q,"-",80)="-"

           SET QQ="="

           SET $PIECE(QQ,"=",80)="="

           SET FBPG=1

           KILL ^TMP($JOB,"FBCK")

 +1        NEW FBV,DFN

           DO ^FBCKDIS1

 +2        USE IO

           if $EXTRACT(IOST,1,2)["C-"

               WRITE @IOF

 +3        FOR FBPROG="OPT","CH","CNH","PHAR","TRAV"

               IF $DATA(^TMP($JOB,"FBCK",FBPROG))

                   DO PGCHK

                   Begin DoDot:1

 +4                    SET FBV=0

                       FOR 

                           SET FBV=$ORDER(^TMP($JOB,"FBCK",FBPROG,FBV))

                           if FBV']""!($GET(FBAAOUT))

                               QUIT 

                           if FBPROG'="TRAV"

                               WRITE !!,"VENDOR:  ",$$VNAME^FBNHEXP(FBV),?40,"  VENDOR ID:  ",$$VID^FBNHEXP(FBV)

                           Begin DoDot:2

 +5                            SET DFN=0

                               FOR 

                                   SET DFN=$ORDER(^TMP($JOB,"FBCK",FBPROG,FBV,DFN))

                                   if 'DFN!($GET(FBAAOUT))

                                       QUIT 

                                   if $Y+8>IOSL

                                       DO PGCHK

                                   if $GET(FBAAOUT)

                                       QUIT 

                                   WRITE !!,"Patient:  ",$$NAME^FBCHREQ2(DFN),?40,"Patient ID:  ",$$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN))

                                   Begin DoDot:3

 +6                                    NEW FBAARC,FBADJLA,FBADJLR,FBC,FBFPPSC,FBFPPSL,FBSUSPA,FBX

 +7                                    SET FBCNT=0

                                       FOR 

                                           SET FBCNT=$ORDER(^TMP($JOB,"FBCK",FBPROG,FBV,DFN,FBCNT))

                                           if 'FBCNT!($GET(FBAAOUT))

                                               QUIT 

                                           SET FBDA=^(FBCNT)

                                           DO @FBPROG

                                           DO OUTPUT

                                           DO CLEAN

                                   End DoDot:3

                           End DoDot:2

                   End DoDot:1

                   if $GET(FBAAOUT)

                       QUIT 

END        KILL FBCN,FBCNT,DFN,FBV,FBPROG,FBPG,DIRUT,DTOUT,DUOUT,Q,QQ,^TMP($JOB,"FBCK")

 +1        DO CLOSE^FBAAUTL

 +2        IF $GET(FBAAOUT)

               KILL FBAAOUT

               QUIT 

 +3        if $GET(FBPR)]""!($GET(ZTQUEUED))

               QUIT 

 +4        WRITE !!

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           if 'Y

               QUIT 

           GOTO TOP

OPT       ;gather payment line item for outpatient

 +1        FOR I=1:1:4

               SET FB(I)=+$PIECE(FBDA,U,I)

 +2        SET FBA=^FBAAC(FB(1),1,FB(2),1,FB(3),1,FB(4),0)

           SET FBB=^(2)

           SET FBC=$GET(^(3))

 +3        SET FBDOS=+^FBAAC(FB(1),1,FB(2),1,FB(3),0)

 +4        SET FBSRV=$$CPT^FBAAUTL4($PIECE(FBA,U))

 +5        SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_FB(1)_",1,"_FB(2)_",1,"_FB(3)_",1,"_FB(4)_",""M"")","E")

 +6        SET FBSRV=FBSRV_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")

 +7        SET FBAMCL=$PIECE(FBA,U,2)

           SET FBAMPD=$PIECE(FBA,U,3)

 +8        SET FBSUSP=$PIECE(FBA,U,5)

           DO SUSP^FBCKDIS1

 +9        SET FBSUSPA=$FNUMBER($PIECE(FBA,U,4),"",2)

 +10       SET FBFPPSC=$PIECE(FBC,U)

 +11       SET FBFPPSL=$PIECE(FBC,U,2)

 +12       SET FBAARCE=$$GET1^DIQ(162.03,FB(4)_","_FB(3)_","_FB(2)_","_FB(1)_",",48)

 +13       SET FBX=$$ADJLRA^FBAAFA(FB(4)_","_FB(3)_","_FB(2)_","_FB(1)_",")

 +14       SET FBADJLR=$PIECE(FBX,U)

 +15       SET FBADJLA=$PIECE(FBX,U,2)

 +16       SET FBVP=$PIECE(FBA,U,21)

           SET FBREIM=$PIECE(FBA,U,20)

           SET FBBAT=$PIECE(FBA,U,8)

           SET FBINV=$PIECE(FBA,U,16)

 +17       DO FBCKO^FBAACCB2(FB(1),FB(2),FB(3),FB(4))

 +18       QUIT 

CH        ;gather payment line item for ch

CNH       ;gather payment line item for cnh

 +1        SET FBA=^FBAAI(FBDA,0)

           SET FBB=^(2)

           SET FBC=$GET(^(3))

           SET FBDOS=$PIECE(FBA,U,6)_"-"_$PIECE(FBA,U,7)

           SET FBAMCL=$PIECE(FBA,U,8)

           SET FBAMPD=$PIECE(FBA,U,9)

           SET FBSUSP=$PIECE(FBA,U,11)

           DO SUSP^FBCKDIS1

 +2        SET FBVP=$PIECE(FBA,U,14)

           SET FBREIM=$PIECE(FBA,U,13)

           SET FBBAT=$PIECE(FBA,U,17)

           SET FBINV=+FBA

 +3        SET FBSUSPA=$FNUMBER($PIECE(FBA,U,10),"",2)

 +4        SET FBFPPSC=$PIECE(FBC,U)

 +5        SET FBFPPSL=$PIECE(FBC,U,2)

 +6        SET FBX=$$ADJLRA^FBCHFA(FBDA_",")

 +7        SET FBADJLR=$PIECE(FBX,U)

 +8        SET FBADJLA=$PIECE(FBX,U,2)

 +9        DO FBCKI^FBAACCB1(FBDA)

 +10       QUIT 

PHAR      ;gather payment line item for pharmacy

 +1        FOR I=1,2

               SET FB(I)=$PIECE(FBDA,U,I)

 +2        SET FBA=^FBAA(162.1,FB(1),"RX",FB(2),0)

           SET FBB=^(2)

           SET FBC=$GET(^(3))

           SET FBDOS=$PIECE(FBA,U,3)

           SET FBSRV=$PIECE(FBA,"^")

           SET FBAMCL=$PIECE(FBA,U,4)

           SET FBAMPD=$PIECE(FBA,U,16)

           SET FBSUSP=$PIECE(FBA,U,8)

           DO SUSP^FBCKDIS1

 +3        SET FBVP=$PIECE(FBB,U,3)

           SET FBREIM=$PIECE(FBA,U,20)

           SET FBBAT=$PIECE($GET(FBA),U,17)

           SET FBINV=+$GET(^FBAA(162.1,FB(1),0))

 +4        SET FBSUSPA=$FNUMBER($PIECE(FBA,U,7),"",2)

 +5        SET FBFPPSC=$PIECE($GET(^FBAA(162.1,FB(1),0)),U,13)

 +6        SET FBFPPSL=$PIECE(FBC,U)

 +7        SET FBX=$$ADJLRA^FBRXFA(FB(2)_","_FB(1)_",")

 +8        SET FBADJLR=$PIECE(FBX,U)

 +9        SET FBADJLA=$PIECE(FBX,U,2)

 +10       DO FBCKP^FBAACCB1(FB(1),FB(2))

 +11       QUIT 

TRAV      ;gather payment line item for travel

 +1        FOR I=1,2

               SET FB(I)=$PIECE(FBDA,U,I)

 +2        SET FBA=^FBAAC(FB(1),3,FB(2),0)

           SET FBDOS=+FBA

           SET FBAMCL=$PIECE(FBA,U,3)

           SET FBAMPD=FBAMCL

           SET FBVP=""

           SET FBREIM="R"

           SET FBBAT=$PIECE(FBA,U,2)

           SET FBINV=""

 +3        DO FBCKT^FBAACCB0(FB(1),FB(2))

 +4        QUIT 

CLEAN     ;clean up variables

 +1        KILL I,FB,FBA,FBB,FBDOS,FBSRV,FBMOD,FBAMCL,FBAMPD,FBSUSP,FBVP,FBREIM,FBBAT,FBINV,FBDA,FBMODLE

 +2        QUIT 

OUTPUT    ;display line items for check number

 +1        IF $Y+5>IOSL

               DO PGCHK

               if $GET(FBAAOUT)

                   QUIT 

 +2        WRITE !

           if FBVP="VP"

               WRITE "#"

           if FBREIM="R"

               WRITE "*"

           if FBCAN]""

               WRITE "+"

           Begin DoDot:1

 +3            IF FBPROG["C"

                   Begin DoDot:2

 +4                    WRITE ?3,$$DATX^FBAAUTL($PIECE(FBDOS,"-")),?15,$$DATX^FBAAUTL($PIECE(FBDOS,"-",2)),?59,+$GET(^FBAA(161.7,+FBBAT,0)),?68,FBINV

 +5                    WRITE !?3,$JUSTIFY($FNUMBER(FBAMCL,",",2),10),?15,$JUSTIFY($FNUMBER(FBAMPD,",",2),10)

 +6       ; write adjustment reasons, if null then write suspend code

 +7                    WRITE ?28,$SELECT(FBADJLR]"":FBADJLR,1:FBSUSP)

 +8       ; write adjustment amounts, if null then write amount suspended

 +9                    WRITE ?38,$SELECT(FBADJLA]"":FBADJLA,1:FBSUSPA)

 +10                   IF FBFPPSC]""

                           WRITE !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL

                   End DoDot:2

                   QUIT 

 +11           IF FBPROG="OPT"

                   Begin DoDot:2

 +12                   WRITE ?3,$$DATX^FBAAUTL(FBDOS),?13,$PIECE(FBSRV,","),?23,FBAARCE

 +13                   WRITE ?59,+$GET(^FBAA(161.7,+FBBAT,0)),?68,FBINV

 +14                   IF $PIECE(FBSRV,",",2)]""

                           Begin DoDot:3

 +15                           NEW FBI,FBMOD

 +16                           FOR FBI=2:1

                                   SET FBMOD=$PIECE(FBSRV,",",FBI)

                                   if FBMOD=""

                                       QUIT 

                                   Begin DoDot:4

 +17                                   IF $Y+5>IOSL

                                           DO PGCHK

                                           if $GET(FBAAOUT)

                                               QUIT 

                                           WRITE !,"  (continued)"

 +18                                   WRITE !,?18,"-",FBMOD

                                   End DoDot:4

                                   if $GET(FBAAOUT)

                                       QUIT 

                           End DoDot:3

                           if $GET(FBAAOUT)

                               QUIT 

 +19                   WRITE !?3,$JUSTIFY($FNUMBER(FBAMCL,",",2),10),?15,$JUSTIFY($FNUMBER(FBAMPD,",",2),10)

 +20      ; write adjustment reasons, if null then write suspend code

 +21                   WRITE ?28,$SELECT(FBADJLR]"":FBADJLR,1:FBSUSP)

 +22      ; write adjustment amounts, if null then write amount suspended

 +23                   WRITE ?38,$SELECT(FBADJLA]"":FBADJLA,1:FBSUSPA)

 +24                   IF FBFPPSC]""

                           WRITE !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL

                   End DoDot:2

                   QUIT 

 +25           IF FBPROG="PHAR"

                   Begin DoDot:2

 +26                   WRITE ?3,$$DATX^FBAAUTL(FBDOS),?13,FBSRV,?59,+$GET(^FBAA(161.7,+FBBAT,0)),?68,FBINV

 +27                   WRITE !?3,$JUSTIFY($FNUMBER(FBAMCL,",",2),10),?15,$JUSTIFY($FNUMBER(FBAMPD,",",2),10)

 +28      ; write adjustment reasons, if null then write suspend code

 +29                   WRITE ?28,$SELECT(FBADJLR]"":FBADJLR,1:FBSUSP)

 +30      ; write adjustment amounts, if null then write amount suspended

 +31                   WRITE ?38,$SELECT(FBADJLA]"":FBADJLA,1:FBSUSPA)

 +32                   IF FBFPPSC]""

                           WRITE !,?12,"FPPS Claim ID: ",FBFPPSC,?40,"FPPS Line Item: ",FBFPPSL

                   End DoDot:2

                   QUIT 

 +33           WRITE ?3,$$DATX^FBAAUTL(FBDOS)

               if FBPROG'="TRAV"

                   WRITE ?13,FBSRV

               WRITE ?20,$JUSTIFY($FNUMBER(FBAMCL,",",2),10),?32,$JUSTIFY($FNUMBER(FBAMPD,",",2),10)

               if FBPROG'="TRAV"

                   WRITE ?47,FBSUSP

               WRITE ?53,+$GET(^FBAA(161.7,+FBBAT,0)),?65,FBINV

           End DoDot:1

           if $GET(FBAAOUT)

               QUIT 

 +34       SET A2=FBAMPD

           DO PMNT^FBAACCB2

           KILL A2

 +35       QUIT 

HED        WRITE !?20,"PAYMENT HISTORY FOR CHECK # ",FBCN,!,?20,$EXTRACT(Q,1,(28+$LENGTH(FBCN))),?70,"Page: ",FBPG

 +1        WRITE !!,?22,"FEE PROGRAM:  ",$SELECT(FBPROG="OPT":"OUTPATIENT",FBPROG="CH":"CIVIL HOSPITAL",FBPROG="CNH":"COMMUNITY NURSING HOME",FBPROG="PHAR":"PHARMACY",FBPROG="TRAV":"TRAVEL",1:"")

 +2        WRITE !?1,"('*' Reimbursement to Patient  '#' Voided Payment  '+' Cancellation Activity)"

 +3        IF FBPROG["C"

               Begin DoDot:1

 +4                WRITE !?3,"From Date",?15,"To Date",?59,"Batch #",?68,"Invoice #"

 +5                WRITE !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"

 +6                WRITE !,QQ

               End DoDot:1

               QUIT 

 +7        IF FBPROG="TRAV"

               WRITE !?3,"Travel Dt",?21,"Amount",?33,"Amount",?50,"Batch",?62,"Invoice",!,?21,"Claimed",?34,"Paid",?50,"Number",?62,"Number",!,QQ

               QUIT 

 +8        IF FBPROG="OPT"

               Begin DoDot:1

 +9                WRITE !?3,"Svc Date",?13,"CPT-MOD",?23,"Rev.Code",?59,"Batch #",?68,"Invoice #"

 +10               WRITE !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"

 +11               WRITE !,QQ

               End DoDot:1

               QUIT 

 +12       IF FBPROG="PHAR"

               Begin DoDot:1

 +13               WRITE !?3,"Fill Dt",?13,"RX #",?56,"Batch #",?68,"Invoice #"

 +14               WRITE !?3,"Amt Claimed",?17,"Amt Paid",?28,"Adj Code",?38,"Adj Amount"

 +15               WRITE !,QQ

               End DoDot:1

               QUIT 

 +16       QUIT 

PGCHK      IF FBPG>1

               IF ($EXTRACT(IOST,1,2)["C-")

                   WRITE !!

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   IF 'Y

                       SET FBAAOUT=1

                       QUIT 

 +1        if FBPG>1

               WRITE @IOF

           DO HED

 +2        SET FBPG=FBPG+1

           QUIT