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 Apr 09, 2024@21:03:15 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
