- FBNHRC ;AISC/CMR - RATE CHANGE DURING AN AUTHORIZATION ;9/22/2014
- ;;3.5;FEE BASIS;**108,154**;JAN 30, 1995;Build 12
- ;;Per VA Directive 6402, 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
- . N FBX
- . S FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Change CNH rate.")
- . I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
- 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
- D GETAUTHK^FBAAUTL1
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHRC 2776 printed Mar 13, 2025@21:04:05 Page 2
- FBNHRC ;AISC/CMR - RATE CHANGE DURING AN AUTHORIZATION ;9/22/2014
- +1 ;;3.5;FEE BASIS;**108,154**;JAN 30, 1995;Build 12
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 SET DIC="^FBAAA("
- SET DIC(0)="AEQMZ"
- SET DIC("A")="Select Fee Basis Patient: "
- DO ^DIC
- KILL DIC
- if $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
- GOTO END
- SET DFN=+Y
- SET FBNAME=Y(0,0)
- +4 SET FBPROG="I $P(^(0),""^"",3)=7"
- DO GETAUTH^FBAAUTL1
- if '$GET(FB7078)
- GOTO END
- +5 SET FBCNT=0
- DO SORT
- IF FBCNT'>0
- WRITE !!,*7,"No rate information on file for this authorization."
- GOTO END
- ASK WRITE !!
- SET DIR(0)="DA^"_FBSTART_":"_FBEND_":EX"
- SET DIR("A")="Enter effective date of rate change: "
- SET DIR("?")="Date must fall within authorization dates"
- DO ^DIR
- KILL DIR
- +1 if $DATA(DIRUT)!('Y)
- GOTO END
- SET FBEDT=+Y
- +2 ;Get rate that will be affected by change
- +3 SET FBN=0
- FOR
- SET FBN=$ORDER(^FBAA(161.23,"AC",FB7078,FBN))
- if 'FBN
- QUIT
- if (FBEDT'>$PIECE($GET(^FBAA(161.23,+FBN,0)),"^",2))&($PIECE($GET(^FBAA(161.23,+FBN,0)),"^")'>FBEDT)
- QUIT
- +4 IF FBN
- SET FBRATE=1
- SET FBCNUM=$PIECE(^FBAA(161.23,FBN,0),"^",6)
- SET FBVIEN=FBVEN
- SET FBREDT=$PIECE(^(0),"^",2)
- SET FBRBDT=$PIECE(^(0),"^")
- WRITE !!
- DO DISPLAY^FBAAVD1
- if '$GET(FBRATE)
- GOTO END
- IF FBRATE'=$PIECE(^FBAA(161.23,FBN,0),"^",5)
- SET (DIC,DIE)="^FBAA(161.23,"
- SET DA=FBN
- Begin DoDot:1
- +5 IF FBRBDT=FBEDT
- SET DR=".05////^S X=FBRATE"
- DO ^DIE
- +6 IF FBRBDT'=FBEDT
- SET DR=".02////^S X="_$$CDTC^FBUCUTL(FBEDT,-1)
- DO ^DIE
- KILL DIE,DA,DD,DO
- SET DIC(0)="L"
- SET DLAYGO=161.23
- SET X=FBEDT
- SET DIC("DR")=".02////^S X=FBREDT;.03////^S X=FB7078;.04////^S X=DFN;.05////^S X=FBRATE;.06////^S X=FBCNUM"
- DO FILE^DICN
- +7 NEW FBX
- +8 SET FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Change CNH rate.")
- +9 IF 'FBX
- WRITE !,"Error adding record in User Audit. Please contact IRM."
- End DoDot:1
- +10 KILL DIE,DIC,DR,DA,DLAYGO
- +11 DO SORT
- +12 WRITE !!
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to change other rates associated with this Authorization"
- SET DIR("B")="No"
- DO ^DIR
- KILL DIR
- if Y
- GOTO ASK
- END KILL 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
- +1 DO GETAUTHK^FBAAUTL1
- +2 QUIT
- SORT DO HED
- +1 SET FBN=0
- FOR
- SET FBN=$ORDER(^FBAA(161.23,"AC",FB7078,FBN))
- if 'FBN
- QUIT
- SET FBN1=^FBAA(161.23,FBN,0)
- SET FBCNUM=$PIECE(FBN1,"^",6)
- SET FBCFD=$PIECE(FBN1,"^")
- SET FBCTD=$PIECE(FBN1,"^",2)
- SET FBRATE=$PIECE(FBN1,"^",5)
- IF FBCFD'>FBAAEDT
- SET FBAR(FBCFD)=FBCTD_"^"_FBCNUM_"^"_FBRATE
- +2 SET (FBCFD,FBAAOUT)=0
- FOR
- SET FBCFD=$ORDER(FBAR(FBCFD))
- if 'FBCFD!(FBAAOUT)
- QUIT
- SET FBCNT=FBCNT+1
- SET FBAR1=FBAR(FBCFD)
- DO DISPLAY
- +3 IF FBCNT'>0
- QUIT
- +4 SET FBEND=+FBAR1
- SET FBSTART=$ORDER(FBAR(0))
- +5 QUIT
- DISPLAY ;Write out rates affected by contract
- +1 IF $Y+5>IOSL
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET FBAAOUT=1
- QUIT
- +2 IF $Y+5>IOSL
- DO HED
- +3 WRITE !!?5,$$DATX^FBAAUTL(FBCFD),?25,$$DATX^FBAAUTL(+FBAR1),?40,"$ ",$JUSTIFY($FNUMBER($PIECE(FBAR1,"^",3),",",2),8),?55,$PIECE(FBAR1,"^",2)
- +4 QUIT
- HED WRITE @IOF,!,?20,"CURRENT RATE INFORMATION FOR ",$$NAME^FBCHREQ2(DFN)
- +1 WRITE !!!?5,"FROM DATE",?25,"TO DATE",?40,"RATE",?55,"CONTRACT #",!
- FOR I=1:1:79
- WRITE "_"
- +2 QUIT
