FBPAY2.m

FBPAY2 ;AISC/DMK,GRR,TET - OUTPATIENT PAYMENT HISTORY SORT/PRINT ;7/9/2001

 ;;3.5;FEE BASIS;**4,32,55,69**;JAN 30, 1995

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

EN ;entry point

 I FBSORT S FBPNAME=FBNAME,FBPID=FBID,(DFN,J)=FBIEN D SORT

 I 'FBSORT S FBVNAME=$E(FBNAME,1,23),FBVID=FBID,FBVI=FBIEN,J=0 F  S J=$O(^FBAAC("AB",FBVI,J)) Q:J'>0  S DFN=J,FBPID=$$SSN^FBAAUTL(DFN),FBPNAME=$P($G(^DPT(DFN,0)),U) D SORT

KILL ;kill variables set in this routine

 K A1,A2,A3,B3,C3,D,D2,FBAACPTC,FBBN,FBCP,FBDOS,FBDT,FBDT1,FBIN,FBOB,FBP,FBPAT,FBPDX,FBSC,FBTA,FBTRDT,FBTRX,FBTYPE,FBVEN,FBVP,I,J,K,L,M,T,Y,FBMODLE,FB1725

 K FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ,FBY3,FBFPPSC,FBFPPSL,FBAARCE

 K:FBSORT FBVNAME,FBVID

 K:'FBSORT FBPNAME,FBPID,FBTRCK

 Q

SORT S I=FBBEG F  S I=$O(^FBAAC(J,"AB",I)) Q:'I!(I>FBEND)  F K=0:0 S K=$O(^FBAAC(J,"AB",I,K)) Q:'K  I FBSORT!(('FBSORT)&(K=$G(FBVI))) F L=0:0 S L=$O(^FBAAC(J,"AB",I,K,L)) Q:'L  D SETTR F M=0:0 S M=$O(^FBAAC(J,1,K,1,L,1,M)) Q:'M  D SET,SETTMP

 Q

SET ;set variables & sort - also entry point from FBPAY67

 N FBX

 S Y=$G(^FBAAC(J,1,K,1,L,1,M,0)) I '+$P(Y,U,9)!($G(^FBAAC(J,1,K,1,L,1,M,"FBREJ"))]"") S FBOUT=1 Q

 ; if user wants just mill bill or just non-mill bill then check payment

 ;   and skip if associated with an mill bill claim

 I "^M^N^"[(U_$G(FB1725R)_U) S FB1725=$S($P(Y,U,13)["FB583":+$P($G(^FB583(+$P(Y,U,13),0)),U,28),1:0) I $S(FB1725R="M"&'FB1725:1,FB1725R="N"&FB1725:1,1:0) S FBOUT=1 Q

 S FBY=$G(^FBAAC(J,1,K,1,L,1,M,2))

 S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3))

 S FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",48) ;revenue code

 D FBCKO^FBAACCB2(J,K,L,M)

 S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")

 S:FBSORT FBVNAME=$E($P($G(^FBAAV(K,0)),U),1,23),FBVID=$S(FBVNAME]"":$P(^(0),U,2),1:"")

 S FBP=+$P(Y,U,9),FBSC=$P(Y,U,27),FBPDX=+$P(Y,U,23)

 S FBSC=$S(FBSC="Y":"YES",FBSC="N":"NO",1:"-")

 S FBPDX=$$ICD9EX^FBCSV1(FBPDX,3,18,+$G(^FBAAC(J,1,K,1,L,0)))

 S T=$P(Y,U,5),D2=$P(Y,U,6),FBDOS=D2,D2=$$DATX^FBAAUTL(D2),FBCP=$P(Y,U,18),FBCP=$S(FBCP=1:"(C&P)",1:"")

 S FBAACPTC=$$CPT^FBAAUTL4($P(Y,U))

 S FBOB=$P(Y,U,10)

 I T]"" S T=$P($G(^FBAA(161.27,+T,0)),U) ;suspend code

 S TAMT=$FN($P(Y,U,4),"",2) ;suspend amount

 S FBUNITS=$P(FBY,U,14) ;units paid

 S FBCSID=$P(FBY,U,16) ;patient control number

 S FBFPPSC=$P(FBY3,U) ; fpps claim id

 S FBFPPSL=$P(FBY3,U,2) ; fpps line item

 S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")

 S FBADJLR=$P(FBX,U) ;adjustment codes

 S FBADJLA=$P(FBX,U,2) ;adjustment amounts

 S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",") ;remit remarks

 S FBTYPE=$P(Y,U,20),FBVP=$P(Y,U,21),FBIN=$P(Y,U,16),FBBN=$P(Y,U,8),FBBN=$S(FBBN']"":"",$D(^FBAA(161.7,FBBN,0)):$P(^(0),U),1:""),FBBN=$S(FBBN="":"",1:$E("00000",$L(FBBN)+1,5)_FBBN)

 S FBVEN=FBVNAME_";"_FBVID,FBPAT=FBPNAME_";"_DFN

 ;output format

 S A1=$J($P(Y,U,2),6,2),A2=$J($P(Y,U,3),6,2),FBIN=$J(FBIN,7)

 S A2=A2_$$APS^FBAAUTL4(J,K,L,M) ; append symbol

 S FBDT1=$S(FBVP="VP":"#",1:"")_$S(FBTYPE="R":"*",1:" ")_FBDT

 Q

SETTMP ;sort data by fee program, vendor, patient, date

 I '$D(FBPROG(+$P(Y,U,9)))!($P(Y,U,9)'=FBPI)!($G(^FBAAC(J,1,K,1,L,1,M,"FBREJ"))]"") S FBOUT=1 G SETTMP1

 ; if user wants just mill bill or just non-mill bill then check payment

 ;   and skip if associated with an mill bill claim

 I "^M^N^"[(U_$G(FB1725R)_U) S FB1725=$S($P(Y,U,13)["FB583":+$P($G(^FB583(+$P(Y,U,13),0)),U,28),1:0) I $S(FB1725R="M"&'FB1725:1,FB1725R="N"&FB1725:1,1:0) S FBOUT=1 G SETTMP1

 S ^TMP($J,"FB",FBP,FBVEN,FBPAT,I,L,M)=FBDT1_U_FBAACPTC_FBCP_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_T_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB

 S ^TMP($J,"FB",FBP,FBVEN,FBPAT,I,L,M,"FBCK")="^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT

 S ^TMP($J,"FB",FBP,FBVEN,FBPAT,I,L,M,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID_U_FBFPPSC_U_FBFPPSL_U_FBAARCE

SETTMP1 D PMTCLN^FBAACCB2

 Q

SETTR S D=$S($D(^FBAAC(J,1,K,1,L,0)):$P(^(0),"^",1),1:""),A3=""

 ; if just mill bill (FB1725R="M") requested then skip travel payments

 I D]"",$D(^FBAAC(J,3,"AB",D)),$G(FB1725R)'="M" S (FBTA,FBCTR)=0 F  S FBTA=$O(^FBAAC(J,3,"AB",D,FBTA)) Q:'FBTA  S A3=$P($G(^FBAAC(J,3,FBTA,0)),"^",3) I A3>0 D

 .D FBCKT^FBAACCB0(J,FBTA) S FBCTR=FBCTR+1,^TMP($J,"FBTR",FBPNAME,D,FBCTR)=$J(A3,6,2)_"^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT

 K A3,B3,FBTA,FBCTR

 S FBDT=$$DATX^FBAAUTL(D)

 Q

EN1 ;entry point to set variables, called by fbpay67, oth & anc

 N FBVEN,FBPAT,FBDT1

 D SETTR,SET

 Q

WMSG ;write message if no matches found

 W !!,"There are no outpatient payments on file for specified date range"

 W:'FBPROG !?3," and selected Fee programs"

 W ".",*7,!!

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBPAY2   4751     printed  Feb 18, 2025@23:25:55                                                                                                                                                                                                      Page 2

FBPAY2    ;AISC/DMK,GRR,TET - OUTPATIENT PAYMENT HISTORY SORT/PRINT ;7/9/2001

 +1       ;;3.5;FEE BASIS;**4,32,55,69**;JAN 30, 1995

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

EN        ;entry point

 +1        IF FBSORT

               SET FBPNAME=FBNAME

               SET FBPID=FBID

               SET (DFN,J)=FBIEN

               DO SORT

 +2        IF 'FBSORT

               SET FBVNAME=$EXTRACT(FBNAME,1,23)

               SET FBVID=FBID

               SET FBVI=FBIEN

               SET J=0

               FOR 

                   SET J=$ORDER(^FBAAC("AB",FBVI,J))

                   if J'>0

                       QUIT 

                   SET DFN=J

                   SET FBPID=$$SSN^FBAAUTL(DFN)

                   SET FBPNAME=$PIECE($GET(^DPT(DFN,0)),U)

                   DO SORT

KILL      ;kill variables set in this routine

 +1        KILL A1,A2,A3,B3,C3,D,D2,FBAACPTC,FBBN,FBCP,FBDOS,FBDT,FBDT1,FBIN,FBOB,FBP,FBPAT,FBPDX,FBSC,FBTA,FBTRDT,FBTRX,FBTYPE,FBVEN,FBVP,I,J,K,L,M,T,Y,FBMODLE,FB1725

 +2        KILL FBCSID,FBADJLA,FBADJLR,FBRRMKL,FBUNITS,TAMT,T,FBADJ,FBY3,FBFPPSC,FBFPPSL,FBAARCE

 +3        if FBSORT

               KILL FBVNAME,FBVID

 +4        if 'FBSORT

               KILL FBPNAME,FBPID,FBTRCK

 +5        QUIT 

SORT       SET I=FBBEG

           FOR 

               SET I=$ORDER(^FBAAC(J,"AB",I))

               if 'I!(I>FBEND)

                   QUIT 

               FOR K=0:0

                   SET K=$ORDER(^FBAAC(J,"AB",I,K))

                   if 'K

                       QUIT 

                   IF FBSORT!(('FBSORT)&(K=$GET(FBVI)))

                       FOR L=0:0

                           SET L=$ORDER(^FBAAC(J,"AB",I,K,L))

                           if 'L

                               QUIT 

                           DO SETTR

                           FOR M=0:0

                               SET M=$ORDER(^FBAAC(J,1,K,1,L,1,M))

                               if 'M

                                   QUIT 

                               DO SET

                               DO SETTMP

 +1        QUIT 

SET       ;set variables & sort - also entry point from FBPAY67

 +1        NEW FBX

 +2        SET Y=$GET(^FBAAC(J,1,K,1,L,1,M,0))

           IF '+$PIECE(Y,U,9)!($GET(^FBAAC(J,1,K,1,L,1,M,"FBREJ"))]"")

               SET FBOUT=1

               QUIT 

 +3       ; if user wants just mill bill or just non-mill bill then check payment

 +4       ;   and skip if associated with an mill bill claim

 +5        IF "^M^N^"[(U_$GET(FB1725R)_U)

               SET FB1725=$SELECT($PIECE(Y,U,13)["FB583":+$PIECE($GET(^FB583(+$PIECE(Y,U,13),0)),U,28),1:0)

               IF $SELECT(FB1725R="M"&'FB1725:1,FB1725R="N"&FB1725:1,1:0)

                   SET FBOUT=1

                   QUIT 

 +6        SET FBY=$GET(^FBAAC(J,1,K,1,L,1,M,2))

 +7        SET FBY3=$GET(^FBAAC(J,1,K,1,L,1,M,3))

 +8       ;revenue code

           SET FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",48)

 +9        DO FBCKO^FBAACCB2(J,K,L,M)

 +10       SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")

 +11       if FBSORT

               SET FBVNAME=$EXTRACT($PIECE($GET(^FBAAV(K,0)),U),1,23)

               SET FBVID=$SELECT(FBVNAME]"":$PIECE(^(0),U,2),1:"")

 +12       SET FBP=+$PIECE(Y,U,9)

           SET FBSC=$PIECE(Y,U,27)

           SET FBPDX=+$PIECE(Y,U,23)

 +13       SET FBSC=$SELECT(FBSC="Y":"YES",FBSC="N":"NO",1:"-")

 +14       SET FBPDX=$$ICD9EX^FBCSV1(FBPDX,3,18,+$GET(^FBAAC(J,1,K,1,L,0)))

 +15       SET T=$PIECE(Y,U,5)

           SET D2=$PIECE(Y,U,6)

           SET FBDOS=D2

           SET D2=$$DATX^FBAAUTL(D2)

           SET FBCP=$PIECE(Y,U,18)

           SET FBCP=$SELECT(FBCP=1:"(C&P)",1:"")

 +16       SET FBAACPTC=$$CPT^FBAAUTL4($PIECE(Y,U))

 +17       SET FBOB=$PIECE(Y,U,10)

 +18      ;suspend code

           IF T]""

               SET T=$PIECE($GET(^FBAA(161.27,+T,0)),U)

 +19      ;suspend amount

           SET TAMT=$FNUMBER($PIECE(Y,U,4),"",2)

 +20      ;units paid

           SET FBUNITS=$PIECE(FBY,U,14)

 +21      ;patient control number

           SET FBCSID=$PIECE(FBY,U,16)

 +22      ; fpps claim id

           SET FBFPPSC=$PIECE(FBY3,U)

 +23      ; fpps line item

           SET FBFPPSL=$PIECE(FBY3,U,2)

 +24       SET FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")

 +25      ;adjustment codes

           SET FBADJLR=$PIECE(FBX,U)

 +26      ;adjustment amounts

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

 +27      ;remit remarks

           SET FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",")

 +28       SET FBTYPE=$PIECE(Y,U,20)

           SET FBVP=$PIECE(Y,U,21)

           SET FBIN=$PIECE(Y,U,16)

           SET FBBN=$PIECE(Y,U,8)

           SET FBBN=$SELECT(FBBN']"":"",$DATA(^FBAA(161.7,FBBN,0)):$PIECE(^(0),U),1:"")

           SET FBBN=$SELECT(FBBN="":"",1:$EXTRACT("00000",$LENGTH(FBBN)+1,5)_FBBN)

 +29       SET FBVEN=FBVNAME_";"_FBVID

           SET FBPAT=FBPNAME_";"_DFN

 +30      ;output format

 +31       SET A1=$JUSTIFY($PIECE(Y,U,2),6,2)

           SET A2=$JUSTIFY($PIECE(Y,U,3),6,2)

           SET FBIN=$JUSTIFY(FBIN,7)

 +32      ; append symbol

           SET A2=A2_$$APS^FBAAUTL4(J,K,L,M)

 +33       SET FBDT1=$SELECT(FBVP="VP":"#",1:"")_$SELECT(FBTYPE="R":"*",1:" ")_FBDT

 +34       QUIT 

SETTMP    ;sort data by fee program, vendor, patient, date

 +1        IF '$DATA(FBPROG(+$PIECE(Y,U,9)))!($PIECE(Y,U,9)'=FBPI)!($GET(^FBAAC(J,1,K,1,L,1,M,"FBREJ"))]"")

               SET FBOUT=1

               GOTO SETTMP1

 +2       ; if user wants just mill bill or just non-mill bill then check payment

 +3       ;   and skip if associated with an mill bill claim

 +4        IF "^M^N^"[(U_$GET(FB1725R)_U)

               SET FB1725=$SELECT($PIECE(Y,U,13)["FB583":+$PIECE($GET(^FB583(+$PIECE(Y,U,13),0)),U,28),1:0)

               IF $SELECT(FB1725R="M"&'FB1725:1,FB1725R="N"&FB1725:1,1:0)

                   SET FBOUT=1

                   GOTO SETTMP1

 +5        SET ^TMP($JOB,"FB",FBP,FBVEN,FBPAT,I,L,M)=FBDT1_U_FBAACPTC_FBCP_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_T_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB

 +6        SET ^TMP($JOB,"FB",FBP,FBVEN,FBPAT,I,L,M,"FBCK")="^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT

 +7        SET ^TMP($JOB,"FB",FBP,FBVEN,FBPAT,I,L,M,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID_U_FBFPPSC_U_FBFPPSL_U_FBAARCE

SETTMP1    DO PMTCLN^FBAACCB2

 +1        QUIT 

SETTR      SET D=$SELECT($DATA(^FBAAC(J,1,K,1,L,0)):$PIECE(^(0),"^",1),1:"")

           SET A3=""

 +1       ; if just mill bill (FB1725R="M") requested then skip travel payments

 +2        IF D]""

               IF $DATA(^FBAAC(J,3,"AB",D))

                   IF $GET(FB1725R)'="M"

                       SET (FBTA,FBCTR)=0

                       FOR 

                           SET FBTA=$ORDER(^FBAAC(J,3,"AB",D,FBTA))

                           if 'FBTA

                               QUIT 

                           SET A3=$PIECE($GET(^FBAAC(J,3,FBTA,0)),"^",3)

                           IF A3>0

                               Begin DoDot:1

 +3                                DO FBCKT^FBAACCB0(J,FBTA)

                                   SET FBCTR=FBCTR+1

                                   SET ^TMP($JOB,"FBTR",FBPNAME,D,FBCTR)=$JUSTIFY(A3,6,2)_"^"_FBCK_"^"_FBCKDT_"^"_FBCANDT_"^"_FBCANR_"^"_FBCAN_"^"_FBDIS_"^"_FBCKINT

                               End DoDot:1

 +4        KILL A3,B3,FBTA,FBCTR

 +5        SET FBDT=$$DATX^FBAAUTL(D)

 +6        QUIT 

EN1       ;entry point to set variables, called by fbpay67, oth & anc

 +1        NEW FBVEN,FBPAT,FBDT1

 +2        DO SETTR

           DO SET

 +3        QUIT 

WMSG      ;write message if no matches found

 +1        WRITE !!,"There are no outpatient payments on file for specified date range"

 +2        if 'FBPROG

               WRITE !?3," and selected Fee programs"

 +3        WRITE ".",*7,!!

 +4        QUIT