FBUCEX.m

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 ---FBUCEX   3936     printed  Mar 13, 2025@21:05:08                                                                                                                                                                                                      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