FBNHRC ;AISC/CMR-RATE CHANGE DURING AN AUTHORIZATION ;10APR93
 ;;3.5;FEE BASIS;;JAN 30, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 S DIC="^FBAAA(",DIC(0)="AEQMZ",DIC("A")="Select Fee Basis Patient: " D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) END S DFN=+Y,FBNAME=Y(0,0)
 S FBPROG="I $P(^(0),""^"",3)=7" D GETAUTH^FBAAUTL1 G END:'$G(FB7078)
 S FBCNT=0 D SORT I FBCNT'>0 W !!,*7,"No rate information on file for this authorization." G END
ASK W !! S DIR(0)="DA^"_FBSTART_":"_FBEND_":EX",DIR("A")="Enter effective date of rate change: ",DIR("?")="Date must fall within authorization dates" D ^DIR K DIR
 G END:$D(DIRUT)!('Y) S FBEDT=+Y
 ;Get rate that will be affected by change
 S FBN=0 F  S FBN=$O(^FBAA(161.23,"AC",FB7078,FBN)) Q:'FBN  Q:(FBEDT'>$P($G(^FBAA(161.23,+FBN,0)),"^",2))&($P($G(^FBAA(161.23,+FBN,0)),"^")'>FBEDT)
 I FBN S FBRATE=1,FBCNUM=$P(^FBAA(161.23,FBN,0),"^",6),FBVIEN=FBVEN,FBREDT=$P(^(0),"^",2),FBRBDT=$P(^(0),"^") W !! D DISPLAY^FBAAVD1 G END:'$G(FBRATE) I FBRATE'=$P(^FBAA(161.23,FBN,0),"^",5) S (DIC,DIE)="^FBAA(161.23,",DA=FBN D
 .I FBRBDT=FBEDT S DR=".05////^S X=FBRATE" D ^DIE
 .I FBRBDT'=FBEDT S DR=".02////^S X="_$$CDTC^FBUCUTL(FBEDT,-1) D ^DIE K DIE,DA,DD,DO S DIC(0)="L",DLAYGO=161.23,X=FBEDT,DIC("DR")=".02////^S X=FBREDT;.03////^S X=FB7078;.04////^S X=DFN;.05////^S X=FBRATE;.06////^S X=FBCNUM" D FILE^DICN
 K DIE,DIC,DR,DA,DLAYGO
 D SORT
 W !! S DIR(0)="Y",DIR("A")="Do you want to change other rates associated with this Authorization",DIR("B")="No" D ^DIR K DIR G:Y ASK
END K FBNAME,DFN,FB7078,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBAUT,FBPOV,FBPROG,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FTP,CNT,FBAR,FBCFD,FBCNT,FBCNUM,FBCTD,FBEDT,FBEND,FBN,FBN1,FBRATE,FBRBDT,FBREDT,FBSTART,FBVIEN,FBX,X,Y,Z,FBAR1
 Q
SORT D HED
 S FBN=0 F  S FBN=$O(^FBAA(161.23,"AC",FB7078,FBN)) Q:'FBN  S FBN1=^FBAA(161.23,FBN,0),FBCNUM=$P(FBN1,"^",6),FBCFD=$P(FBN1,"^"),FBCTD=$P(FBN1,"^",2),FBRATE=$P(FBN1,"^",5) I FBCFD'>FBAAEDT S FBAR(FBCFD)=FBCTD_"^"_FBCNUM_"^"_FBRATE
 S (FBCFD,FBAAOUT)=0 F  S FBCFD=$O(FBAR(FBCFD)) Q:'FBCFD!(FBAAOUT)  S FBCNT=FBCNT+1,FBAR1=FBAR(FBCFD) D DISPLAY
 I FBCNT'>0 Q
 S FBEND=+FBAR1,FBSTART=$O(FBAR(0))
 Q
DISPLAY ;Write out rates affected by contract
 I $Y+5>IOSL S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
 I $Y+5>IOSL D HED
 W !!?5,$$DATX^FBAAUTL(FBCFD),?25,$$DATX^FBAAUTL(+FBAR1),?40,"$ ",$J($FN($P(FBAR1,"^",3),",",2),8),?55,$P(FBAR1,"^",2)
 Q
HED W @IOF,!,?20,"CURRENT RATE INFORMATION FOR ",$$NAME^FBCHREQ2(DFN)
 W !!!?5,"FROM DATE",?25,"TO DATE",?40,"RATE",?55,"CONTRACT #",! F I=1:1:79 W "_"
 Q