Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBAAPIN

FBAAPIN.m

Go to the documentation of this file.
  1. FBAAPIN ;AISC/GRR - INVOICE DISPLAY ;7/17/2003
  1. ;;3.5;FEE BASIS;**4,61,122,133,108,135,123,164**;JAN 30, 1995;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. D DT^DICRW
  1. RD1 W ! S (FBHDONE,FBAAOUT,FBINTOT)=0,FBSW=0 K FBHED S DIR(0)="NO",DIR("A")="Select Invoice Number",DIR("?")="^D HELP^FBAAPIN1" D ^DIR K DIR G Q:$D(DIRUT)!'Y
  1. I '$D(^FBAAC("C",X)) W !,*7,"Invalid selection.",! G RD1
  1. S HX=X,FBAAIN=X D LIST S X=HX G RD1
  1. LIST S Q="",$P(Q,"=",80)="="
  1. S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
  1. F J=0:0 S J=$O(^FBAAC("C",FBAAIN,J)) Q:J'>0!(FBAAOUT) D MMORE
  1. Q
  1. SET S FBFILE="^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",1,",D=$P($G(^FBAAC(J,1,K,1,L,0)),"^",1),FBYY=$G(^FBAAC(J,1,K,1,L,1,M,0)),FBYY("REJ")=$S($D(^FBAAC(J,1,K,1,L,1,M,"FBREJ")):^("FBREJ"),1:""),FBY=$G(^FBAAC(J,1,K,1,L,1,M,2))
  1. S FBY3=$G(^FBAAC(J,1,K,1,L,1,M,3))
  1. S FBAARCE=$$GET1^DIQ(162.03,M_","_L_","_K_","_J_",",48)
  1. D SET2
  1. Q
  1. SET2 ;
  1. N FBX,FBIA,FBDODINV
  1. S N=$S($D(^DPT(J,0)):$P(^(0),"^",1),1:""),S=$S(N]"":$P(^DPT(J,0),"^",9),1:""),V=$S($D(^FBAAV(K,0)):$P(^FBAAV(K,0),"^",1),1:"")
  1. S T=$P(FBYY,"^",5),D2=$P(FBYY,"^",6),ZS=$P(FBYY,"^",20),VP=$P(FBYY,"^",21)
  1. S T=$P($G(^FBAA(161.27,+T,0)),U)
  1. S TAMT=$FN($P(FBYY,U,4),"",2)
  1. S FBAACPT=$P(FBYY,"^",1) I FBAACPT]"" S FBAACPT=$$CPT^FBAAUTL4(FBAACPT)
  1. S FBMODLE=$$MODL^FBAAUTL4("^FBAAC("_J_",1,"_K_",1,"_L_",1,"_M_",""M"")","E")
  1. S FBUNITS=$P(FBY,U,14)
  1. S FBFPPSL=$P(FBY3,U,2)
  1. S FBX=$$ADJLRA^FBAAFA(M_","_L_","_K_","_J_",")
  1. S FBADJLR=$P(FBX,U)
  1. S FBADJLA=$P(FBX,U,2)
  1. S FBRRMKL=$$RRL^FBAAFR(M_","_L_","_K_","_J_",")
  1. S FBCNTRN=$S($P(FBY3,U,8):$P($G(^FBAA(161.43,$P(FBY3,U,8),0)),U),1:"")
  1. S FBIA=+$P($G(^FBAAC(J,1,K,1,L,1,M,3)),U,6) ; IPAC agreement pointer (*123)
  1. S FBIA=$S(FBIA:$P($G(^FBAA(161.95,FBIA,0)),U,1),1:"") ; IPAC vendor agreement ID (*123)
  1. S FBDODINV=$P($G(^FBAAC(J,1,K,1,L,1,M,3)),U,7) ; DoD invoice number (*123)
  1. S A1=$P(FBYY,"^",2)+.0001,A2=$P(FBYY,"^",3)+.0001,A3=$P(FBYY,"^",12)+.0001,A1=$P(A1,".",1)_"."_$E($P(A1,".",2),1,2),A2=$P(A2,".",1)_"."_$E($P(A2,".",2),1,2),A3=$P(A3,".",1)_"."_$E($P(A3,".",2),1,2),FBINTOT=FBINTOT+A2+.0001
  1. S FBINTOT=$P(FBINTOT,".")_"."_$E($P(FBINTOT,".",2),1,2)
  1. S FBBN=$S($P(FBYY,"^",8)]"":$S($D(^FBAA(161.7,$P(FBYY,"^",8),0)):$P(^(0),"^",1),1:""),$P(FBYY("REJ"),"^",3)]"":$S($D(^FBAA(161.7,$P(FBYY("REJ"),"^",3),0)):$P(^(0),"^",1),1:""),1:"")
  1. D FBCKO^FBAACCB2(J,K,L,M)
  1. I $D(^FBAAC(J,1,K,1,L,1,M,4))!($D(^FBAAC(J,1,K,1,L,1,M,5))) D PROV
  1. I '$D(FBHED) D HED
  1. D WRT S FBHED=1
  1. Q
  1. WRT I ($Y+5)>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q:FBAAOUT D HED
  1. W !!,N,?33,$$DATX^FBAAUTL(D),?43,FBAACPT_$S($G(FBMODLE)]"":"-"_$P(FBMODLE,","),1:"")
  1. I FBAARCE]"" W ?51,"/",FBAARCE
  1. W ?57,FBBN,?67,$S(FBYY("REJ")]"":"Rejected",1:$$DATX^FBAAUTL(D2))
  1. I $P($G(FBMODLE),",",2)]"" D Q:FBAAOUT
  1. . N FBI
  1. . F FBI=2:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D Q:FBAAOUT
  1. . . I $Y+5>IOSL D Q:FBAAOUT W !,"(continued)"
  1. . . . S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q:FBAAOUT D HED
  1. . . W !,?48,"-",FBMOD
  1. W !,$S(ZS="R":"*",1:""),$S(VP="VP":"#",1:""),$S($G(FBCAN)]"":"+",1:"")
  1. W ?3,FBFPPSL,?14,"$",$J(A1,8),?26,"$",$J(A2,8),?37,FBUNITS
  1. ; write adjustment reasons, if null then write suspend code
  1. W ?43,$S(FBADJLR]"":FBADJLR,1:T)
  1. ; write adjustment amounts, if null then write amount suspended
  1. W ?53,"$",$S(FBADJLA]"":FBADJLA,1:TAMT)
  1. W ?69,FBRRMKL
  1. ; if adjustment reasons null and suspend code = other then write desc.
  1. I FBADJLR="",T=4 D ^FBAAPIN1
  1. I FBCNTRN]"" W !!,?2,"Contract Number: ",FBCNTRN
  1. I FBIA'=""!(FBDODINV'="") W !!?5,"IPAC Number: ",FBIA,?30,"DoD Invoice Number: ",FBDODINV
  1. ;
  1. ; write attachment IDs FB*3.5*164
  1. I $D(^FBAAC(J,1,K,1,L,1,M,10)) D
  1. . N AI,AID,AITI,WRTPC
  1. . S AI=0 S WRTPC="Attachment ID:"
  1. . F S AI=$O(^FBAAC(J,1,K,1,L,1,M,10,AI)) Q:'AI D
  1. . . S AID=$P($G(^FBAAC(J,1,K,1,L,1,M,10,AI,0)),U)
  1. . . I AI>1 S WRTPC=WRTPC_","
  1. . . S WRTPC=WRTPC_" "_AID
  1. . . S AITI=$P($G(^FBAAC(J,1,K,1,L,1,M,10,AI,0)),U,2)
  1. . . I AITI D
  1. . . . S WRTPC=WRTPC_" ("_$P($G(^IBE(353.3,AITI,0)),U)
  1. . . . S WRTPC=WRTPC_" - "
  1. . . . S WRTPC=WRTPC_$P($G(^IBE(353.3,AITI,0)),U,2)_")"
  1. . . I $L(WRTPC)>IOM D WRTSTR^FBAACCB1(.WRTPC,IOM)
  1. . I $L(WRTPC)>0 D WRTSTR^FBAACCB1(.WRTPC,IOM)
  1. ;
  1. D PMNT^FBAACCB2
  1. ; Display LI Rendering Provider data
  1. N FBLIPRV S FBLIPRV=$G(^FBAAC(J,1,K,1,L,1,M,3)) ; FB*3.5*135
  1. I $L($P(FBLIPRV,U,3)) D
  1. . W !?3,"RENDERING PROV NAME (LI): "_$P(FBLIPRV,U,3)
  1. . I $L($P(FBLIPRV,U,4,5))>1 W !?7,"NPI: "_$P(FBLIPRV,U,4),?29,"TAXONOMY CODE: "_$P(FBLIPRV,U,5)
  1. Q
  1. HED W @IOF,!,"Invoice Number: ",FBAAIN,?30,"Vendor Name: ",V,!,?2,"Date Received: ",FBINDAT
  1. I +$G(FBY) W ?33,"Invoice Date: ",$$DATX^FBAAUTL(+FBY)
  1. W !?2,"FPPS Claim ID: ",$S(FBFPPSC]"":FBFPPSC,1:"N/A")
  1. W ?33,"Patient Account #: ",FBCSID
  1. W !?10,"('*' Reimb. to Patient '+' Cancel. Activity '#' Voided Payment)"
  1. ;W !,"SVC DATE"," CPT-MOD "," AMT CLAIMED",?35,"AMT PAID",?47,"CODE",?57,"BATCH NO.",?67,"VOUCHER DATE",!,?5,"Other Suspension Description",!,$$REPEAT^XLFSTR("=",79),!
  1. W !,"PATIENT",?33,"SVC DATE",?43,"CPT-MOD",?51,"/REV",?57,"BATCH NO.",?67,"VOUCHER DATE"
  1. W !,?3,"FPPS LINE",?14,"AMT CLAIMED",?26,"AMT PAID",?36,"UNITS",?43,"ADJ CODE",?53,"ADJ AMT",?69,"REMIT RMK"
  1. W !,$$REPEAT^XLFSTR("=",79)
  1. Q
  1. Q K D,N,V,D2,J,K,L,M,DIC,T,FBYY,Q,I,A1,A2,A3,C,DIYS,FBAACPT,FBAAIN,FBAAOUT,FBBN,FBINTOT,FBINDAT,FBSW,FBHDONE,HX,S,VP,Z,ZS,FBHED,FBFILE,DIRUT,FBY,FBMOD
  1. K FBMODLE
  1. K FBAARCE,FBADJLA,FBADJLR,FBCSID,FBFPPSC,FBFPPSL,FBRRMKL,FBUNITS,TAMT
  1. Q
  1. ERR W !,*7,"Please enter a whole number! Alpha characters and puctuation are invalid" G RD1
  1. SETHD S V=$S($D(^FBAAV(K,0)):$P(^(0),"^",1),1:"") D INDAT:FBSW S FBHDONE=1 Q
  1. MMORE S FBSW=1 F K=0:0 S K=$O(^FBAAC("C",FBAAIN,J,K)) Q:K=""!(FBAAOUT) D SETHD F L=0:0 S L=$O(^FBAAC("C",FBAAIN,J,K,L)) Q:L=""!(FBAAOUT) F M=0:0 S M=$O(^FBAAC("C",FBAAIN,J,K,L,M)) Q:M'>0 D SET Q:FBAAOUT
  1. Q
  1. INDAT S L=$O(^FBAAC("C",FBAAIN,J,K,"")),M=$O(^FBAAC("C",FBAAIN,J,K,L,""))
  1. S FBINDAT=$P($G(^FBAAC(J,1,K,1,L,1,M,0)),"^",15)
  1. S FBINDAT=$S(FBINDAT="":"Unknown",1:$E(FBINDAT,4,5)_"/"_$E(FBINDAT,6,7)_"/"_$E(FBINDAT,2,3))
  1. S FBFPPSC=$P($G(^FBAAC(J,1,K,1,L,1,M,3)),U,1)
  1. S FBCSID=$P($G(^FBAAC(J,1,K,1,L,1,M,2)),U,16)
  1. S FBSW=0 K L,M Q
  1. Q
  1. PROV ;Display Invoice Provider information before invoice details FB*3.5*122
  1. N FBPRI,FBSRVF S FBPRI=$G(^FBAAC(J,1,K,1,L,1,M,4)),FBSRVF=$G(^FBAAC(J,1,K,1,L,1,M,5)),$P(FBSRVF,U,3)=$$GET1^DIQ(5,$P(FBSRVF,U,3)_",",1)
  1. W @IOF,!?30,"INVOICE DISPLAY",!?30,"===============",!?28,"PROVIDER INFORMATION",!
  1. I $L($P(FBPRI,U,1,3))>3 W !?3,"ATTENDING PROV NAME: "_$P(FBPRI,U),!?3,"ATTENDING PROV NPI: "_$P(FBPRI,U,2),?35,"ATTENDING PROV TAXONOMY CODE: "_$P(FBPRI,U,3)
  1. I $L($P(FBPRI,U,4,5))>2 W !!?3,"OPERATING PROV NAME: "_$P(FBPRI,U,4),!?3,"OPERATING PROV NPI: "_$P(FBPRI,U,5)
  1. I $L($P(FBPRI,U,6,8))>3 W !!?3,"RENDERING PROV NAME: "_$P(FBPRI,U,6),!?3,"RENDERING PROV NPI: "_$P(FBPRI,U,7),?35,"RENDERING PROV TAXONOMY CODE: "_$P(FBPRI,U,8)
  1. I $L($P(FBPRI,U,9,10))>2 W !!?3,"SERVICING PROV NAME: "_$P(FBPRI,U,9),!?3,"SERVICING PROV NPI: "_$P(FBPRI,U,10)
  1. I $L($P(FBSRVF,U,1,4))>4 W !?3,"SERVICING FACILITY ADDRESS: ",!?5,$P(FBSRVF,U),!?5,$P(FBSRVF,U,2) I $P(FBSRVF,U,2)'="" W ", "
  1. W $P(FBSRVF,U,3)_" "_$P(FBSRVF,U,4)
  1. I $L($P(FBPRI,U,11,12))>2 W !!?3,"REFERRING PROV NAME: "_$P(FBPRI,U,11),!?3,"REFERRING PROV NPI: "_$P(FBPRI,U,12),!!
  1. I '$D(FBHED) S DIR(0)="E" D ^DIR
  1. Q