source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBPCR67.m@ 808

FBPCR67 ;AISC/DMK,TET-CH/CNH POTENTIAL COST RECOVERY SORT ;07/01/2006
 ;;3.5;FEE BASIS;**4,48,55,69,98**;JAN 30, 1995;Build 54
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;entry point for sort
 S (FBCATC,FBINS,FBPSF)=0
SORT ;sort by date finalized, ien
 N FBY2,FBCDAYS,FBCSID,FBX,FBADJLR,FBADJLA,FBRRMKL
 S FBM=FBBDATE-.1 F  S FBM=$O(^FBAAI("AD",FBM)) Q:'FBM!(FBM>FBEDATE)  S FBI=0 F  S FBI=$O(^FBAAI("AD",FBM,FBI)) Q:FBI'>0  S FBIN=$G(^FBAAI(FBI,0)) I FBIN]""&($G(^FBAAI(FBI,"FBREJ"))']"") D  S (FBCATC,FBINS,FBPSF)=0
 .S (DFN,J)=+$P(FBIN,U,4) D VET^FBPCR
 .D SET Q:FBPI'[+$P(FBIN,U,12)!('FBPSV&('$D(FBPSV(FBPSF))))  I FBCATC!FBINS D SETTMP
KILL ;kill variables set in this routine and in FPAY2, sort/set sections
 K A1,A2,A3,D,D2,DFN,FBAACPTC,FBBN,FBCATC,FBCNT,FBCP,FBDOB,FBDT,FBDT1,FBDX,FBDX1,FBI,FBIN,FBINS,FBIX,FBJ,FBM,FBOB,FBPAT,FBPDX,FBPROC,FBPROC1,FBPSF,FBSC,FBTA,FBVEN,FBVENID,FBVP,I,J,K,L,M,Y
 K FBVNAME,FBVID,FBPNAME,FBPID
 K FBY2,FBCDAYS,FBCSID,FBX,FBADJLR,FBADJLA,FBRRMKL
 D KILL^FBPCR2
 Q
SET ;set variables
 ;I $G(FBPROG)]"",'FBPROG,'$D(FBPROG(+$P(FBIN,U,12))) Q
 S FBY2=$G(^FBAAI(FBI,2))
 F FBJ=1,2,3,4,6,7,8,9,11,13,14 S FBIN(FBJ)=$P(FBIN,"^",FBJ)
 Q:FBPI'[+$P(FBIN,U,12)  S FBPSF=+$P(FBIN,U,20)
 Q:'FBPSV&('$D(FBPSV(FBPSF)))
 D
 . N FBCATC2
 . S FBCATC=$$CATC^FBPCR(DFN,+$P(FBIN,U,6),+$P(FBIN,U,18))
 . Q:FBCATC=2
 . S FBCATC2=$$CATC^FBPCR(DFN,+$P(FBIN,U,7),+$P(FBIN,U,18))
 . I FBCATC2=0 Q
 . I FBCATC=0!(FBCATC=1) S FBCATC=FBCATC2 Q
 . S:FBCATC2=2 FBCATC=2
 ;,FBINS=$S($O(^FBAAA("AIC",FBIN(4),+$O(^FBAAA("AIC",FBIN(4),-FBIN(6))),0))="Y":1,1:0)
 S FBINS=$S($$INSCK^FBPCR3(FBIN(6),FBIN(4),+$P(FBIN,U,12))=1:$$INSURED^FBPCR4(DFN,+$P(FBIN,U,6),+$P(FBIN,U,7)),1:0)
 Q:'FBCATC&'FBINS
 S FBIN(5)=$P(FBIN,U,5)
 S FBIEN=FBIN(3),FBVNAME=$G(^FBAAV(FBIN(3),0)) Q:FBVNAME']""  S FBVID=$P(FBVNAME,U,2)_"/"_$S($P($G(^FBAAV(FBIEN,3)),U,2)]"":$P($G(^FBAAV(FBIEN,3)),U,2),1:"**********"),FBVNAME=$E($P(FBVNAME,U),1,23)
 S FBIN(2)=$$DATX^FBAAUTL(FBIN(2)),FBVEN=FBVNAME_";"_FBVID,FBPAT=FBPNAME_";"_DFN
 S FBIN(6)=$$DATX^FBAAUTL(FBIN(6)),FBIN(7)=$$DATX^FBAAUTL(FBIN(7))
 Q
SETTMP ;sort data by primary service facility, patient, fee program, vendor, date
 Q:$$FILTER^FBPCR4()=0
 S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI)=FBIN(2)_U_$J(FBIN(8),8,2)_U_$J(FBIN(9),8,2)_U_FBIN(11)_U_$J(FBIN(1),8)_U_FBIN(6)_U_FBIN(7)_U_$P(FBIN,U,12)_U_FBCATC_U_FBINS_U_FBIN(13)_U_FBIN(14)
 S FBCDAYS=$P(FBY2,U,10) ; covered days
 S FBCSID=$P(FBY2,U,11) ; patient control number
 S FBX=$$ADJLRA^FBCHFA(FBI_",")
 S FBADJLR=$P(FBX,U) ;adjustment reason
 S FBADJLA=$P(FBX,U,2) ;adjustment amount
 S FBRRMKL=$$RRL^FBCHFR(FBI_",") ;remittance remarks
 S ^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"FBINV")=FBCDAYS_"^"_FBCSID_"^"_FBADJLR_"^"_FBADJLA_"^"_FBRRMKL
 S FBDX=$G(^FBAAI(FBI,"DX")) I FBDX]"" S FBDX1="" F I=1:1:5 S:$P(FBDX,U,I) FBDX1=FBDX1_$$ICD9^FBCSV1($P(FBDX,U,I),+$P($G(FBIN),U,6))_U
 I FBDX]"" S FBDX1=$P(FBDX1,U,1,($L(FBDX1,U)-1)),^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"DX")=FBDX1
 S FBPROC=$G(^FBAAI(FBI,"PROC")) I FBPROC]"" S FBPROC1="" F I=1:1:5 S:$P(FBPROC,U,I) FBPROC1=FBPROC1_$$ICD0^FBCSV1($P(FBPROC,U,I),+$P($G(FBIN),U,6))_U
 I FBPROC]"" S FBPROC1=$P(FBPROC1,U,1,($L(FBPROC1,U)-1)),^TMP($J,"FB",FBPSF,FBPAT,+$P(FBIN,U,12),FBVEN,FBM,FBI,"PROC")=FBPROC1
 ;*** removed conditional to get ancillary payments processed
 ;D ANC:$D(^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI))
 D ANC
 Q
ANC ;ancillary payments
 N J,K,L,M,Y,FBDT1,FBVID I FBPI=67 N FBPI S FBPI=+$P(FBIN,U,12)
 S J=DFN,FBCNT=0 I J,+FBIN(5),$D(^FBAAC("AM",FBIN(5),J)) D
 .F K=0:0 S K=$O(^FBAAC("AM",FBIN(5),J,K)) Q:'K  S L=0 F  S L=$O(^FBAAC("AM",FBIN(5),J,K,L)) Q:'L  D
 ..S FBDT1=$P($G(^FBAAC(J,1,K,1,L,0)),U) I FBDT1]"" S FBDT1=$$DATX^FBAAUTL(FBDT1)
 ..S M=0 F  S M=$O(^FBAAC("AM",FBIN(5),J,K,L,M)) Q:'M  S Y=$G(^FBAAC(J,1,K,1,L,1,M,0)) I Y]"" D
 ...D EN1^FBPCR2 Q:'$D(FBAACPTC)  S FBCNT=FBCNT+1
 ...Q:$$FILTER^FBPCR4()=0
 ...S ^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI,"A",FBCNT)=FBDT1_U_FBAACPTC_FBCP_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")_U_A1_U_A2_U_FBBN_U_FBIN_U_D2_U_FBSC_U_FBPDX_U_FBOB_U_FBVNAME_U_FBVID_U_FBPI_U_FBCATC_U_FBINS
 ...S ^TMP($J,"FB",FBPSF,FBPAT,FBPI,FBVEN,FBM,FBI,"A",FBCNT,"FBADJ")=TAMT_U_FBUNITS_U_FBADJLR_U_FBADJLA_U_FBRRMKL_U_FBCSID
 Q