source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEP.m@ 1520

Last change on this file since 1520 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.7 KB
Line 
1FBNHEP ;AISC/GRR-ENTER NURSING HOME PAYMENT ;18DEC00
2 ;;3.5;FEE BASIS;**25**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 I '$D(^FBAA(161.7,"AB","O",DUZ)) G NOBAT^FBNHEP2
5 S FBOUT=1 F I=0:0 S I=$O(^FBAA(161.7,"AB","O",DUZ,I)) Q:I'>0 I $D(^FBAA(161.7,I,0)),$P(^(0),"^",3)="B9",$P(^(0),"^",15)="" S FBOUT=0 Q
6 G:FBOUT NOBAT^FBNHEP2
7 D GETBAT^FBNHEP2 G Q:FBOUT!('$D(FBBAT)) W !
8 ;
9RD S FBAAPTC="V",FBER=0,%DT="AEPMX",%DT("A")="Payments for which Month/Year: " D ^%DT G:X="^"!(X="") Q
10 S FBPAYDT=$E(+Y,1,5)_"00",FBMM=$E(+Y,4,5),FBYY=$E(+Y,2,3),X=+Y S FBDAYS=$$DAYS^FBNHEP1(X),(FBENDDT,FBPAYEDT)=$E(+Y,1,5)_FBDAYS
11 ;
12GETVET K FB,FB7078,FBAABDT,FBAAEDT,FBASSOC,FBAT,FBAUT,FBBEG,FBDEFP,FBEND,FBHI,FBPDT,FBPOV,FBPREV,FBPROG,FBPRTR,FBPSA,FBPT,FBRIFN,FBTRDYS,FBTT,FBTYPE,FBVEN,FBZ,FTP,IFN,FBAAID,FBAAVID
13 S FBENDDT=$E(+FBENDDT,1,5)_$$DAYS^FBNHEP1(FBENDDT) D GETVET^FBAAUTL1 G:DFN']"" Q S FBPROG="I $P(^(0),U,3)=7,($P(^(0),U,9)'[""FB583"")" D GETAUTH^FBAAUTL1 G GETVET:FTP']"",GETVET:$D(DIRUT) K FBAAOUT
14 I $E(FBPAYDT,1,5)<$E(FBAABDT,1,5)!($E(FBPAYDT,1,5)>$E(FBAAEDT,1,5)) W !!,*7,"Payment Period is NOT within the veterans authorized dates!" G GETVET
15 ;
16GETVEN S FBERR=0,IFN=$G(FBVEN) D:'IFN GETVEN^FBAAUTL1 G:IFN'>0 Q S FBENDFLG=$S(FBAAEDT'>FBENDDT:1,1:""),FBENDDT=$S(FBENDDT>FBAAEDT:FBAAEDT,1:FBENDDT)
17 I $P($G(^FBAAV(+IFN,"ADEL")),U)="Y" W !!,*7,"Vendor is flagged for Austin deletion!",! G Q
18 K FB D CKRAT^FBNHEP2 G:FBERR GETVET
19 I $D(^FBAAI("AA",IFN,DFN,$E(FBPAYDT,1,5))) S FBINA=$O(^FBAAI("AA",IFN,DFN,$E(FBPAYDT,1,5),0)) W !!,*7,"Invoice (# ",FBINA,") already exists for treatment provided in the",!,"month and year selected.",! G CHKAHD
20 ;
21LETSGO D GETACT G:FBERR GETVET
22 D:$D(FBNOAC) CALC^FBNHEP2 G:FBERR GETVET
23 ;
24ADDMOR I '$D(FBNOAC) D DAYS^FBNHEP2,CALC1^FBNHEP2
25 I FBTRDYS>0 W !!!,"Amount based on ",FBTRDYS," days of care."
26 W !!," Total Amount calculated is: $",$J(FBDEFP,7,2),!
27 ;
28RD3 S DIR(0)="Y",DIR("A")="Want to Continue with Payment Entry",DIR("B")="YES" D ^DIR K DIR G ^FBNHEP1:Y,GETVET
29 ;
30GETACT D HED^FBNHDEC S (FBTRDYS,FBTRDYS(2))=0,FBPRTR="",FBNAC=$O(^FBAACNH("AG",DFN,FBVEN,$S(FBAABDT>(FBPAYDT+1):FBAABDT,1:FBPAYDT))) G:FBNAC'>0!($P(FBNAC,".")>FBENDDT) NOAC
31 ;
32 S FBRIFN=$O(^FBAACNH("AG",DFN,FBVEN,FBNAC,0)),Z=$G(^FBAACNH(FBRIFN,0)) Q:Z=""
33 I '$D(FBPNAC),$P(Z,"^",3)="T"&($P(Z,"^",7)<4) D
34 .S FBHZ=Z D GETPRV S Z=FBPRTR Q:Z="" D DISPAC S Z=FBHZ,FBPNAC=FBPAYDT+1 D
35 ..S FBTRDYS=FBTRDYS+(($P(FBNAC,".")-FBPNAC)),FBTRDYS=$S(FBTRDYS>0:FBTRDYS,((FBAABDT<FBAAEDT)&(+$E(FBAAEDT,6,7)=1)):0,1:1)
36 S FBPNAC=FBNAC,FBCOUNT=$S($P(Z,"^",3)="A":1,$P(Z,"^",3)="T":$S($P(Z,"^",7)>3:1,1:0),1:0) S FBLTT=$P(Z,"^",3) D:FBLTT'="D" DISPAC G:$P(Z,"^",3)'="D" CONT
37 S FBHZ=Z D GETPRV S Z=FBPRTR G:FBPRTR="" GETVET D DISPAC S Z=FBHZ D DISPAC I $P(FBPRTR,"^",3)="T"&($P(FBPRTR,"^",7)<4) G SKIPC
38 S FBTRDYS=FBTRDYS+($P(FBNAC,".",1)-FBPAYDT)-1,FBTRDYS=$S(FBTRDYS>0:FBTRDYS,((FBAABDT<FBAAEDT)&(+$E(FBAAEDT,6,7)=1)):0,1:1)
39 ;
40SKIPC S FBCOUNT=0
41 ;
42CONT F I=0:0 S FBNAC=$O(^FBAACNH("AG",DFN,FBVEN,FBNAC)) Q:FBNAC'>0!($P(FBNAC,".")>FBENDDT) S FBRIFN=$O(^FBAACNH("AG",DFN,FBVEN,FBNAC,0)) I $D(^FBAACNH(FBRIFN,0)) S Z=^(0),FBLTT=$P(Z,"^",3) D MORE
43 I FBCOUNT S FBTRDYS=FBTRDYS+(FBENDDT-$P(FBPNAC,".",1))+$S(FBLTT="D":0,FBLTT="T":$S($P(Z,"^",7)<4:0,1:1),1:1),FBTRDYS=$S(FBTRDYS>0:FBTRDYS,((FBAABDT<FBAAEDT)&(+$E(FBAAEDT,6,7)=1)):0,1:1)
44 G ENDACT
45 ;
46MORE D DISPAC S FBTRDYS=FBTRDYS+($P(FBNAC,".",1)-$P(FBPNAC,".",1)+$S(FBLTT="D":0,FBLTT="T":$S($P(Z,"^",7)<4:0,1:1),1:1)),FBTRDYS=$S(FBTRDYS>0:FBTRDYS,((FBAABDT<FBAAEDT)&(+$E(FBAAEDT,6,7)=1)):0,1:1)
47AHEAD S FBPNAC=FBNAC,FBLTT=$P(Z,"^",3),FBCOUNT=$S(FBLTT="A":1,FBLTT="T":$S($P(Z,"^",7)>3:1,1:0),1:0)
48 Q
49ENDACT K FBCOUNT,FBNAC,FBPNAC,FBLTT Q
50 ;
51GETPRV S FBPRTR="",FBPREV=$O(^FBAACNH("AF",DFN,(9999999-FBPAYDT))) G:FBPREV'>0 PROB^FBNHEP1 S (FBPIFN,FBRIFN)=$O(^(FBPREV,0)),FBPRTR=$G(^FBAACNH(FBPIFN,0))
52 Q
53 ;
54NOAC D GETPRV G:FBPRTR="" ENDACT S Z=FBPRTR,FBNOAC=1
55 W !!,"No movements during payment period. Last transaction prior was:",! D DISPAC
56 I $P(Z,"^",3)="D" W !,*7,"Veteran not provided care during Payment Period!" G ENDACT
57 I $P(Z,"^",3)="T"&($P(Z,"^",7)<4) W !,*7,"Veteran has not been in Nursing Home during Payment Period" G ENDACT
58 S FBTRDYS=$E(FBENDDT,6,7)-$G(FBENDFLG) G ENDACT
59 ;
60DISPAC S Y=$P(Z,"^"),FBTYPE=$P(Z,"^",3) D PDATE^FBAAUTL,ADD^FBNHDEC:FBTYPE="A",TRAN^FBNHDEC:FBTYPE="T",DIS^FBNHDEC:FBTYPE="D"
61 S FBZ(FBRIFN)=$P($P(Z,"^"),".")_"^"_$S($P(Z,U,3)="A":1,$P(Z,U,3)="T":$S($P(Z,U,7)>3:1,1:0),1:0)
62 Q
63 ;
64Q K %DT,FBAAAD,FBAT,FBBDT,FBIFN,FBPDT,FBTDAYS,FBPAYEDT,PSA,DIRUT,DUOUT,DTOUT,FBNOAC,FB,FBZ,FBZZ,FBDEFP,FBBEG,FBEND,FBHI,FBX1,FBAMTP,FBNHAC,DFN,FB583,FBENDFLG
65 G Q^FBNHEP2
66 ;
67CHKAHD S DIR(0)="Y",DIR("A")="Do you want to continue entering this payment",DIR("B")="No" D ^DIR K DIR G GETVET:Y=0,GETVET:$D(DIRUT),LETSGO
68 Q
Note: See TracBrowser for help on using the repository browser.