FBUCEX ;ALBISC/TET - EXPIRATION UPDATE &/OR OUTPUT ;10/07/2014
;;3.5;FEE BASIS;**32,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
ABAND ;background update to abandoned if expiration date is met
;on claims with status order of 10 or 55
N FBDT,FBACT S FBACT="EDT"
S FBO=0 F S FBO=$O(^FB583("AES",FBO)) Q:'FBO I "^10^55^"[FBO S FBDT=-(DT) F S FBDT=$O(^FB583("AES",FBO,FBDT)) Q:FBDT']"" S FBDA=0 F S FBDA=$O(^FB583("AES",FBO,FBDT,FBDA)) Q:'FBDA S FBZ=$G(^FB583(FBDA,0)) I FBZ]"" D
.N FBUCA,FBUCAA,FBUCP,FBUCPA
.D PRIOR^FBUCEVT(FBDA,"EDT") S DIE="^FB583(",DA=FBDA,DR="26///^S X=""@"";10////^S X=5"
.D LOCK^FBUCUTL(DIE,DA,1) I FBLOCK D ^DIE L -^FB583(DA) K DIE,DR,DA
.D AFTER^FBUCEVT(FBDA,"EDT"),UPDATE^FBUCUPD(FBUCP,FBUCPA,FBUCA,FBUCAA,FBDA,"EDT")
.S ^TMP("FBEX",$J,$$VET^FBUCUTL($P(FBZ,U,4))_";"_$P(FBZ,U,4),FBDA)=$E($$VEN^FBUCUTL($P(FBZ,U,3)),1,20)_U_$E($P($$PTR^FBUCUTL("^FB(162.92,",$$STATUS^FBUCUTL(FBO)),U),1,16)_U_$$DATX^FBAAUTL($P(FBZ,U,5))_U_$$DATX^FBAAUTL($P(FBZ,U,6))
.K FBLOCK
G:'$D(^TMP("FBEX")) END S FBHDR="Unauthorized Claims Dispositioned to 'ABANDONED'"
PRINT ;print claims which have been dispositioned to abandoned or fall within date range to expire
U IO S FBPG=0,FBCRT=$S($E(IOST,1,2)="C-":1,1:0),FBOUT=0,$P(FBDASH,"=",80)="" D PAGE
S FBVET="" F S FBVET=$O(^TMP("FBEX",$J,FBVET)) Q:FBVET']""!(FBOUT) S FBDA=0 F S FBDA=$O(^TMP("FBEX",$J,FBVET,FBDA)) Q:'FBDA!(FBOUT) S FBNODE=$G(^TMP("FBEX",$J,FBVET,FBDA)) D Q:FBOUT
.I IOSL<($Y+5) D PAGE Q:FBOUT
.W !,$E($P(FBVET,";"),1,20),?24,$P(FBNODE,U),?48,$P(FBNODE,U,3),?60,$P(FBNODE,U,4),?72,$E($P(FBNODE,U,2),1,8)
END ;kill variables,tmp global and quit
K FBCRT,FBDA,FBDASH,FBDT,FBFR,FBHDR,FBLOCK,FBNODE,FBO,FBOUT,FBPG,FBPOP,FBTO,FBVET,FBZ,BEGDATE,DIR,DIRUT,DTOUT,DUOUT,ENDDATE,PGM,POP,VAL,VAR,^TMP("FBEX",$J),FB1725R
D CLOSE^FBAAUTL
Q
PAGE ;write new page
D:FBCRT&(FBPG>0) CR Q:FBOUT
HDR W:FBCRT!(FBPG>0) @IOF S FBPG=FBPG+1
W !,FBHDR,!!,?48,"Treatment",?60,"Treatment",!,"Veteran",?24,"Vendor",?51,"FROM",?64,"TO",?72,"Status",!,FBDASH
Q
CR ;ask end of page prompt
;OUTPUT: FBOUT is set if time out or up arrow out
W ! S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) FBOUT=1
Q
EXPIRE ;called from print option to display/print claims due to expire within date range
;claim will print if expiration date falls within date range user selected,
;status order is 10 <incomplete> or 55 <appeal/stmt of case issued>,
;and has not been abandoned (ck needed?)
; ask if report for just mill-bill (1725) or just non-mill bill claims
S FB1725R=$$ASKMB^FBUCUTL9 I FB1725R="" G END
W !?3,"Select the date range within which an unauthorized claim will expire." S %DT="AEX" D DATE^FBAAUTL K %DT G:FBPOP END
S VAR="BEGDATE^ENDDATE^FB1725R",VAL=VAR,PGM="DQ^FBUCEX" D ZIS^FBAAUTL G:FBPOP END
DQ S FBFR=BEGDATE,FBTO=ENDDATE ;scratch
S FBHDR="Unauthorized"_$S(FB1725R="M":" Mill Bill (1725)",FB1725R="N":" NON-Mill Bill",1:"")_" Claims Due to Expire between "_$$DATX^FBAAUTL(FBFR)_" and "_$$DATX^FBAAUTL(FBTO)
S FBO=0 F S FBO=$O(^FB583("AES",FBO)) Q:'FBO I "^10^55^"[FBO S FBDT=-(FBTO-.1) F S FBDT=$O(^FB583("AES",FBO,FBDT)) Q:FBDT']""!(FBDT>-FBFR) S FBDA=0 F S FBDA=$O(^FB583("AES",FBO,FBDT,FBDA)) Q:'FBDA S FBZ=$G(^FB583(FBDA,0)) I FBZ]"" D
.; if user requested just mill-bill (1725) or non-mill bill claims then
.; check claim and skip when appropriate
.Q:$S(FB1725R="M"&'+$P(FBZ,U,28):1,FB1725R="N"&+$P(FBZ,U,28):1,1:0)
.S ^TMP("FBEX",$J,$$VET^FBUCUTL($P(FBZ,U,4))_";"_$P(FBZ,U,4),FBDA)=$E($$VEN^FBUCUTL($P(FBZ,U,3)),1,20)_U_$E($P($$PTR^FBUCUTL("^FB(162.92,",$$STATUS^FBUCUTL(FBO)),U),1,16)_U_$$DATX^FBAAUTL($P(FBZ,U,5))_U_$$DATX^FBAAUTL($P(FBZ,U,6))
I '$D(^TMP("FBEX")) D G END
.S FBPG=0,$P(FBDASH,"=",80)="",FBCRT=$S($E(IOST,1,2)="C-":1,1:0)
.S FBOUT=0
.U IO
.D PAGE W !,"No claims will expire within selected date range."
G PRINT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCEX 3936 printed Sep 23, 2025@19:36:19 Page 2
FBUCEX ;ALBISC/TET - EXPIRATION UPDATE &/OR OUTPUT ;10/07/2014
+1 ;;3.5;FEE BASIS;**32,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
ABAND ;background update to abandoned if expiration date is met
+1 ;on claims with status order of 10 or 55
+2 NEW FBDT,FBACT
SET FBACT="EDT"
+3 SET FBO=0
FOR
SET FBO=$ORDER(^FB583("AES",FBO))
if 'FBO
QUIT
IF "^10^55^"[FBO
SET FBDT=-(DT)
FOR
SET FBDT=$ORDER(^FB583("AES",FBO,FBDT))
if FBDT']""
QUIT
SET FBDA=0
FOR
SET FBDA=$ORDER(^FB583("AES",FBO,FBDT,FBDA))
if 'FBDA
QUIT
SET FBZ=$GET(^FB583(FBDA,0))
IF FBZ]""
Begin DoDot:1
+4 NEW FBUCA,FBUCAA,FBUCP,FBUCPA
+5 DO PRIOR^FBUCEVT(FBDA,"EDT")
SET DIE="^FB583("
SET DA=FBDA
SET DR="26///^S X=""@"";10////^S X=5"
+6 DO LOCK^FBUCUTL(DIE,DA,1)
IF FBLOCK
DO ^DIE
LOCK -^FB583(DA)
KILL DIE,DR,DA
+7 DO AFTER^FBUCEVT(FBDA,"EDT")
DO UPDATE^FBUCUPD(FBUCP,FBUCPA,FBUCA,FBUCAA,FBDA,"EDT")
+8 SET ^TMP("FBEX",$JOB,$$VET^FBUCUTL($PIECE(FBZ,U,4))_";"_$PIECE(FBZ,U,4),FBDA)=$EXTRACT($$VEN^FBUCUTL($PIECE(FBZ,U,3)),1,20)_U_...
... $EXTRACT($PIECE($$PTR^FBUCUTL("^FB(162.92,",$$STATUS^FBUCUTL(FBO)),U),1,16)_U_$$DATX^FBAAUTL($PIECE(FBZ,U,5))_U_$$DATX^FBAAUTL($PIECE(FBZ,U,6))
+9 KILL FBLOCK
End DoDot:1
+10 if '$DATA(^TMP("FBEX"))
GOTO END
SET FBHDR="Unauthorized Claims Dispositioned to 'ABANDONED'"
PRINT ;print claims which have been dispositioned to abandoned or fall within date range to expire
+1 USE IO
SET FBPG=0
SET FBCRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
SET FBOUT=0
SET $PIECE(FBDASH,"=",80)=""
DO PAGE
+2 SET FBVET=""
FOR
SET FBVET=$ORDER(^TMP("FBEX",$JOB,FBVET))
if FBVET']""!(FBOUT)
QUIT
SET FBDA=0
FOR
SET FBDA=$ORDER(^TMP("FBEX",$JOB,FBVET,FBDA))
if 'FBDA!(FBOUT)
QUIT
SET FBNODE=$GET(^TMP("FBEX",$JOB,FBVET,FBDA))
Begin DoDot:1
+3 IF IOSL<($Y+5)
DO PAGE
if FBOUT
QUIT
+4 WRITE !,$EXTRACT($PIECE(FBVET,";"),1,20),?24,$PIECE(FBNODE,U),?48,$PIECE(FBNODE,U,3),?60,$PIECE(FBNODE,U,4),?72,$EXTRACT($PIECE(FBNODE,U,2),1,8)
End DoDot:1
if FBOUT
QUIT
END ;kill variables,tmp global and quit
+1 KILL FBCRT,FBDA,FBDASH,FBDT,FBFR,FBHDR,FBLOCK,FBNODE,FBO,FBOUT,FBPG,FBPOP,FBTO,FBVET,FBZ,BEGDATE,DIR,DIRUT,DTOUT,DUOUT,ENDDATE,PGM,POP,VAL,VAR,^TMP("FBEX",$JOB),FB1725R
+2 DO CLOSE^FBAAUTL
+3 QUIT
PAGE ;write new page
+1 if FBCRT&(FBPG>0)
DO CR
if FBOUT
QUIT
HDR if FBCRT!(FBPG>0)
WRITE @IOF
SET FBPG=FBPG+1
+1 WRITE !,FBHDR,!!,?48,"Treatment",?60,"Treatment",!,"Veteran",?24,"Vendor",?51,"FROM",?64,"TO",?72,"Status",!,FBDASH
+2 QUIT
CR ;ask end of page prompt
+1 ;OUTPUT: FBOUT is set if time out or up arrow out
+2 WRITE !
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET FBOUT=1
+3 QUIT
EXPIRE ;called from print option to display/print claims due to expire within date range
+1 ;claim will print if expiration date falls within date range user selected,
+2 ;status order is 10 <incomplete> or 55 <appeal/stmt of case issued>,
+3 ;and has not been abandoned (ck needed?)
+4 ; ask if report for just mill-bill (1725) or just non-mill bill claims
+5 SET FB1725R=$$ASKMB^FBUCUTL9
IF FB1725R=""
GOTO END
+6 WRITE !?3,"Select the date range within which an unauthorized claim will expire."
SET %DT="AEX"
DO DATE^FBAAUTL
KILL %DT
if FBPOP
GOTO END
+7 SET VAR="BEGDATE^ENDDATE^FB1725R"
SET VAL=VAR
SET PGM="DQ^FBUCEX"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
DQ ;scratch
SET FBFR=BEGDATE
SET FBTO=ENDDATE
+1 SET FBHDR="Unauthorized"_$SELECT(FB1725R="M":" Mill Bill (1725)",FB1725R="N":" NON-Mill Bill",1:"")_" Claims Due to Expire between "_$$DATX^FBAAUTL(FBFR)_" and "_$$DATX^FBAAUTL(FBTO)
+2 SET FBO=0
FOR
SET FBO=$ORDER(^FB583("AES",FBO))
if 'FBO
QUIT
IF "^10^55^"[FBO
SET FBDT=-(FBTO-.1)
FOR
SET FBDT=$ORDER(^FB583("AES",FBO,FBDT))
if FBDT']""!(FBDT>-FBFR)
QUIT
SET FBDA=0
FOR
SET FBDA=$ORDER(^FB583("AES",FBO,FBDT,FBDA))
if 'FBDA
QUIT
SET FBZ=$GET(^FB583(FBDA,0))
IF FBZ]""
Begin DoDot:1
+3 ; if user requested just mill-bill (1725) or non-mill bill claims then
+4 ; check claim and skip when appropriate
+5 if $SELECT(FB1725R="M"&'+$PIECE(FBZ,U,28)
QUIT
+6 SET ^TMP("FBEX",$JOB,$$VET^FBUCUTL($PIECE(FBZ,U,4))_";"_$PIECE(FBZ,U,4),FBDA)=$EXTRACT($$VEN^FBUCUTL($PIECE(FBZ,U,3)),1,20)_U_...
... $EXTRACT($PIECE($$PTR^FBUCUTL("^FB(162.92,",$$STATUS^FBUCUTL(FBO)),U),1,16)_U_$$DATX^FBAAUTL($PIECE(FBZ,U,5))_U_$$DATX^FBAAUTL($PIECE(FBZ,U,6))
End DoDot:1
+7 IF '$DATA(^TMP("FBEX"))
Begin DoDot:1
+8 SET FBPG=0
SET $PIECE(FBDASH,"=",80)=""
SET FBCRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
+9 SET FBOUT=0
+10 USE IO
+11 DO PAGE
WRITE !,"No claims will expire within selected date range."
End DoDot:1
GOTO END
+12 GOTO PRINT
+13 QUIT
