FBNHEAU2 ;AISC/dmk - ask rates for cnh authorization ; 1/14/10 8:00pm
;;3.5;FEE BASIS;**111**;JAN 30, 1995;Build 17
;;Per VHA Directive 10-93-142, this routine should not be modified.
GETRAT 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
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
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)
S FBEDT=$P(FBC(0),U,2),FBTDT=$P(FBC(0),U,3)
I FBTDT<FBENDDT D
.S CNT=0,FBMULT=1
.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)
I FBPAYDT>FBTDT S FBERR=1 W !,"Vendor: ",$P(^FBAAV(IFN,0),U)," has no current contract on file.",! Q
;display rates for selection
W !!?25,"VENDOR RATE SELECTION",!!
I FBMULT=0 S FBVIEN=IFN,FBRATE=1 D DISPLAY^FBAAVD1 S FB(0)=FBBEGDT_"^"_$S(FBTDT>FBENDDT:FBENDDT,1:FBTDT)_"^"_FBRATE_"^"_FBCNUM S:'FBRATE FBERR=1
I FBMULT S I="",FBRATE=0 F S I=$O(FBRIFN(I)) Q:I=""!(FBERR) D
.S FBFR=$$FR(FBPAYDT,$P(FBRIFN(I),U,2)),FBTO=$$TO(FBENDDT,$P(FBRIFN(I),U,3)),FBCNUM=$P(FBRIFN(I),U)
.W !?14,"For dates ",$$DATX^FBAAUTL(FBFR)_" - "_$$DATX^FBAAUTL(FBTO)_" : ",! S FBRATE=1 D DISPLAY^FBAAVD1 S:'FBRATE FBERR=1 Q:FBERR D
.. S FB(I)=FBFR_"^"_FBTO_"^"_FBRATE_"^"_FBCNUM
;I FBMULT S FBCHECK=1 D EST K FBCHECK,FBATODT,FBTO,FBDEFP I FBERR D
;. W !,*7,"Insufficient contract data on file for current month.",!
I FBMULT K FBATODT,FBTO
Q
;
FR(X,Y) ;return date that should be used as from date at prompt
;x=authorization from date
;y=contract from date
Q $S(X>Y:X,1:Y)
;
TO(X,Y) ;return date that is default to date
;x=last day of authorization or month
;y=last day of contract
Q $S(X>Y:Y,1:X)
;
EST ;calculate estimate amount to post to 1358 for month of authorization
;the FB( array contains all rate information currently available
;for this patient based on vendor contract information.
;FBPAYDT=begin date of autorization
;FBENDDT=end date of authorization
;FBATODT=either end of month or end of autorization (whichever less)
S Z=$Q(FB) I Z="" S FBERR=1 D ERROR Q
I '$D(FBATODT) S FBATODT=$S($E(FBPAYDT,1,5)_"00"+(FBDAYS)>FBENDDT:FBENDDT,1:$E(FBPAYDT,1,5)_"00"+(FBDAYS))
S FBDEFP=0,X=@Z
I FBATODT'>$P(X,U,2) S FBDEFP=($$DTC^FBUCUTL(FBATODT,FBPAYDT)+1)*$P(X,U,3) Q
S FBDEFP=FBDEFP+($$DTC^FBUCUTL($P(X,U,2),$P(X,U))+1*$P(X,U,3))
MORE S Z=$Q(@Z) I Z="" S FBERR=1 D ERROR Q
S X=@Z,FBTO=$S($P(X,U,2)'>FBATODT:$P(X,U,2),1:FBATODT)
I FBTO<$P(X,U) S FBERR=1 D ERROR Q
I FBTO'>$P(X,U,2) S FBDEFP=FBDEFP+($$DTC^FBUCUTL(FBTO,$P(X,U))+1*$P(X,U,3)) Q
S FBDEFP=FBDEFP+($$DTC^FBUCUTL($P(X,U,2),$P(X,U))+1*$P(X,U,3))
G MORE
ERROR W:'$D(FBCHECK) *7,!,"Unable to calculate total estimated amount. Check CNH contracts.",!
Q
;
FILE ;file entries for the patients authorization in file 161.23.
;this file contains from and to dates and the rate we paid
;during that time frame for the 7078.
I $Q(FB)="" S FBERR=1 Q
I '$G(DFN) S FBERR=1 Q
I '$G(FBAA78) S FBERR=1 Q
N DA,DIC,DIE,DR,DLAYGO,FBI S FBI=""
F S FBI=$O(FB(FBI)) Q:FBI="" D
. 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
.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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEAU2 3565 printed Apr 09, 2024@21:05:53 Page 2
FBNHEAU2 ;AISC/dmk - ask rates for cnh authorization ; 1/14/10 8:00pm
+1 ;;3.5;FEE BASIS;**111**;JAN 30, 1995;Build 17
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
GETRAT SET FBERR=""
SET FBMULT=0
SET FBVIEN=IFN
IF '$DATA(^FBAA(161.21,"C",IFN))
SET FBERR=1
WRITE !,"Vendor: ",$PIECE(^FBAAV(IFN,0),"^")," has no Contract data on file"
QUIT
+1 SET FBRIFN=$ORDER(^FBAA(161.21,"ACR",IFN,-(FBPAYDT+.9)))
IF 'FBRIFN
WRITE !,"Vendor: ",$PIECE(^FBAAV(IFN,0),"^")," has no current Contract data on file"
SET FBERR=1
QUIT
+2 SET FBRIFN=$ORDER(^FBAA(161.21,"ACR",IFN,FBRIFN,0))
SET FBC(0)=^FBAA(161.21,+FBRIFN,0)
SET FBCNUM=$PIECE(FBC(0),U)
SET FBRIFN(0)=FBC(0)
+3 SET FBEDT=$PIECE(FBC(0),U,2)
SET FBTDT=$PIECE(FBC(0),U,3)
+4 IF FBTDT<FBENDDT
Begin DoDot:1
+5 SET CNT=0
SET FBMULT=1
+6 FOR I=FBTDT+.9:0
SET I=$ORDER(^FBAA(161.21,"AC",IFN,I))
if 'I!(I>FBENDDT)
QUIT
SET CNT=CNT+1
SET FBRIFN(CNT)=^FBAA(161.21,$ORDER(^(I,0)),0)
End DoDot:1
+7 IF FBPAYDT>FBTDT
SET FBERR=1
WRITE !,"Vendor: ",$PIECE(^FBAAV(IFN,0),U)," has no current contract on file.",!
QUIT
+8 ;display rates for selection
+9 WRITE !!?25,"VENDOR RATE SELECTION",!!
+10 IF FBMULT=0
SET FBVIEN=IFN
SET FBRATE=1
DO DISPLAY^FBAAVD1
SET FB(0)=FBBEGDT_"^"_$SELECT(FBTDT>FBENDDT:FBENDDT,1:FBTDT)_"^"_FBRATE_"^"_FBCNUM
if 'FBRATE
SET FBERR=1
+11 IF FBMULT
SET I=""
SET FBRATE=0
FOR
SET I=$ORDER(FBRIFN(I))
if I=""!(FBERR)
QUIT
Begin DoDot:1
+12 SET FBFR=$$FR(FBPAYDT,$PIECE(FBRIFN(I),U,2))
SET FBTO=$$TO(FBENDDT,$PIECE(FBRIFN(I),U,3))
SET FBCNUM=$PIECE(FBRIFN(I),U)
+13 WRITE !?14,"For dates ",$$DATX^FBAAUTL(FBFR)_" - "_$$DATX^FBAAUTL(FBTO)_" : ",!
SET FBRATE=1
DO DISPLAY^FBAAVD1
if 'FBRATE
SET FBERR=1
if FBERR
QUIT
Begin DoDot:2
+14 SET FB(I)=FBFR_"^"_FBTO_"^"_FBRATE_"^"_FBCNUM
End DoDot:2
End DoDot:1
+15 ;I FBMULT S FBCHECK=1 D EST K FBCHECK,FBATODT,FBTO,FBDEFP I FBERR D
+16 ;. W !,*7,"Insufficient contract data on file for current month.",!
+17 IF FBMULT
KILL FBATODT,FBTO
+18 QUIT
+19 ;
FR(X,Y) ;return date that should be used as from date at prompt
+1 ;x=authorization from date
+2 ;y=contract from date
+3 QUIT $SELECT(X>Y:X,1:Y)
+4 ;
TO(X,Y) ;return date that is default to date
+1 ;x=last day of authorization or month
+2 ;y=last day of contract
+3 QUIT $SELECT(X>Y:Y,1:X)
+4 ;
EST ;calculate estimate amount to post to 1358 for month of authorization
+1 ;the FB( array contains all rate information currently available
+2 ;for this patient based on vendor contract information.
+3 ;FBPAYDT=begin date of autorization
+4 ;FBENDDT=end date of authorization
+5 ;FBATODT=either end of month or end of autorization (whichever less)
+6 SET Z=$QUERY(FB)
IF Z=""
SET FBERR=1
DO ERROR
QUIT
+7 IF '$DATA(FBATODT)
SET FBATODT=$SELECT($EXTRACT(FBPAYDT,1,5)_"00"+(FBDAYS)>FBENDDT:FBENDDT,1:$EXTRACT(FBPAYDT,1,5)_"00"+(FBDAYS))
+8 SET FBDEFP=0
SET X=@Z
+9 IF FBATODT'>$PIECE(X,U,2)
SET FBDEFP=($$DTC^FBUCUTL(FBATODT,FBPAYDT)+1)*$PIECE(X,U,3)
QUIT
+10 SET FBDEFP=FBDEFP+($$DTC^FBUCUTL($PIECE(X,U,2),$PIECE(X,U))+1*$PIECE(X,U,3))
MORE SET Z=$QUERY(@Z)
IF Z=""
SET FBERR=1
DO ERROR
QUIT
+1 SET X=@Z
SET FBTO=$SELECT($PIECE(X,U,2)'>FBATODT:$PIECE(X,U,2),1:FBATODT)
+2 IF FBTO<$PIECE(X,U)
SET FBERR=1
DO ERROR
QUIT
+3 IF FBTO'>$PIECE(X,U,2)
SET FBDEFP=FBDEFP+($$DTC^FBUCUTL(FBTO,$PIECE(X,U))+1*$PIECE(X,U,3))
QUIT
+4 SET FBDEFP=FBDEFP+($$DTC^FBUCUTL($PIECE(X,U,2),$PIECE(X,U))+1*$PIECE(X,U,3))
+5 GOTO MORE
ERROR if '$DATA(FBCHECK)
WRITE *7,!,"Unable to calculate total estimated amount. Check CNH contracts.",!
+1 QUIT
+2 ;
FILE ;file entries for the patients authorization in file 161.23.
+1 ;this file contains from and to dates and the rate we paid
+2 ;during that time frame for the 7078.
+3 IF $QUERY(FB)=""
SET FBERR=1
QUIT
+4 IF '$GET(DFN)
SET FBERR=1
QUIT
+5 IF '$GET(FBAA78)
SET FBERR=1
QUIT
+6 NEW DA,DIC,DIE,DR,DLAYGO,FBI
SET FBI=""
+7 FOR
SET FBI=$ORDER(FB(FBI))
if FBI=""
QUIT
Begin DoDot:1
+8 SET X=$PIECE(FB(FBI),U)
SET DIC="^FBAA(161.23,"
SET DIC(0)="L"
SET DLAYGO=161.23
KILL DD,DO
DO FILE^DICN
IF Y<0
SET FBERR=1
QUIT
+9 SET DA=+Y
SET DIE=DIC
SET 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)"
DO ^DIE
End DoDot:1
+10 QUIT
