FBAAVLU ;AISC/DMK-LOOK UP VENDOR FOR TIME FRAME ;8/10/2003
;;3.5;FEE BASIS;**4,61**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
D DT^DICRW
RDV S FBAAOUT=0 K FBAANQ W !! S DIC="^FBAAV(",DIC(0)="AEQM",DIC("A")="Select Medical Vendor: ",DIC("S")="I $P(^(0),""^"",7)'=3" D ^DIC K DIC("S"),DIC("A") G Q:X="^"!(X=""),RDV:Y<0 S DA=+Y
D DATE^FBAAUTL G:FBPOP RDV S ZZ=9999999.9999,BEG=ZZ-ENDDATE,END=ZZ-BEGDATE
S VAR="DA^BEG^END",VAL=DA_"^"_BEG_"^"_END,PGM="START^FBAAVLU" D ZIS^FBAAUTL G:FBPOP Q S:IO=IO(0) FBAANQ=1
START S Q="",$P(Q,"-",80)="-",HNAM="",FBDEL=$S($P($G(^FBAAV(DA,"ADEL")),"^")="Y":1,1:0) U IO W:$E(IOST,1,2)["C-" @IOF D HED
F J=0:0 S J=$O(^FBAAC("AB",DA,J)) Q:J'>0!(FBAAOUT) F FBK=BEG-1:0 S FBK=$O(^FBAAC(J,DA,"AD",FBK)) Q:FBK>END!(FBK'>0)!(FBAAOUT) S K=DA D MORE
G:$D(FBAANQ) RDV
Q D CLOSE^FBAAUTL K DA,%DT,M,HNAM,J,BEG,BEGDATE,V,DIC,END,ENDDATE,A1,A2,B,B1,B2,PI,T,FBAACPT,FBAADT,FBAAPD,FBIN,FBAANQ,FBAAOUT,K,L,PTNAM,ZS,PGM,Q,VAL,VAR,X,Y,ZZ,FBDEL,FBMOD,FBMODLE Q
MORE F L=0:0 S L=$O(^FBAAC(J,DA,"AD",FBK,L)) Q:L'>0!(FBAAOUT) F M=0:0 S M=$O(^FBAAC(J,1,DA,1,L,1,M)) Q:M'>0!(FBAAOUT) S B=^(M,0) I $P(B,"^",6)]"" S T=$P(B,"^",5),FBAAPD=$P(B,"^",14),ZS=$P(B,"^",20),V=$P(B,"^",21) D
.D FBCKO^FBAACCB2(J,K,L,M),WRT
Q
WRT ;
N FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRRMKL,FBUNITS
N FBX,FBY2,FBY3,TAMT
I $E(IOST,1,2)["C-",$Y+4>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q:FBAAOUT W @IOF D HED
E I $Y+4>IOSL W @IOF D HED
S FBAADT=$P(^FBAAC(J,1,DA,1,L,0),"^",1),FBAADT=$E(FBAADT,4,5)_"/"_$E(FBAADT,6,7)_"/"_$E(FBAADT,2,3),B1=$P(B,"^",8),B2=$S(B1="":"",$D(^FBAA(161.7,B1,0)):$P(^FBAA(161.7,B1,0),"^",1),1:""),PTNAM=$S($D(^DPT(J,0)):$P(^DPT(J,0),"^"),1:"")
S FBAAPD=$S(FBAAPD]"":$E(FBAAPD,4,5)_"/"_$E(FBAAPD,6,7)_"/"_$E(FBAAPD,2,3),1:"NOT PAID")
S A1=$P(B,"^",2)+.0001,A2=$P(B,"^",3)+.0001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2),FBIN=$P(B,"^",16)
S FBAACPT=$$CPT^FBAAUTL4($P(B,"^",1))
S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3))
S FBFPPSC=$P(FBY3,U)
S FBFPPSL=$P(FBY3,U,2)
S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
S FBADJLR=$P(FBX,U)
S FBADJLA=$P(FBX,U,2)
S TAMT=$FN($P(B,"^",4),"",2)
S FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",48)
S FBY2=$G(^FBAAC(J,1,K,1,L,1,M,2))
S FBUNITS=$P(FBY2,U,14)
S FBCSID=$P(FBY2,U,16)
S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",")
W:PTNAM'=HNAM !,PTNAM
W !,$S(ZS="R":"*",1:""),$S(V="VP":"#",1:""),$S($G(FBCAN)]"":"+",1:""),?2,FBAADT,?12,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:""),?22,FBAARCE,?31,FBUNITS,?38,FBCSID,?60,FBIN,?71,B2
I $P($G(FBMODLE),",",2)]"" D Q:FBAAOUT
. N FBI
. F FBI=2:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D Q:FBAAOUT
. . I $Y+4>IOSL D Q:FBAAOUT
. . . I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
. . . W @IOF D HED W !,"(continued)"
. . W !,?17,"-",FBMOD
W !?4,"$",$J(A1,8),?17,"$",$J(A2,8)
; write adjustment reasons, if null then write suspend code
W ?30,$S(FBADJLR]"":FBADJLR,1:T)
; write adjustment amounts, if null then write amount suspended
W ?40,"$",$S(FBADJLA]"":FBADJLA,1:TAMT)
W ?56,FBRRMKL,?70,FBAAPD
I FBFPPSC]"" W !,?5,"FPPS Claim ID: ",FBFPPSC,?32,"FPPS Line Item: ",FBFPPSL
D PMNT^FBAACCB2
S HNAM=PTNAM
Q
HED S FBAAOUT=0 W ?26,"** VENDOR LOOK-UP **",!,!,?23,"Vendor: ",$P(^FBAAV(DA,0),"^",1),!,?14,"('*' Reimb. to Patient '+' Cancel. Activity)",!,"PATIENT",?14,"('#' Voided Payment)"
W !?2,"SVC DATE",?12,"CPT-MOD",?22,"REV.CODE",?31,"UNITS",?38,"PATIENT ACCOUNT NO.",?60,"INVOICE #",?71,"BATCH #"
W !?4,"AMT CLAIMED",?17,"AMT PAID",?30,"ADJ CODE",?40,"ADJ AMOUNT",?56,"REMIT REMARK",?70,"DATE PAID"
W !,Q,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAVLU 3807 printed Dec 13, 2024@01:57:07 Page 2
FBAAVLU ;AISC/DMK-LOOK UP VENDOR FOR TIME FRAME ;8/10/2003
+1 ;;3.5;FEE BASIS;**4,61**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO DT^DICRW
RDV SET FBAAOUT=0
KILL FBAANQ
WRITE !!
SET DIC="^FBAAV("
SET DIC(0)="AEQM"
SET DIC("A")="Select Medical Vendor: "
SET DIC("S")="I $P(^(0),""^"",7)'=3"
DO ^DIC
KILL DIC("S"),DIC("A")
if X="^"!(X="")
GOTO Q
if Y<0
GOTO RDV
SET DA=+Y
+1 DO DATE^FBAAUTL
if FBPOP
GOTO RDV
SET ZZ=9999999.9999
SET BEG=ZZ-ENDDATE
SET END=ZZ-BEGDATE
+2 SET VAR="DA^BEG^END"
SET VAL=DA_"^"_BEG_"^"_END
SET PGM="START^FBAAVLU"
DO ZIS^FBAAUTL
if FBPOP
GOTO Q
if IO=IO(0)
SET FBAANQ=1
START SET Q=""
SET $PIECE(Q,"-",80)="-"
SET HNAM=""
SET FBDEL=$SELECT($PIECE($GET(^FBAAV(DA,"ADEL")),"^")="Y":1,1:0)
USE IO
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
DO HED
+1 FOR J=0:0
SET J=$ORDER(^FBAAC("AB",DA,J))
if J'>0!(FBAAOUT)
QUIT
FOR FBK=BEG-1:0
SET FBK=$ORDER(^FBAAC(J,DA,"AD",FBK))
if FBK>END!(FBK'>0)!(FBAAOUT)
QUIT
SET K=DA
DO MORE
+2 if $DATA(FBAANQ)
GOTO RDV
Q DO CLOSE^FBAAUTL
KILL DA,%DT,M,HNAM,J,BEG,BEGDATE,V,DIC,END,ENDDATE,A1,A2,B,B1,B2,PI,T,FBAACPT,FBAADT,FBAAPD,FBIN,FBAANQ,FBAAOUT,K,L,PTNAM,ZS,PGM,Q,VAL,VAR,X,Y,ZZ,FBDEL,FBMOD,FBMODLE
QUIT
MORE FOR L=0:0
SET L=$ORDER(^FBAAC(J,DA,"AD",FBK,L))
if L'>0!(FBAAOUT)
QUIT
FOR M=0:0
SET M=$ORDER(^FBAAC(J,1,DA,1,L,1,M))
if M'>0!(FBAAOUT)
QUIT
SET B=^(M,0)
IF $PIECE(B,"^",6)]""
SET T=$PIECE(B,"^",5)
SET FBAAPD=$PIECE(B,"^",14)
SET ZS=$PIECE(B,"^",20)
SET V=$PIECE(B,"^",21)
Begin DoDot:1
+1 DO FBCKO^FBAACCB2(J,K,L,M)
DO WRT
End DoDot:1
+2 QUIT
WRT ;
+1 NEW FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRRMKL,FBUNITS
+2 NEW FBX,FBY2,FBY3,TAMT
+3 IF $EXTRACT(IOST,1,2)["C-"
IF $Y+4>IOSL
SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET FBAAOUT=1
if FBAAOUT
QUIT
WRITE @IOF
DO HED
+4 IF '$TEST
IF $Y+4>IOSL
WRITE @IOF
DO HED
+5 SET FBAADT=$PIECE(^FBAAC(J,1,DA,1,L,0),"^",1)
SET FBAADT=$EXTRACT(FBAADT,4,5)_"/"_$EXTRACT(FBAADT,6,7)_"/"_$EXTRACT(FBAADT,2,3)
SET B1=$PIECE(B,"^",8)
SET B2=$SELECT(B1="":"",$DATA(^FBAA(161.7,B1,0)):$PIECE(^FBAA(161.7,B1,0),"^",1),1:"")
SET PTNAM=$SELECT($DATA(^DPT(J,0)):$PIECE(^DPT(J,0),"^"),1:"")
+6 SET FBAAPD=$SELECT(FBAAPD]"":$EXTRACT(FBAAPD,4,5)_"/"_$EXTRACT(FBAAPD,6,7)_"/"_$EXTRACT(FBAAPD,2,3),1:"NOT PAID")
+7 SET A1=$PIECE(B,"^",2)+.0001
SET A2=$PIECE(B,"^",3)+.0001
SET A1=$PIECE(A1,".",1)_"."_$EXTRACT($PIECE(A1,".",2),1,2)
SET A2=$PIECE(A2,".",1)_"."_$EXTRACT($PIECE(A2,".",2),1,2)
SET FBIN=$PIECE(B,"^",16)
+8 SET FBAACPT=$$CPT^FBAAUTL4($PIECE(B,"^",1))
+9 SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
+10 SET FBY3=$GET(^FBAAC(J,1,K,1,L,1,M,3))
+11 SET FBFPPSC=$PIECE(FBY3,U)
+12 SET FBFPPSL=$PIECE(FBY3,U,2)
+13 SET FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
+14 SET FBADJLR=$PIECE(FBX,U)
+15 SET FBADJLA=$PIECE(FBX,U,2)
+16 SET TAMT=$FNUMBER($PIECE(B,"^",4),"",2)
+17 SET FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",48)
+18 SET FBY2=$GET(^FBAAC(J,1,K,1,L,1,M,2))
+19 SET FBUNITS=$PIECE(FBY2,U,14)
+20 SET FBCSID=$PIECE(FBY2,U,16)
+21 SET FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",")
+22 if PTNAM'=HNAM
WRITE !,PTNAM
+23 WRITE !,$SELECT(ZS="R":"*",1:""),$SELECT(V="VP":"#",1:""),$SELECT($GET(FBCAN)]"":"+",1:""),?2,FBAADT,?12,FBAACPT_$SELECT($GET(FBMODLE)]"":"-"_$PIECE(FBMODLE,","),1:""),?22,FBAARCE,?31,FBUNITS,?38,FBCSID,?60,FBIN,?71,B2
+24 IF $PIECE($GET(FBMODLE),",",2)]""
Begin DoDot:1
+25 NEW FBI
+26 FOR FBI=2:1
SET FBMOD=$PIECE(FBMODLE,",",FBI)
if FBMOD=""
QUIT
Begin DoDot:2
+27 IF $Y+4>IOSL
Begin DoDot:3
+28 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBAAOUT=1
QUIT
+29 WRITE @IOF
DO HED
WRITE !,"(continued)"
End DoDot:3
if FBAAOUT
QUIT
+30 WRITE !,?17,"-",FBMOD
End DoDot:2
if FBAAOUT
QUIT
End DoDot:1
if FBAAOUT
QUIT
+31 WRITE !?4,"$",$JUSTIFY(A1,8),?17,"$",$JUSTIFY(A2,8)
+32 ; write adjustment reasons, if null then write suspend code
+33 WRITE ?30,$SELECT(FBADJLR]"":FBADJLR,1:T)
+34 ; write adjustment amounts, if null then write amount suspended
+35 WRITE ?40,"$",$SELECT(FBADJLA]"":FBADJLA,1:TAMT)
+36 WRITE ?56,FBRRMKL,?70,FBAAPD
+37 IF FBFPPSC]""
WRITE !,?5,"FPPS Claim ID: ",FBFPPSC,?32,"FPPS Line Item: ",FBFPPSL
+38 DO PMNT^FBAACCB2
+39 SET HNAM=PTNAM
+40 QUIT
HED SET FBAAOUT=0
WRITE ?26,"** VENDOR LOOK-UP **",!,!,?23,"Vendor: ",$PIECE(^FBAAV(DA,0),"^",1),!,?14,"('*' Reimb. to Patient '+' Cancel. Activity)",!,"PATIENT",?14,"('#' Voided Payment)"
+1 WRITE !?2,"SVC DATE",?12,"CPT-MOD",?22,"REV.CODE",?31,"UNITS",?38,"PATIENT ACCOUNT NO.",?60,"INVOICE #",?71,"BATCH #"
+2 WRITE !?4,"AMT CLAIMED",?17,"AMT PAID",?30,"ADJ CODE",?40,"ADJ AMOUNT",?56,"REMIT REMARK",?70,"DATE PAID"
+3 WRITE !,Q,!
+4 QUIT
