- FBUCMEA ;WOIFO/SAB-UNAUTHORIZED CLAIM MAIN MENU ENTRY ACTION ;12/17/2001
- ;;3.5;FEE BASIS;**38**;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- N DFN,DIR,FBDA,FBDT,FBEXP,FBFR,FBO,FBOUT,FBPG,FBTO,FBVET,FBX,FBY
- ;
- ; gather data
- N VADM,X,Y
- K ^TMP("FBEX",$J)
- S FBTO=$$FMADD^XLFDT(DT,6)
- F FBO=10,55 D
- . S FBDT=-(FBTO+.1)
- . F S FBDT=$O(^FB583("AES",FBO,FBDT)) Q:FBDT']"" D
- . . S FBDA=0 F S FBDA=$O(^FB583("AES",FBO,FBDT,FBDA)) Q:'FBDA D
- . . . S FBY=$G(^FB583(FBDA,0))
- . . . S FBEXP=$P(FBY,U,26)
- . . . S FBVET=$$VET^FBUCUTL($P(FBY,U,4))
- . . . S ^TMP("FBEX",$J,FBEXP,FBVET_";"_$P(FBY,U,4),FBDA)=""
- ;
- ; display resutls
- I $D(^TMP("FBEX",$J)) D
- . S FBPG=0,FBOUT=0 D HD
- . S FBEXP="" F S FBEXP=$O(^TMP("FBEX",$J,FBEXP)) Q:FBEXP="" D Q:FBOUT
- . . S FBX="" F S FBX=$O(^TMP("FBEX",$J,FBEXP,FBX)) Q:FBX="" D Q:FBOUT
- . . . S FBDA=0
- . . . F S FBDA=$O(^TMP("FBEX",$J,FBEXP,FBX,FBDA)) Q:'FBDA D Q:FBOUT
- . . . . S FBY=$G(^FB583(FBDA,0))
- . . . . S DFN=$P(FBY,U,4)
- . . . . D DEM^VADPT
- . . . . I $Y+6>IOSL D HD Q:FBOUT
- . . . . W !,$E($P(FBX,";"),1,20),?22,$P(VADM(2),U,2)
- . . . . W ?36,$E($$VEN^FBUCUTL($P(FBY,U,3)),1,20)
- . . . . W ?59,$$FMTE^XLFDT(FBEXP,"2F")
- . . . . W ?69,$E($$GET1^DIQ(162.7,FBDA_",",24),1,10)
- . . . . D KVAR^VADPT
- . I 'FBOUT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S FBOUT=1 Q
- ;
- ; clean up
- K ^TMP("FBEX",$J)
- Q
- ;
- HD ; header
- I $E(IOST,1,2)="C-",FBPG S DIR(0)="E" D ^DIR K DIR I 'Y S FBOUT=1 Q
- I $E(IOST,1,2)="C-"!FBPG W @IOF S $X=0
- S FBPG=FBPG+1
- W !,?10,"Unauthorized Claims Expiring on or before "_$$FMTE^XLFDT(FBTO)
- W !,"Veteran",?22,"SSN",?36,"Vendor",?59,"Expires",?69,"Status"
- W !,"--------------------",?22,"-----------"
- W ?36,"--------------------"
- W ?59,"--------",?69,"----------"
- Q
- ;FBUCMEA
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUCMEA 1849 printed Mar 13, 2025@21:05:16 Page 2
- FBUCMEA ;WOIFO/SAB-UNAUTHORIZED CLAIM MAIN MENU ENTRY ACTION ;12/17/2001
- +1 ;;3.5;FEE BASIS;**38**;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 NEW DFN,DIR,FBDA,FBDT,FBEXP,FBFR,FBO,FBOUT,FBPG,FBTO,FBVET,FBX,FBY
- +4 ;
- +5 ; gather data
- +6 NEW VADM,X,Y
- +7 KILL ^TMP("FBEX",$JOB)
- +8 SET FBTO=$$FMADD^XLFDT(DT,6)
- +9 FOR FBO=10,55
- Begin DoDot:1
- +10 SET FBDT=-(FBTO+.1)
- +11 FOR
- SET FBDT=$ORDER(^FB583("AES",FBO,FBDT))
- if FBDT']""
- QUIT
- Begin DoDot:2
- +12 SET FBDA=0
- FOR
- SET FBDA=$ORDER(^FB583("AES",FBO,FBDT,FBDA))
- if 'FBDA
- QUIT
- Begin DoDot:3
- +13 SET FBY=$GET(^FB583(FBDA,0))
- +14 SET FBEXP=$PIECE(FBY,U,26)
- +15 SET FBVET=$$VET^FBUCUTL($PIECE(FBY,U,4))
- +16 SET ^TMP("FBEX",$JOB,FBEXP,FBVET_";"_$PIECE(FBY,U,4),FBDA)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +17 ;
- +18 ; display resutls
- +19 IF $DATA(^TMP("FBEX",$JOB))
- Begin DoDot:1
- +20 SET FBPG=0
- SET FBOUT=0
- DO HD
- +21 SET FBEXP=""
- FOR
- SET FBEXP=$ORDER(^TMP("FBEX",$JOB,FBEXP))
- if FBEXP=""
- QUIT
- Begin DoDot:2
- +22 SET FBX=""
- FOR
- SET FBX=$ORDER(^TMP("FBEX",$JOB,FBEXP,FBX))
- if FBX=""
- QUIT
- Begin DoDot:3
- +23 SET FBDA=0
- +24 FOR
- SET FBDA=$ORDER(^TMP("FBEX",$JOB,FBEXP,FBX,FBDA))
- if 'FBDA
- QUIT
- Begin DoDot:4
- +25 SET FBY=$GET(^FB583(FBDA,0))
- +26 SET DFN=$PIECE(FBY,U,4)
- +27 DO DEM^VADPT
- +28 IF $Y+6>IOSL
- DO HD
- if FBOUT
- QUIT
- +29 WRITE !,$EXTRACT($PIECE(FBX,";"),1,20),?22,$PIECE(VADM(2),U,2)
- +30 WRITE ?36,$EXTRACT($$VEN^FBUCUTL($PIECE(FBY,U,3)),1,20)
- +31 WRITE ?59,$$FMTE^XLFDT(FBEXP,"2F")
- +32 WRITE ?69,$EXTRACT($$GET1^DIQ(162.7,FBDA_",",24),1,10)
- +33 DO KVAR^VADPT
- End DoDot:4
- if FBOUT
- QUIT
- End DoDot:3
- if FBOUT
- QUIT
- End DoDot:2
- if FBOUT
- QUIT
- +34 IF 'FBOUT
- IF $EXTRACT(IOST,1,2)="C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET FBOUT=1
- QUIT
- End DoDot:1
- +35 ;
- +36 ; clean up
- +37 KILL ^TMP("FBEX",$JOB)
- +38 QUIT
- +39 ;
- HD ; header
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF FBPG
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET FBOUT=1
- QUIT
- +2 IF $EXTRACT(IOST,1,2)="C-"!FBPG
- WRITE @IOF
- SET $X=0
- +3 SET FBPG=FBPG+1
- +4 WRITE !,?10,"Unauthorized Claims Expiring on or before "_$$FMTE^XLFDT(FBTO)
- +5 WRITE !,"Veteran",?22,"SSN",?36,"Vendor",?59,"Expires",?69,"Status"
- +6 WRITE !,"--------------------",?22,"-----------"
- +7 WRITE ?36,"--------------------"
- +8 WRITE ?59,"--------",?69,"----------"
- +9 QUIT
- +10 ;FBUCMEA
