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

FBNHEP2.m

Go to the documentation of this file.
  1. FBNHEP2 ;AISC/GRR - ENTER NURSING HOME PAYMENT ;7/1/2009
  1. ;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. NOBAT W !!,*7,"You do not have an open CNH Batch. You must have an open",!,"CNH type Batch before you can enter a payment!",!
  1. D Q
  1. Q
  1. ;
  1. GETBAT ;
  1. S FBAAMPI=$P($G(^FBAA(161.4,1,"FBNUM")),"^",5) ; max lines CNH batch
  1. I FBAAMPI'>0 S FBAAMPI=61
  1. S FBOUT=0,DIC="^FBAA(161.7,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,3)=""B9""&($P(^(0),U,5)=DUZ)&($P(^(0),U,15)="""")&($G(^(""ST""))=""O"")" W ! D ^DIC K DIC
  1. I X=""!(X="^") S FBOUT=1 Q
  1. G GETBAT:Y<0
  1. I $$B9INVC(+Y)>(FBAAMPI-1) D G GETBAT
  1. . W !!,"This Batch already has the maximum number of Payments!"
  1. S FBBAT=+Y,FBCNH=1
  1. Q
  1. Q K FBYY,FBMM,FBDAYS,FBPAYDT,FBENDDT,Z,Y,DIC,FBRIFN,CNT,%DT,FBAABDT,FBAAEDT,FBAAPTC,FBDEFP,FBER,FBERR,FBHZ,FBINA,FBIRAT,FBPIFN,FBPREV,FBPROG,FBPRTR,FBSRAT,FBTRDYS,FBTYPE,FBVCAR,I,IFN,VAL,X,DA,DIE,DR,FBAAID,FBAAIN,FBNL,FBI7078,FBBAT,FBOUT
  1. K DAT,F,FBAUT,FBDX,FBEDT,FBI,FBMULT,FBRR,FBTDT,FBXX,FTP,PI,PTYPE,T,ZZ,FB7078,FBAAOUT,FBASSOC,FBLOC,FBPOV,FBPSA,FBPT,FBTT,FBVEN,TA,FBCNH
  1. D GETAUTHK^FBAAUTL1
  1. Q
  1. ;
  1. CKRAT ;check rates and fill gaps if needed
  1. K FB S FBERR=0 N I,J,FBVIEN,FBCHFDT,FBCHTDT,FBCIEN,FBCNUM,FBDDT,FBEXDT,FBEXNDT,FBFND,FBRFDT,FBRTDT,FBRT,FBUNR S I=0
  1. F S I=$O(^FBAA(161.23,"AC",FB7078,I)) Q:'I I $D(^FBAA(161.23,I,0)) S J=^(0) D
  1. .S FBRT($P(J,U))=$P(J,U,5)_"^"_$P(J,U,2)
  1. S FBRFDT=0,FBCHFDT=$S(FBAABDT<FBPAYDT:$E(FBPAYDT,1,5)_"01",1:FBAABDT),(FBCHTDT,FBDDT)=FBENDDT,I=DFN,FBVIEN=IFN
  1. D GETRAT^FBNHRAT,CKFRDT^FBNHRAT
  1. I $D(FBUNR) S FBERR=1 D ERR K FB Q
  1. D GETRAT
  1. Q
  1. GETRAT N I,J,FBCK S I=0
  1. F S I=$O(^FBAA(161.23,"AC",FB7078,I)) Q:'I I $D(^FBAA(161.23,I,0)) S J=^(0) D
  1. .S FB($P(J,U,2))=$P(J,U,5)_"^"_$P(J,U)
  1. I $O(FB(FBPAYDT+.9))="" S FBERR=1 D ERR Q
  1. Q
  1. ;
  1. CALC ;get dollar amount to pay when no movements in month.
  1. ;FBPAYS=# of days in month
  1. ;FBTRDYS=# of treatment days
  1. ;FBPAYDT=month of payment
  1. ;FBENDDT=last day of payment month or last day of authorization
  1. S FBDEFP=0 N FBCT S FBCT=0
  1. I $G(FBDAYS) S FBTRDYS=$S(FBTRDYS>FBDAYS:FBDAYS,1:FBTRDYS)
  1. S X=$S(FBAABDT>(FBPAYDT):FBAABDT-1,1:FBPAYDT)
  1. S Y=$O(FB(X)) I FBENDDT'>Y S FBDEFP=FBTRDYS*+FB(Y) Q
  1. RATE S X1=$O(FB(X)),FBCT=FBCT+1 I 'X1 S FBERR=1 Q
  1. S FBX1=($S(X1>(FBENDDT-$G(FBENDFLG)):(FBENDDT-$G(FBENDFLG)),1:X1)-X) S:FBCT'>0 FBX1=FBX1+1 S FBDEFP=FBDEFP+(FBX1*$P(FB(X1),U)) S X=X1
  1. I FBENDDT>X G RATE
  1. Q
  1. ;
  1. ERR W !,"Insufficient Authorization Rate data on file for patient: ",$$NAME^FBCHREQ2(DFN) ;,!,"Use the Edit Authorization option prior to entering payment.",!!
  1. W !,"Take the appropriate action prior to entering a payment:"
  1. W !?3,"Use the Edit Authorization option to modify the authorization period or",!?3,"assure a contract with valid rates exists for the payment period before",!?8,"continuing with this payment entry.",!!
  1. Q
  1. ;calculate dollars when at least one movement in month.
  1. CALC1 S (I,J,Z,FBDEFP)=0
  1. F S J=$O(FBZZ(J)) Q:'J D
  1. .S I=$O(FBZZ(0)) Q:'I D
  1. ..F Q:'$D(FBZZ(I)) S X=$P(FBZZ(I),"^"),Y=$O(FB(X-.1)),X1=$O(FB(X-.1)) Q:'Y D
  1. ...I $P(FBZZ(I),"^",2)>Y S Z=1 D DEFP S Z=0 S $P(FBZZ(I),"^")=Y+1 Q
  1. ...S Y=$P(FBZZ(I),"^",2) D DEFP K FBZZ(I)
  1. K I,J,X,Y,X1 Q
  1. ;
  1. DEFP S FBDEFP=FBDEFP+(($S(FBAABDT=FBAAEDT:1,1:Y-X)+$P(FBZZ(I),"^",3)+Z)*+FB(X1))
  1. Q
  1. ;
  1. DAYS S (I,FBTRDYS)=0 K FBPREV,FBHI
  1. S FBBEG=FBPAYDT+1
  1. F S I=$O(FBZ(I)) Q:'I D
  1. .I '$D(FBPREV),$P(FBZ(I),U,2) S FBBEG=$S($P(FBZ(I),U)>FBPAYDT:$P(FBZ(I),U),1:FBPAYDT),FBPREV=1
  1. .I '$P(FBZ(I),U,2),$S('$D(FBHI):1,1:$P(FBZ(+FBHI),U,2)) S FBEND=$P(FBZ(I),U),FBTRDYS=FBTRDYS+($S(FBEND-FBBEG:FBEND-FBBEG,((FBAABDT<FBAAEDT)&(+$E(FBAAEDT,6,7)=1)):0,1:1))+$P(FBZ(I),U,2) S FBZZ(I)=FBBEG_"^"_FBEND
  1. .I $D(FBHI),$P(FBZ(I),U,2) S FBBEG=$P(FBZ(I),U)
  1. .S FBHI=I
  1. I FBENDDT>$P(FBZ(FBHI),U),$P(FBZ(FBHI),U,2) S FBTRDYS=FBTRDYS+($S(FBENDDT-FBBEG:FBENDDT-FBBEG,1:1))+1,$P(FBZZ(FBHI),U,3)=1 I '+FBZZ(FBHI) S $P(FBZZ(FBHI),"^",1,2)=FBBEG_"^"_FBENDDT
  1. I FBENDDT=$P(FBZ(FBHI),U),$P(FBZ(FBHI),U,2) S FBTRDYS=FBTRDYS+1 I '+$G(FBZZ(FBHI)) S $P(FBZZ(FBHI),"^",1,2)=FBBEG_"^"_FBENDDT
  1. Q
  1. CHECK N FBCK,FBCK1
  1. S FBCK=$S(FBABD<FBPAYDT:($E(FBPAYDT,1,5)_"01"),1:FBABD),FBCK1=$O(FB(FBCK-.1)) I $P(FB(FBCK1),"^",2)>FBCK S FBERR=1 D ERR Q
  1. Q
  1. B9INVC(FBBAT) ; B9 Batch Invoice Count
  1. ; Input
  1. ; FBBAT = IEN of B9 type batch in file 161.7
  1. ; Returns count of invoices in batch
  1. N FBCNT,FBDA
  1. S FBCNT=0
  1. I $G(FBBAT) D
  1. . S FBDA=0
  1. . F S FBDA=$O(^FBAAI("AC",FBBAT,FBDA)) Q:'FBDA S:$D(^FBAAI(FBDA,0)) FBCNT=FBCNT+1
  1. Q FBCNT