FBUCUPD ;ALBISC/TET - UPDATE AFTER EVENT ;9/22/2014
;;3.5;FEE BASIS;**8,27,38,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
UPDATE(FBUCP,FBUCPA,FBUCA,FBUCAA,FBDA,FBACT,FBUCDISR) ;update if before and after values differ
;INPUT: FBUCP - zero node of 162.7, prior
; FBUCPA- 'A' (appeal) node of 162.7, prior
; FBUCA - zero node of 162.7, after
; FBUCAA- 'A' (appeal) node of 162.7, after
; FBDA - IEN of 162.7
; FBACT - action type
; FBUCDISR - (option) exists if disapp.
; 1 = denial reasons for gr to be same as prim
; 0 = ask denial reason for each claim in gr
;VARIABLES:
; FBSTATUS - 0 if no change, or status ien to 162.92
; FBORDER - order number of status in 162.92
; FBLET - = 1 if status or disp. changed (letter should be printed)
; FBDISP - flag if disp. changed to approved from other
; than approved. 1 to delete disap. reasons
; 0 no action
; FBDISPDT - date disp. changed, 0 if no change, "@" to delete
; FBEXP - exp. date, 0 if no change, "@" to delete
; or new date in internal format
; FBVALID - valid date claim rec., 0 if no change, "@" to delete
; or today's date in internal format
; FBORIG - date of original disp. or "@" to delete
; to approve. 1 is to set in file 161, 0 is to delete.
I $S('+$G(FBDA):1,$G(FBACT)']"":1,$G(FBUCA)']"":1,1:0) G END
;
I "^ENT^EDT^DIS^REO^APL^AED^COVA^"[("^"_FBACT_"^") D
. N FBX,FBTXT
. S FBTXT=""
. I FBACT="ENT" S FBTXT="Enter claim."
. I FBACT="EDT" S FBTXT="Edit claim."
. I FBACT="DIS" S FBTXT="Disposition claim."
. I FBACT="REO" S FBTXT="Reopen claim."
. I FBACT="APL" S FBTXT="Enter appeal."
. I FBACT="AED" S FBTXT="Edit appeal."
. I FBACT="COVA" S FBTXT="Enter COVA appeal."
. S FBX=$$ADDUA^FBUTL9(162.7,FBDA_",",FBTXT)
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
;
AUTH ;determine if auth. needs to be updated, based upon disp.
;returns variable FBAUTH, may returne FBOUT
D AUTH^FBUCUPD1(FBUCP,FBUCA,FBDA,FBACT)
;
Q ;enter code to task remainder of update here
;S ZTRTN="DQ^FBUCUPD",ZTDESC="UPDATE UNAUTH CLAIM",ZTDTH=$H,ZTIO="",ZTSAVE("FBUCP")="",ZTSAVE("FBUCPA")="",ZTSAVE("FBUCA")="",ZTSAVE("FBUCAA")="",ZTSAVE("FBDA")="" S:$D(FBAUTH) ZTSAVE("FBAUTH")=""
;D ^%ZTLOAD G END
;
DQ ;de-queue tasked job here
D:$D(XRTL) T0^%ZOSV ;start monitor
N FBD1,FBD2,FBDISP,FBDISPDT,FBEXP,FBLET,FBORDER,FBORIG,FBST,FBSTATUS,FBUC,FBVALID S (FBDISP,FBDISPDT,FBEXP,FBLET,FBORDER,FBORIG,FBSTATUS,FBVALID)=0,FBUC=$$FBUC^FBUCUTL2(1)
;
STATUS ;determine status of claim
;FBST=status of claim prior to update;updated to most current
S FBST=$$ORDER^FBUCUTL(+$P(FBUCA,U,24)) I FBST<40 S FBST=$S($$PEND^FBUCUTL(FBDA):10,$P(FBUC,U,7)&(FBACT="ENT"):5,1:30)
;
DISP ;dispostion change
I $P(FBUCP,U,11)'=$P(FBUCA,U,11),$P(FBUCA,U,11) D
.S FBST=$S($P(FBUCAA,U,6):90,$P(FBUCAA,U,4):70,1:40)
.S FBDISPDT=DT,FBORIG=$S('$P(FBUCP,U,11)&(FBST=40):DT,1:0)
I $P(FBUCP,U,11)'=$P(FBUCA,U,11),'$P(FBUCA,U,11) D
.N FBO S FBO=$$ORDER^FBUCUTL(+$P(FBUCP,U,24))
.I FBO=90 S FBST=$S($P(FBUCAA,U,5):80,1:70)
.I FBO=70 S FBST=$S($P(FBUCAA,U,3):60,$P(FBUCAA,U,2):55,$P(FBUCAA,U):50,1:40)
.I FBO=40 S FBST=$S($$PEND^FBUCUTL(FBDA):10,1:30)
.S FBDISPDT="@",FBORIG=$S($$ORDER^FBUCUTL($P(FBUCP,U,24))=40:"@",1:0)
I $P(FBUCP,U,11)'=$P(FBUCA,U,11) S FBLET=1 S FBD1=$P(FBUCP,U,11),FBD2=$P(FBUCA,U,11) I "^2^3^5^"[FBD1,"^1^4^"[FBD2 S FBDISP=1
I $P(FBUCP,U,11)=$P(FBUCA,U,11),FBUCPA=FBUCAA S FBST=$S($P(FBUCA,U,11):40,1:FBST)
;
APPEAL ;appeal change - check if disposition remains unchanged
I FBUCAA]""!(FBUCPA'=FBUCAA) D
.I $P(FBUCAA,U,2)&($P(FBUCA,U,11)=5) S FBST=70 Q
.S FBST=$S('$P(FBUCAA,U):40,'$P(FBUCAA,U,2):50,'$P(FBUCAA,U,3):55,'$P(FBUCAA,U,4):60,'$P(FBUCAA,U,5):70,'$P(FBUCAA,U,6):80,$P(FBUCAA,U,6):90,$P(FBUCAA,U,5):80,$P(FBUCAA,U,4):70,$P(FBUCAA,U,3):60,$P(FBUCAA,U,2):55,$P(FBUCAA,U):50,1:FBST)
;
S FBORDER=FBST,FBSTATUS=$$STATUS^FBUCUTL(FBORDER) S:FBORIG]"" $P(FBUCA,U,22)=$S(FBORIG="@":"",FBORIG=0:"",1:FBORIG)
I FBSTATUS,FBSTATUS'=$P(FBUCA,U,24)!(FBUCP']"")!((FBORDER=10)&("^ENT^REQ^"[FBACT)) D
.S FBLET=$S(FBORDER=10:1,FBORDER=40&(FBACT="ENT"):1,FBORDER=$$ORDER^FBUCUTL(+$P(FBUCA,U,24)):0,1:1) I FBLET S FBLET=$S($$LETTER^FBUCUTL2(FBORDER):1,1:0)
.S FBVALID=$S(FBORDER>20&('$P(FBUCA,U,8))&('$$PEND^FBUCUTL(FBDA)):DT,FBORDER<20&($P(FBUCA,U,8)):"@",1:0)
I FBACT="REC" N FBEXPD27 S FBEXPD27=$S(+$P(FBUCA,U,26)>0:0,+$P(FBUCA,U,19)>0:+$P(FBUCA,U,19),1:0)
S:'FBLET FBEXP=$$EXPIRE^FBUCUTL8(FBDA,$S(FBORDER>$$ORDER^FBUCUTL(+$P(FBUCA,U,24)):$S('$P(FBUCA,U,25):DT,1:+$P(FBUCA,U,25)),FBACT="REC":$S($D(FBEXPD27):FBEXPD27,1:0),FBORDER=55:+$P(FBUCAA,U,2),1:DT),FBUCA,FBORDER)
;
DIE ;die update
I $S(FBSTATUS:1,FBVALID'=0:1,FBEXP'=0:1,FBLET:1,FBORIG'=0:1,FBDISPDT'=0:1,1:0) S DA=FBDA,DIE="^FB583(",DR="[FB UNAUTHORIZED UPDATE]" D
.D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE D L -^FB583(FBDA)
..I FBUCP'=FBUCA!(FBUCPA'=FBUCAA) S DR="27////^S X=DUZ;28///^S X=DT" D
...I $P(FBUCAA,U,2)&($P(FBUCA,U,11)=5) S DR=DR_";53///^S X=DT"
...D ^DIE
.K DIE,DA,DR,DQ,FBLOCK
.D:FBDISP DELDAP^FBUCUTL3(FBDA)
.I $G(FBUCDISR)=0!($P($G(FBUCDISR),U)=1) D DISAPR^FBUCUTL8
S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ;stop monitor
;
LETTER ;letter denoting change of status or disposition
N FBLETDT I FBLET,"^1^4^"'[(U_$P(FBUCA,U,11)_U) D AUTO^FBUCLET(FBDA,FBORDER,FBUCA,FBUC) ;print letter/update fields if letter prints
END ;kill variables and quit
K FBAUTH,FBLOCK,FBUCAA,FBUCP,FBUCPA,XRT0,XRTN,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCUPD 5816 printed Nov 22, 2024@17:10:38 Page 2
FBUCUPD ;ALBISC/TET - UPDATE AFTER EVENT ;9/22/2014
+1 ;;3.5;FEE BASIS;**8,27,38,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
UPDATE(FBUCP,FBUCPA,FBUCA,FBUCAA,FBDA,FBACT,FBUCDISR) ;update if before and after values differ
+1 ;INPUT: FBUCP - zero node of 162.7, prior
+2 ; FBUCPA- 'A' (appeal) node of 162.7, prior
+3 ; FBUCA - zero node of 162.7, after
+4 ; FBUCAA- 'A' (appeal) node of 162.7, after
+5 ; FBDA - IEN of 162.7
+6 ; FBACT - action type
+7 ; FBUCDISR - (option) exists if disapp.
+8 ; 1 = denial reasons for gr to be same as prim
+9 ; 0 = ask denial reason for each claim in gr
+10 ;VARIABLES:
+11 ; FBSTATUS - 0 if no change, or status ien to 162.92
+12 ; FBORDER - order number of status in 162.92
+13 ; FBLET - = 1 if status or disp. changed (letter should be printed)
+14 ; FBDISP - flag if disp. changed to approved from other
+15 ; than approved. 1 to delete disap. reasons
+16 ; 0 no action
+17 ; FBDISPDT - date disp. changed, 0 if no change, "@" to delete
+18 ; FBEXP - exp. date, 0 if no change, "@" to delete
+19 ; or new date in internal format
+20 ; FBVALID - valid date claim rec., 0 if no change, "@" to delete
+21 ; or today's date in internal format
+22 ; FBORIG - date of original disp. or "@" to delete
+23 ; to approve. 1 is to set in file 161, 0 is to delete.
+24 IF $SELECT('+$GET(FBDA):1,$GET(FBACT)']"":1,$GET(FBUCA)']"":1,1:0)
GOTO END
+25 ;
+26 IF "^ENT^EDT^DIS^REO^APL^AED^COVA^"[("^"_FBACT_"^")
Begin DoDot:1
+27 NEW FBX,FBTXT
+28 SET FBTXT=""
+29 IF FBACT="ENT"
SET FBTXT="Enter claim."
+30 IF FBACT="EDT"
SET FBTXT="Edit claim."
+31 IF FBACT="DIS"
SET FBTXT="Disposition claim."
+32 IF FBACT="REO"
SET FBTXT="Reopen claim."
+33 IF FBACT="APL"
SET FBTXT="Enter appeal."
+34 IF FBACT="AED"
SET FBTXT="Edit appeal."
+35 IF FBACT="COVA"
SET FBTXT="Enter COVA appeal."
+36 SET FBX=$$ADDUA^FBUTL9(162.7,FBDA_",",FBTXT)
+37 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+38 ;
AUTH ;determine if auth. needs to be updated, based upon disp.
+1 ;returns variable FBAUTH, may returne FBOUT
+2 DO AUTH^FBUCUPD1(FBUCP,FBUCA,FBDA,FBACT)
+3 ;
Q ;enter code to task remainder of update here
+1 ;S ZTRTN="DQ^FBUCUPD",ZTDESC="UPDATE UNAUTH CLAIM",ZTDTH=$H,ZTIO="",ZTSAVE("FBUCP")="",ZTSAVE("FBUCPA")="",ZTSAVE("FBUCA")="",ZTSAVE("FBUCAA")="",ZTSAVE("FBDA")="" S:$D(FBAUTH) ZTSAVE("FBAUTH")=""
+2 ;D ^%ZTLOAD G END
+3 ;
DQ ;de-queue tasked job here
+1 ;start monitor
if $DATA(XRTL)
DO T0^%ZOSV
+2 NEW FBD1,FBD2,FBDISP,FBDISPDT,FBEXP,FBLET,FBORDER,FBORIG,FBST,FBSTATUS,FBUC,FBVALID
SET (FBDISP,FBDISPDT,FBEXP,FBLET,FBORDER,FBORIG,FBSTATUS,FBVALID)=0
SET FBUC=$$FBUC^FBUCUTL2(1)
+3 ;
STATUS ;determine status of claim
+1 ;FBST=status of claim prior to update;updated to most current
+2 SET FBST=$$ORDER^FBUCUTL(+$PIECE(FBUCA,U,24))
IF FBST<40
SET FBST=$SELECT($$PEND^FBUCUTL(FBDA):10,$PIECE(FBUC,U,7)&(FBACT="ENT"):5,1:30)
+3 ;
DISP ;dispostion change
+1 IF $PIECE(FBUCP,U,11)'=$PIECE(FBUCA,U,11)
IF $PIECE(FBUCA,U,11)
Begin DoDot:1
+2 SET FBST=$SELECT($PIECE(FBUCAA,U,6):90,$PIECE(FBUCAA,U,4):70,1:40)
+3 SET FBDISPDT=DT
SET FBORIG=$SELECT('$PIECE(FBUCP,U,11)&(FBST=40):DT,1:0)
End DoDot:1
+4 IF $PIECE(FBUCP,U,11)'=$PIECE(FBUCA,U,11)
IF '$PIECE(FBUCA,U,11)
Begin DoDot:1
+5 NEW FBO
SET FBO=$$ORDER^FBUCUTL(+$PIECE(FBUCP,U,24))
+6 IF FBO=90
SET FBST=$SELECT($PIECE(FBUCAA,U,5):80,1:70)
+7 IF FBO=70
SET FBST=$SELECT($PIECE(FBUCAA,U,3):60,$PIECE(FBUCAA,U,2):55,$PIECE(FBUCAA,U):50,1:40)
+8 IF FBO=40
SET FBST=$SELECT($$PEND^FBUCUTL(FBDA):10,1:30)
+9 SET FBDISPDT="@"
SET FBORIG=$SELECT($$ORDER^FBUCUTL($PIECE(FBUCP,U,24))=40:"@",1:0)
End DoDot:1
+10 IF $PIECE(FBUCP,U,11)'=$PIECE(FBUCA,U,11)
SET FBLET=1
SET FBD1=$PIECE(FBUCP,U,11)
SET FBD2=$PIECE(FBUCA,U,11)
IF "^2^3^5^"[FBD1
IF "^1^4^"[FBD2
SET FBDISP=1
+11 IF $PIECE(FBUCP,U,11)=$PIECE(FBUCA,U,11)
IF FBUCPA=FBUCAA
SET FBST=$SELECT($PIECE(FBUCA,U,11):40,1:FBST)
+12 ;
APPEAL ;appeal change - check if disposition remains unchanged
+1 IF FBUCAA]""!(FBUCPA'=FBUCAA)
Begin DoDot:1
+2 IF $PIECE(FBUCAA,U,2)&($PIECE(FBUCA,U,11)=5)
SET FBST=70
QUIT
+3 SET FBST=$SELECT('$PIECE(FBUCAA,U):40,'$PIECE(FBUCAA,U,2):50,'...
... $PIECE(FBUCAA,U,3):55,'$PIECE(FBUCAA,U,4):60,'$PIECE(FBUCAA,U,5):70,'$PIECE(FBUCAA,U,6):80,$PIECE(FBUCAA,U,6):90,$PIECE(FBUCAA,U,5):80,$PIECE(FBUCAA,U,4):70,$PIECE(FBUCAA,U,3):60,$PIECE(FBUCAA,U,2):55,$PIECE(FBUCAA,U):50,1:FBST)
End DoDot:1
+4 ;
+5 SET FBORDER=FBST
SET FBSTATUS=$$STATUS^FBUCUTL(FBORDER)
if FBORIG]""
SET $PIECE(FBUCA,U,22)=$SELECT(FBORIG="@":"",FBORIG=0:"",1:FBORIG)
+6 IF FBSTATUS
IF FBSTATUS'=$PIECE(FBUCA,U,24)!(FBUCP']"")!((FBORDER=10)&("^ENT^REQ^"[FBACT))
Begin DoDot:1
+7 SET FBLET=$SELECT(FBORDER=10:1,FBORDER=40&(FBACT="ENT"):1,FBORDER=$$ORDER^FBUCUTL(+$PIECE(FBUCA,U,24)):0,1:1)
IF FBLET
SET FBLET=$SELECT($$LETTER^FBUCUTL2(FBORDER):1,1:0)
+8 SET FBVALID=$SELECT(FBORDER>20&('$PIECE(FBUCA,U,8))&('$$PEND^FBUCUTL(FBDA)):DT,FBORDER<20&($PIECE(FBUCA,U,8)):"@",1:0)
End DoDot:1
+9 IF FBACT="REC"
NEW FBEXPD27
SET FBEXPD27=$SELECT(+$PIECE(FBUCA,U,26)>0:0,+$PIECE(FBUCA,U,19)>0:+$PIECE(FBUCA,U,19),1:0)
+10 if 'FBLET
SET FBEXP=$$EXPIRE^FBUCUTL8(FBDA,$SELECT(FBORDER>$$ORDER^FBUCUTL(+$PIECE(FBUCA,U,24)):$SELECT('$PIECE(FBUCA,U,25):DT,1:+$PIECE(FBUCA,U,25)),FBACT="REC":$SELECT($DATA(FBEXPD27):FBEXPD27,1:0),FBORDER=55:+$PIECE(FBUCAA,U,2),1:DT),FBUCA,FBORDER
)
+11 ;
DIE ;die update
+1 IF $SELECT(FBSTATUS:1,FBVALID'=0:1,FBEXP'=0:1,FBLET:1,FBORIG'=0:1,FBDISPDT'=0:1,1:0)
SET DA=FBDA
SET DIE="^FB583("
SET DR="[FB UNAUTHORIZED UPDATE]"
Begin DoDot:1
+2 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
Begin DoDot:2
+3 IF FBUCP'=FBUCA!(FBUCPA'=FBUCAA)
SET DR="27////^S X=DUZ;28///^S X=DT"
Begin DoDot:3
+4 IF $PIECE(FBUCAA,U,2)&($PIECE(FBUCA,U,11)=5)
SET DR=DR_";53///^S X=DT"
+5 DO ^DIE
End DoDot:3
End DoDot:2
LOCK -^FB583(FBDA)
+6 KILL DIE,DA,DR,DQ,FBLOCK
+7 if FBDISP
DO DELDAP^FBUCUTL3(FBDA)
+8 IF $GET(FBUCDISR)=0!($PIECE($GET(FBUCDISR),U)=1)
DO DISAPR^FBUCUTL8
End DoDot:1
+9 ;stop monitor
if $DATA(XRT0)
SET XRTN=$TEXT(+0)
if $DATA(XRT0)
DO T1^%ZOSV
+10 ;
LETTER ;letter denoting change of status or disposition
+1 ;print letter/update fields if letter prints
NEW FBLETDT
IF FBLET
IF "^1^4^"'[(U_$PIECE(FBUCA,U,11)_U)
DO AUTO^FBUCLET(FBDA,FBORDER,FBUCA,FBUC)
END ;kill variables and quit
+1 KILL FBAUTH,FBLOCK,FBUCAA,FBUCP,FBUCPA,XRT0,XRTN,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
QUIT
