source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAU2.m@ 1778

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

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1FBNHEAU2 ;AISC/dmk - ask rates for cnh authorization ;4/28/93 11:04
2 ;;3.5;FEE BASIS;;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4GETRAT S FBERR="",FBMULT=0,FBVIEN=IFN I '$D(^FBAA(161.21,"C",IFN)) S FBERR=1 W !,"Vendor: ",$P(^FBAAV(IFN,0),"^")," has no Contract data on file" Q
5 S FBRIFN=$O(^FBAA(161.21,"ACR",IFN,-(FBPAYDT+.9))) I 'FBRIFN W !,"Vendor: ",$P(^FBAAV(IFN,0),"^")," has no current Contract data on file" S FBERR=1 Q
6 S FBRIFN=$O(^FBAA(161.21,"ACR",IFN,FBRIFN,0)),FBC(0)=^FBAA(161.21,+FBRIFN,0),FBCNUM=$P(FBC(0),U),FBRIFN(0)=FBC(0)
7 S FBEDT=$P(FBC(0),U,2),FBTDT=$P(FBC(0),U,3)
8 I FBTDT<FBENDDT D
9 .S CNT=0,FBMULT=1
10 .F I=FBTDT+.9:0 S I=$O(^FBAA(161.21,"AC",IFN,I)) Q:'I!(I>FBENDDT) S CNT=CNT+1,FBRIFN(CNT)=^FBAA(161.21,$O(^(I,0)),0)
11 I FBPAYDT>FBTDT S FBERR=1 W !,"Vendor: ",$P(^FBAAV(IFN,0),U)," has no current contract on file.",! Q
12 ;display rates for selection
13 W !!?25,"VENDOR RATE SELECTION",!!
14 I FBMULT=0 S FBVIEN=IFN,FBX=$$RATE^FBAAVD1(FBCNUM),FBRATE="" D DISPLAY^FBAAVD1 S FB(0)=FBBEGDT_"^"_$S(FBTDT>FBENDDT:FBENDDT,1:FBTDT)_"^"_FBRATE_"^"_FBCNUM S:'FBRATE FBERR=1
15 I FBMULT S I="",FBRATE=0 F S I=$O(FBRIFN(I)) Q:I=""!(FBERR) D
16 . S FBX=$$RATE^FBAAVD1($P(FBRIFN(I),U)),FBFR=$$FR(FBPAYDT,$P(FBRIFN(I),U,2)),FBTO=$$TO(FBENDDT,$P(FBRIFN(I),U,3)),FBCNUM=$P(FBRIFN(I),U)
17 .W !?14,"For dates ",$$DATX^FBAAUTL(FBFR)_" - "_$$DATX^FBAAUTL(FBTO)_" : ",! D DISPLAY^FBAAVD1 S:'FBRATE FBERR=1 Q:FBERR D
18 .. S FB(I)=FBFR_"^"_FBTO_"^"_FBRATE_"^"_FBCNUM
19 ;I FBMULT S FBCHECK=1 D EST K FBCHECK,FBATODT,FBTO,FBDEFP I FBERR D
20 ;. W !,*7,"Insufficient contract data on file for current month.",!
21 I FBMULT K FBATODT,FBTO
22 Q
23 ;
24FR(X,Y) ;return date that should be used as from date at prompt
25 ;x=authorization from date
26 ;y=contract from date
27 Q $S(X>Y:X,1:Y)
28 ;
29TO(X,Y) ;return date that is default to date
30 ;x=last day of authorization or month
31 ;y=last day of contract
32 Q $S(X>Y:Y,1:X)
33 ;
34EST ;calculate estimate amount to post to 1358 for month of authorization
35 ;the FB( array contains all rate information currently available
36 ;for this patient based on vendor contract information.
37 ;FBPAYDT=begin date of autorization
38 ;FBENDDT=end date of authorization
39 ;FBATODT=either end of month or end of autorization (whichever less)
40 S Z=$Q(FB) I Z="" S FBERR=1 D ERROR Q
41 I '$D(FBATODT) S FBATODT=$S($E(FBPAYDT,1,5)_"00"+(FBDAYS)>FBENDDT:FBENDDT,1:$E(FBPAYDT,1,5)_"00"+(FBDAYS))
42 S FBDEFP=0,X=@Z
43 I FBATODT'>$P(X,U,2) S FBDEFP=($$DTC^FBUCUTL(FBATODT,FBPAYDT)+1)*$P(X,U,3) Q
44 S FBDEFP=FBDEFP+($$DTC^FBUCUTL($P(X,U,2),$P(X,U))+1*$P(X,U,3))
45MORE S Z=$Q(@Z) I Z="" S FBERR=1 D ERROR Q
46 S X=@Z,FBTO=$S($P(X,U,2)'>FBATODT:$P(X,U,2),1:FBATODT)
47 I FBTO<$P(X,U) S FBERR=1 D ERROR Q
48 I FBTO'>$P(X,U,2) S FBDEFP=FBDEFP+($$DTC^FBUCUTL(FBTO,$P(X,U))+1*$P(X,U,3)) Q
49 S FBDEFP=FBDEFP+($$DTC^FBUCUTL($P(X,U,2),$P(X,U))+1*$P(X,U,3))
50 G MORE
51ERROR W:'$D(FBCHECK) *7,!,"Unable to calculate total estimated amount. Check CNH contracts.",!
52 Q
53 ;
54FILE ;file entries for the patients authorization in file 161.23.
55 ;this file contains from and to dates and the rate we paid
56 ;during that time frame for the 7078.
57 I $Q(FB)="" S FBERR=1 Q
58 I '$G(DFN) S FBERR=1 Q
59 I '$G(FBAA78) S FBERR=1 Q
60 N DA,DIC,DIE,DR,DLAYGO,FBI S FBI=""
61 F S FBI=$O(FB(FBI)) Q:FBI="" D
62 . S X=$P(FB(FBI),U),DIC="^FBAA(161.23,",DIC(0)="L",DLAYGO=161.23 K DD,DO D FILE^DICN I Y<0 S FBERR=1 Q
63 .S DA=+Y,DIE=DIC,DR=".02////^S X=$P(FB(FBI),U,2);.03////^S X=FBAA78;.04////^S X=DFN;.05////^S X=$P(FB(FBI),U,3);.06////^S X=$P(FB(FBI),U,4)" D ^DIE
64 Q
Note: See TracBrowser for help on using the repository browser.