source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHRC.m@ 1710

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1FBNHRC ;AISC/CMR-RATE CHANGE DURING AN AUTHORIZATION ;10APR93
2 ;;3.5;FEE BASIS;;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 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)
5 S FBPROG="I $P(^(0),""^"",3)=7" D GETAUTH^FBAAUTL1 G END:'$G(FB7078)
6 S FBCNT=0 D SORT I FBCNT'>0 W !!,*7,"No rate information on file for this authorization." G END
7ASK 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
8 G END:$D(DIRUT)!('Y) S FBEDT=+Y
9 ;Get rate that will be affected by change
10 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)
11 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
12 .I FBRBDT=FBEDT S DR=".05////^S X=FBRATE" D ^DIE
13 .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
14 K DIE,DIC,DR,DA,DLAYGO
15 D SORT
16 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
17END 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
18 Q
19SORT D HED
20 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
21 S (FBCFD,FBAAOUT)=0 F S FBCFD=$O(FBAR(FBCFD)) Q:'FBCFD!(FBAAOUT) S FBCNT=FBCNT+1,FBAR1=FBAR(FBCFD) D DISPLAY
22 I FBCNT'>0 Q
23 S FBEND=+FBAR1,FBSTART=$O(FBAR(0))
24 Q
25DISPLAY ;Write out rates affected by contract
26 I $Y+5>IOSL S DIR(0)="E" D ^DIR K DIR I 'Y S FBAAOUT=1 Q
27 I $Y+5>IOSL D HED
28 W !!?5,$$DATX^FBAAUTL(FBCFD),?25,$$DATX^FBAAUTL(+FBAR1),?40,"$ ",$J($FN($P(FBAR1,"^",3),",",2),8),?55,$P(FBAR1,"^",2)
29 Q
30HED W @IOF,!,?20,"CURRENT RATE INFORMATION FOR ",$$NAME^FBCHREQ2(DFN)
31 W !!!?5,"FROM DATE",?25,"TO DATE",?40,"RATE",?55,"CONTRACT #",! F I=1:1:79 W "_"
32 Q
Note: See TracBrowser for help on using the repository browser.