FBUCUTL6 ;ALBISC/TET - UTILITY (continued) ;10/28/93 15:56
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
AUTH(FBUCP,FBUCA) ;determine if authorization file needs updating, based on
;change in disposition or other info impacting authorization
;INPUT: FBUCP = zero node of 162.7 prior to enter/edit
; FBUCA = zero node of 162.7 after enter/edit
;OUTPUT: 0 for deletion/1 for addition/2 for change/NULL for no action
; (if function follows null update file)
N FBAUTH I $P(FBUCA,U,11)=$P(FBUCP,U,11) D G AUTHQ
.;if disposition remained the same do further checking for app/app to stabilization claims
.;if either auth from/to dates,program,vendor,patient type changed, update auth
.;if dx change auth should also be updated (in 3.5 or 4)
.I '($P(FBUCA,U,11)=1!($P(FBUCA,U,11)=4)) Q
.S FBAUTH=$S($P(FBUCP,U,13,14)'=$P(FBUCA,U,13,14):2,$P(FBUCP,U,2,3)'=$P(FBUCA,U,2,3):2,$P(FBUCP,U,10)'=$P(FBUCA,U,10):2,1:"")
.;include dx in future
.Q
N FBD1,FBD2
S FBD1=$P(FBUCP,U,11),FBD2=$P(FBUCA,U,11)
I FBD2=1!(FBD2=4) S FBAUTH=$S('FBD1:1,FBD1=1!(FBD1=4):2,1:1)
I FBD2=2!(FBD2=3)!(FBD2=5)!('FBD2) S FBAUTH=$S(FBD1=1!(FBD1=4):0,1:"")
;S FBAUTH=$S(FBAUTH=2&($P(FBUCA,U,13,14)=$P(FBUCP,U,13,14)):"",FBAUTH']""&($P(FBUCA,U,13,14)'=$P(FBUCP,U,13,14)):2,1:FBAUTH)
I FBAUTH']""!(FBAUTH=2),FBD2=1!(FBD2=4) S FBAUTH=$S($P(FBUCP,U,2,3)'=$P(FBUCA,U,2,3):2,$P(FBUCP,U,10)'=$P(FBUCA,U,10):2,$P(FBUCP,U,13,14)'=$P(FBUCA,U,13,14):2,1:FBAUTH)
AUTHQ K FBD1,FBD2 Q $G(FBAUTH)
CKAUTH(FBUCP,FBUCA,FBDA) ;check authorization dates if auth is approved or approved to stabilization
;called after the AFTER event
;check is necessary as these fields are required in order to set up authorization.
;if not there, disposition is reverted back to previous and message sent.
;INPUT: FBUCP = prior node
; FBUCA = after node
; FBDA = internal entry of u/c in 162.7
;OUPUT: message to user if disposition has been reverted back
;VARIABLES: BACK = 1 if reverted to another dispo, otherwise '@'
; FBAFR & FBATO = auth from/to dates
; FBD1 & FBD2 = pre and post disposition
; FBAMT = amount approved
N BACK,DR,FBAMT,FBD,FBD1,FBD2,FBFR,FBTO
I $S($G(FBUCP)']"":1,$G(FBUCA)']"":1,'+$G(FBDA):1,1:0) G CKAUTHQ
S FBD1=$P(FBUCP,U,11),FBD2=$P(FBUCA,U,11)
;if disposition is not approved or approve to stab then quit,
; if disp is approv or approv to stab and auth fr/to dates incomplete then quit
I $S('(FBD2=1!(FBD2=4)):1,+$P(FBUCA,U,13)&(+$P(FBUCA,U,14)):1,1:0) G CKAUTHQ
S BACK=$S(FBD1:1,1:0),FBD=$S(BACK:+$P(FBUCP,U,11),1:"@"),(FBFR,FBTO,FBAMT)=0
I BACK,FBD1=1!(FBD1=4) S FBFR=$P(FBUCP,U,13),FBTO=$P(FBUCP,U,14),FBAMT=$P(FBUCP,U,15)
E S:$P(FBUCA,U,13) FBFR="@" S:$P(FBUCA,U,14) FBTO="@" S:$P(FBUCA,U,15) FBAMT="@"
;reset fbuca
I FBD'=0 S $P(FBUCA,U,11)=$S(FBD="@":"",1:FBD)
I FBFR'=0 S $P(FBUCA,U,13)=$S(FBFR="@":"",1:FBFR)
I FBTO'=0 S $P(FBUCA,U,14)=$S(FBTO="@":"",1:FBTO)
I FBAMT'=0 S $P(FBUCA,U,15)=$S(FBAMT="@":"",1:FBAMT)
;set to call die & call
S DR="S:FBD=""@"" Y=""@1"";10////^S X=FBD;S Y=""@2"";@1;10///@;@2;S:FBFR=0 Y=""@3"";S:FBFR=""@"" Y=""@30"";12///^S X=FBFR;S Y=""@3"";@30;12///@;@3;S:FBTO=0 Y=""@4"";S:FBTO=""@"" Y=""@40"";13///^S X=FBTO S Y=""@4"";@40;13///@;@4"
S DR(162.7,1)="S:FBAMT=0 Y=""@99"";S:FBAMT=""@"" Y=""@50"";14///^S X=FBAMT;S Y=""@99"";@50;14///@;@99"
D DIE^FBUCUTL2("^FB583(",FBDA,.DR)
;write message
W !,*7,"Authorization From/To dates are missing.",!,"Disposition has not been updated.",!,"When entering in this disposition, please include these dates.",!
CKAUTHQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCUTL6 3678 printed Dec 13, 2024@02:00:35 Page 2
FBUCUTL6 ;ALBISC/TET - UTILITY (continued) ;10/28/93 15:56
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
AUTH(FBUCP,FBUCA) ;determine if authorization file needs updating, based on
+1 ;change in disposition or other info impacting authorization
+2 ;INPUT: FBUCP = zero node of 162.7 prior to enter/edit
+3 ; FBUCA = zero node of 162.7 after enter/edit
+4 ;OUTPUT: 0 for deletion/1 for addition/2 for change/NULL for no action
+5 ; (if function follows null update file)
+6 NEW FBAUTH
IF $PIECE(FBUCA,U,11)=$PIECE(FBUCP,U,11)
Begin DoDot:1
+7 ;if disposition remained the same do further checking for app/app to stabilization claims
+8 ;if either auth from/to dates,program,vendor,patient type changed, update auth
+9 ;if dx change auth should also be updated (in 3.5 or 4)
+10 IF '($PIECE(FBUCA,U,11)=1!($PIECE(FBUCA,U,11)=4))
QUIT
+11 SET FBAUTH=$SELECT($PIECE(FBUCP,U,13,14)'=$PIECE(FBUCA,U,13,14):2,$PIECE(FBUCP,U,2,3)'=$PIECE(FBUCA,U,2,3):2,$PIECE(FBUCP,U,10)'=$PIECE(FBUCA,U,10):2,1:"")
+12 ;include dx in future
+13 QUIT
End DoDot:1
GOTO AUTHQ
+14 NEW FBD1,FBD2
+15 SET FBD1=$PIECE(FBUCP,U,11)
SET FBD2=$PIECE(FBUCA,U,11)
+16 IF FBD2=1!(FBD2=4)
SET FBAUTH=$SELECT('FBD1:1,FBD1=1!(FBD1=4):2,1:1)
+17 IF FBD2=2!(FBD2=3)!(FBD2=5)!('FBD2)
SET FBAUTH=$SELECT(FBD1=1!(FBD1=4):0,1:"")
+18 ;S FBAUTH=$S(FBAUTH=2&($P(FBUCA,U,13,14)=$P(FBUCP,U,13,14)):"",FBAUTH']""&($P(FBUCA,U,13,14)'=$P(FBUCP,U,13,14)):2,1:FBAUTH)
+19 IF FBAUTH']""!(FBAUTH=2)
IF FBD2=1!(FBD2=4)
SET FBAUTH=$SELECT($PIECE(FBUCP,U,2,3)'=$PIECE(FBUCA,U,2,3):2,$PIECE(FBUCP,U,10)'=$PIECE(FBUCA,U,10):2,$PIECE(FBUCP,U,13,14)'=$PIECE(FBUCA,U,13,14):2,1:FBAUTH)
AUTHQ KILL FBD1,FBD2
QUIT $GET(FBAUTH)
CKAUTH(FBUCP,FBUCA,FBDA) ;check authorization dates if auth is approved or approved to stabilization
+1 ;called after the AFTER event
+2 ;check is necessary as these fields are required in order to set up authorization.
+3 ;if not there, disposition is reverted back to previous and message sent.
+4 ;INPUT: FBUCP = prior node
+5 ; FBUCA = after node
+6 ; FBDA = internal entry of u/c in 162.7
+7 ;OUPUT: message to user if disposition has been reverted back
+8 ;VARIABLES: BACK = 1 if reverted to another dispo, otherwise '@'
+9 ; FBAFR & FBATO = auth from/to dates
+10 ; FBD1 & FBD2 = pre and post disposition
+11 ; FBAMT = amount approved
+12 NEW BACK,DR,FBAMT,FBD,FBD1,FBD2,FBFR,FBTO
+13 IF $SELECT($GET(FBUCP)']"":1,$GET(FBUCA)']"":1,'+$GET(FBDA):1,1:0)
GOTO CKAUTHQ
+14 SET FBD1=$PIECE(FBUCP,U,11)
SET FBD2=$PIECE(FBUCA,U,11)
+15 ;if disposition is not approved or approve to stab then quit,
+16 ; if disp is approv or approv to stab and auth fr/to dates incomplete then quit
+17 IF $SELECT('(FBD2=1!(FBD2=4)):1,+$PIECE(FBUCA,U,13)&(+$PIECE(FBUCA,U,14)):1,1:0)
GOTO CKAUTHQ
+18 SET BACK=$SELECT(FBD1:1,1:0)
SET FBD=$SELECT(BACK:+$PIECE(FBUCP,U,11),1:"@")
SET (FBFR,FBTO,FBAMT)=0
+19 IF BACK
IF FBD1=1!(FBD1=4)
SET FBFR=$PIECE(FBUCP,U,13)
SET FBTO=$PIECE(FBUCP,U,14)
SET FBAMT=$PIECE(FBUCP,U,15)
+20 IF '$TEST
if $PIECE(FBUCA,U,13)
SET FBFR="@"
if $PIECE(FBUCA,U,14)
SET FBTO="@"
if $PIECE(FBUCA,U,15)
SET FBAMT="@"
+21 ;reset fbuca
+22 IF FBD'=0
SET $PIECE(FBUCA,U,11)=$SELECT(FBD="@":"",1:FBD)
+23 IF FBFR'=0
SET $PIECE(FBUCA,U,13)=$SELECT(FBFR="@":"",1:FBFR)
+24 IF FBTO'=0
SET $PIECE(FBUCA,U,14)=$SELECT(FBTO="@":"",1:FBTO)
+25 IF FBAMT'=0
SET $PIECE(FBUCA,U,15)=$SELECT(FBAMT="@":"",1:FBAMT)
+26 ;set to call die & call
+27 SET DR="S:FBD=""@"" Y=""@1"";10////^S X=FBD;S Y=""@2"";@1;10///@;@2;S:FBFR=0 Y=""@3"";S:FBFR=""@"" Y=""@30"";12///^S X=FBFR;S Y=""@3"";@30;12///@;@3;S:FBTO=0 Y=""@4"";S:FBTO=""@"" Y=""@40"";13///^S X=FBTO S Y=""@4"";@40;13///@;@4"
+28 SET DR(162.7,1)="S:FBAMT=0 Y=""@99"";S:FBAMT=""@"" Y=""@50"";14///^S X=FBAMT;S Y=""@99"";@50;14///@;@99"
+29 DO DIE^FBUCUTL2("^FB583(",FBDA,.DR)
+30 ;write message
+31 WRITE !,*7,"Authorization From/To dates are missing.",!,"Disposition has not been updated.",!,"When entering in this disposition, please include these dates.",!
CKAUTHQ QUIT
