- FBNHEP2 ;AISC/GRR - ENTER NURSING HOME PAYMENT ;7/1/2009
- ;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- 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!",!
- D Q
- Q
- ;
- GETBAT ;
- S FBAAMPI=$P($G(^FBAA(161.4,1,"FBNUM")),"^",5) ; max lines CNH batch
- I FBAAMPI'>0 S FBAAMPI=61
- 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
- I X=""!(X="^") S FBOUT=1 Q
- G GETBAT:Y<0
- I $$B9INVC(+Y)>(FBAAMPI-1) D G GETBAT
- . W !!,"This Batch already has the maximum number of Payments!"
- S FBBAT=+Y,FBCNH=1
- Q
- 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
- 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
- D GETAUTHK^FBAAUTL1
- Q
- ;
- CKRAT ;check rates and fill gaps if needed
- K FB S FBERR=0 N I,J,FBVIEN,FBCHFDT,FBCHTDT,FBCIEN,FBCNUM,FBDDT,FBEXDT,FBEXNDT,FBFND,FBRFDT,FBRTDT,FBRT,FBUNR S I=0
- F S I=$O(^FBAA(161.23,"AC",FB7078,I)) Q:'I I $D(^FBAA(161.23,I,0)) S J=^(0) D
- .S FBRT($P(J,U))=$P(J,U,5)_"^"_$P(J,U,2)
- S FBRFDT=0,FBCHFDT=$S(FBAABDT<FBPAYDT:$E(FBPAYDT,1,5)_"01",1:FBAABDT),(FBCHTDT,FBDDT)=FBENDDT,I=DFN,FBVIEN=IFN
- D GETRAT^FBNHRAT,CKFRDT^FBNHRAT
- I $D(FBUNR) S FBERR=1 D ERR K FB Q
- D GETRAT
- Q
- GETRAT N I,J,FBCK S I=0
- F S I=$O(^FBAA(161.23,"AC",FB7078,I)) Q:'I I $D(^FBAA(161.23,I,0)) S J=^(0) D
- .S FB($P(J,U,2))=$P(J,U,5)_"^"_$P(J,U)
- I $O(FB(FBPAYDT+.9))="" S FBERR=1 D ERR Q
- Q
- ;
- CALC ;get dollar amount to pay when no movements in month.
- ;FBPAYS=# of days in month
- ;FBTRDYS=# of treatment days
- ;FBPAYDT=month of payment
- ;FBENDDT=last day of payment month or last day of authorization
- S FBDEFP=0 N FBCT S FBCT=0
- I $G(FBDAYS) S FBTRDYS=$S(FBTRDYS>FBDAYS:FBDAYS,1:FBTRDYS)
- S X=$S(FBAABDT>(FBPAYDT):FBAABDT-1,1:FBPAYDT)
- S Y=$O(FB(X)) I FBENDDT'>Y S FBDEFP=FBTRDYS*+FB(Y) Q
- RATE S X1=$O(FB(X)),FBCT=FBCT+1 I 'X1 S FBERR=1 Q
- 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
- I FBENDDT>X G RATE
- Q
- ;
- ERR W !,"Insufficient Authorization Rate data on file for patient: ",$$NAME^FBCHREQ2(DFN) ;,!,"Use the Edit Authorization option prior to entering payment.",!!
- W !,"Take the appropriate action prior to entering a payment:"
- 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.",!!
- Q
- ;calculate dollars when at least one movement in month.
- CALC1 S (I,J,Z,FBDEFP)=0
- F S J=$O(FBZZ(J)) Q:'J D
- .S I=$O(FBZZ(0)) Q:'I D
- ..F Q:'$D(FBZZ(I)) S X=$P(FBZZ(I),"^"),Y=$O(FB(X-.1)),X1=$O(FB(X-.1)) Q:'Y D
- ...I $P(FBZZ(I),"^",2)>Y S Z=1 D DEFP S Z=0 S $P(FBZZ(I),"^")=Y+1 Q
- ...S Y=$P(FBZZ(I),"^",2) D DEFP K FBZZ(I)
- K I,J,X,Y,X1 Q
- ;
- DEFP S FBDEFP=FBDEFP+(($S(FBAABDT=FBAAEDT:1,1:Y-X)+$P(FBZZ(I),"^",3)+Z)*+FB(X1))
- Q
- ;
- DAYS S (I,FBTRDYS)=0 K FBPREV,FBHI
- S FBBEG=FBPAYDT+1
- F S I=$O(FBZ(I)) Q:'I D
- .I '$D(FBPREV),$P(FBZ(I),U,2) S FBBEG=$S($P(FBZ(I),U)>FBPAYDT:$P(FBZ(I),U),1:FBPAYDT),FBPREV=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
- .I $D(FBHI),$P(FBZ(I),U,2) S FBBEG=$P(FBZ(I),U)
- .S FBHI=I
- 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
- 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
- Q
- CHECK N FBCK,FBCK1
- 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
- Q
- B9INVC(FBBAT) ; B9 Batch Invoice Count
- ; Input
- ; FBBAT = IEN of B9 type batch in file 161.7
- ; Returns count of invoices in batch
- N FBCNT,FBDA
- S FBCNT=0
- I $G(FBBAT) D
- . S FBDA=0
- . F S FBDA=$O(^FBAAI("AC",FBBAT,FBDA)) Q:'FBDA S:$D(^FBAAI(FBDA,0)) FBCNT=FBCNT+1
- Q FBCNT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEP2 4568 printed Feb 18, 2025@23:25:28 Page 2
- FBNHEP2 ;AISC/GRR - ENTER NURSING HOME PAYMENT ;7/1/2009
- +1 ;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- NOBAT WRITE !!,*7,"You do not have an open CNH Batch. You must have an open",!,"CNH type Batch before you can enter a payment!",!
- +1 DO Q
- +2 QUIT
- +3 ;
- GETBAT ;
- +1 ; max lines CNH batch
- SET FBAAMPI=$PIECE($GET(^FBAA(161.4,1,"FBNUM")),"^",5)
- +2 IF FBAAMPI'>0
- SET FBAAMPI=61
- +3 SET FBOUT=0
- SET DIC="^FBAA(161.7,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),U,3)=""B9""&($P(^(0),U,5)=DUZ)&($P(^(0),U,15)="""")&($G(^(""ST""))=""O"")"
- WRITE !
- DO ^DIC
- KILL DIC
- +4 IF X=""!(X="^")
- SET FBOUT=1
- QUIT
- +5 if Y<0
- GOTO GETBAT
- +6 IF $$B9INVC(+Y)>(FBAAMPI-1)
- Begin DoDot:1
- +7 WRITE !!,"This Batch already has the maximum number of Payments!"
- End DoDot:1
- GOTO GETBAT
- +8 SET FBBAT=+Y
- SET FBCNH=1
- +9 QUIT
- Q KILL 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 KILL 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
- +2 DO GETAUTHK^FBAAUTL1
- +3 QUIT
- +4 ;
- CKRAT ;check rates and fill gaps if needed
- +1 KILL FB
- SET FBERR=0
- NEW I,J,FBVIEN,FBCHFDT,FBCHTDT,FBCIEN,FBCNUM,FBDDT,FBEXDT,FBEXNDT,FBFND,FBRFDT,FBRTDT,FBRT,FBUNR
- SET I=0
- +2 FOR
- SET I=$ORDER(^FBAA(161.23,"AC",FB7078,I))
- if 'I
- QUIT
- IF $DATA(^FBAA(161.23,I,0))
- SET J=^(0)
- Begin DoDot:1
- +3 SET FBRT($PIECE(J,U))=$PIECE(J,U,5)_"^"_$PIECE(J,U,2)
- End DoDot:1
- +4 SET FBRFDT=0
- SET FBCHFDT=$SELECT(FBAABDT<FBPAYDT:$EXTRACT(FBPAYDT,1,5)_"01",1:FBAABDT)
- SET (FBCHTDT,FBDDT)=FBENDDT
- SET I=DFN
- SET FBVIEN=IFN
- +5 DO GETRAT^FBNHRAT
- DO CKFRDT^FBNHRAT
- +6 IF $DATA(FBUNR)
- SET FBERR=1
- DO ERR
- KILL FB
- QUIT
- +7 DO GETRAT
- +8 QUIT
- GETRAT NEW I,J,FBCK
- SET I=0
- +1 FOR
- SET I=$ORDER(^FBAA(161.23,"AC",FB7078,I))
- if 'I
- QUIT
- IF $DATA(^FBAA(161.23,I,0))
- SET J=^(0)
- Begin DoDot:1
- +2 SET FB($PIECE(J,U,2))=$PIECE(J,U,5)_"^"_$PIECE(J,U)
- End DoDot:1
- +3 IF $ORDER(FB(FBPAYDT+.9))=""
- SET FBERR=1
- DO ERR
- QUIT
- +4 QUIT
- +5 ;
- CALC ;get dollar amount to pay when no movements in month.
- +1 ;FBPAYS=# of days in month
- +2 ;FBTRDYS=# of treatment days
- +3 ;FBPAYDT=month of payment
- +4 ;FBENDDT=last day of payment month or last day of authorization
- +5 SET FBDEFP=0
- NEW FBCT
- SET FBCT=0
- +6 IF $GET(FBDAYS)
- SET FBTRDYS=$SELECT(FBTRDYS>FBDAYS:FBDAYS,1:FBTRDYS)
- +7 SET X=$SELECT(FBAABDT>(FBPAYDT):FBAABDT-1,1:FBPAYDT)
- +8 SET Y=$ORDER(FB(X))
- IF FBENDDT'>Y
- SET FBDEFP=FBTRDYS*+FB(Y)
- QUIT
- RATE SET X1=$ORDER(FB(X))
- SET FBCT=FBCT+1
- IF 'X1
- SET FBERR=1
- QUIT
- +1 SET FBX1=($SELECT(X1>(FBENDDT-$GET(FBENDFLG)):(FBENDDT-$GET(FBENDFLG)),1:X1)-X)
- if FBCT'>0
- SET FBX1=FBX1+1
- SET FBDEFP=FBDEFP+(FBX1*$PIECE(FB(X1),U))
- SET X=X1
- +2 IF FBENDDT>X
- GOTO RATE
- +3 QUIT
- +4 ;
- ERR ;,!,"Use the Edit Authorization option prior to entering payment.",!!
- WRITE !,"Insufficient Authorization Rate data on file for patient: ",$$NAME^FBCHREQ2(DFN)
- +1 WRITE !,"Take the appropriate action prior to entering a payment:"
- +2 WRITE !?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.",!!
- +3 QUIT
- +4 ;calculate dollars when at least one movement in month.
- CALC1 SET (I,J,Z,FBDEFP)=0
- +1 FOR
- SET J=$ORDER(FBZZ(J))
- if 'J
- QUIT
- Begin DoDot:1
- +2 SET I=$ORDER(FBZZ(0))
- if 'I
- QUIT
- Begin DoDot:2
- +3 FOR
- if '$DATA(FBZZ(I))
- QUIT
- SET X=$PIECE(FBZZ(I),"^")
- SET Y=$ORDER(FB(X-.1))
- SET X1=$ORDER(FB(X-.1))
- if 'Y
- QUIT
- Begin DoDot:3
- +4 IF $PIECE(FBZZ(I),"^",2)>Y
- SET Z=1
- DO DEFP
- SET Z=0
- SET $PIECE(FBZZ(I),"^")=Y+1
- QUIT
- +5 SET Y=$PIECE(FBZZ(I),"^",2)
- DO DEFP
- KILL FBZZ(I)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +6 KILL I,J,X,Y,X1
- QUIT
- +7 ;
- DEFP SET FBDEFP=FBDEFP+(($SELECT(FBAABDT=FBAAEDT:1,1:Y-X)+$PIECE(FBZZ(I),"^",3)+Z)*+FB(X1))
- +1 QUIT
- +2 ;
- DAYS SET (I,FBTRDYS)=0
- KILL FBPREV,FBHI
- +1 SET FBBEG=FBPAYDT+1
- +2 FOR
- SET I=$ORDER(FBZ(I))
- if 'I
- QUIT
- Begin DoDot:1
- +3 IF '$DATA(FBPREV)
- IF $PIECE(FBZ(I),U,2)
- SET FBBEG=$SELECT($PIECE(FBZ(I),U)>FBPAYDT:$PIECE(FBZ(I),U),1:FBPAYDT)
- SET FBPREV=1
- +4 IF '$PIECE(FBZ(I),U,2)
- IF $SELECT('$DATA(FBHI):1,1:$PIECE(FBZ(+FBHI),U,2))
- SET FBEND=$PIECE(FBZ(I),U)
- SET FBTRDYS=FBTRDYS+($SELECT(FBEND-FBBEG:FBEND-FBBEG,((FBAABDT<FBAAEDT)&(+$EXTRACT(FBAAEDT,6,7)=1)):0,1:1))+$PIECE(FBZ(I),U,2)
- SET FBZZ(I)=FBBEG_"^"_FBEND
- +5 IF $DATA(FBHI)
- IF $PIECE(FBZ(I),U,2)
- SET FBBEG=$PIECE(FBZ(I),U)
- +6 SET FBHI=I
- End DoDot:1
- +7 IF FBENDDT>$PIECE(FBZ(FBHI),U)
- IF $PIECE(FBZ(FBHI),U,2)
- SET FBTRDYS=FBTRDYS+($SELECT(FBENDDT-FBBEG:FBENDDT-FBBEG,1:1))+1
- SET $PIECE(FBZZ(FBHI),U,3)=1
- IF '+FBZZ(FBHI)
- SET $PIECE(FBZZ(FBHI),"^",1,2)=FBBEG_"^"_FBENDDT
- +8 IF FBENDDT=$PIECE(FBZ(FBHI),U)
- IF $PIECE(FBZ(FBHI),U,2)
- SET FBTRDYS=FBTRDYS+1
- IF '+$GET(FBZZ(FBHI))
- SET $PIECE(FBZZ(FBHI),"^",1,2)=FBBEG_"^"_FBENDDT
- +9 QUIT
- CHECK NEW FBCK,FBCK1
- +1 SET FBCK=$SELECT(FBABD<FBPAYDT:($EXTRACT(FBPAYDT,1,5)_"01"),1:FBABD)
- SET FBCK1=$ORDER(FB(FBCK-.1))
- IF $PIECE(FB(FBCK1),"^",2)>FBCK
- SET FBERR=1
- DO ERR
- QUIT
- +2 QUIT
- B9INVC(FBBAT) ; B9 Batch Invoice Count
- +1 ; Input
- +2 ; FBBAT = IEN of B9 type batch in file 161.7
- +3 ; Returns count of invoices in batch
- +4 NEW FBCNT,FBDA
- +5 SET FBCNT=0
- +6 IF $GET(FBBAT)
- Begin DoDot:1
- +7 SET FBDA=0
- +8 FOR
- SET FBDA=$ORDER(^FBAAI("AC",FBBAT,FBDA))
- if 'FBDA
- QUIT
- if $DATA(^FBAAI(FBDA,0))
- SET FBCNT=FBCNT+1
- End DoDot:1
- +9 QUIT FBCNT