- 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 Apr 23, 2025@18:14:57 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
