FBFPDS ;WCIOFO/SAB-REPORT OF VENDORS WITHOUT FPDS DATA ;9/15/97
;;3.5;FEE BASIS;**9**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
EN ; entry point
;
S DIR(0)="Y",DIR("A")="Only check FPDS data for active vendors"
S DIR("B")="YES"
S DIR("?",1)="Enter YES if only active vendors should be checked for"
S DIR("?",2)="missing FPDS data. A vendor is considered active if there"
S DIR("?",3)="has been a treatment/invoice after a user-specified date."
S DIR("?",4)=" "
S DIR("?")="Enter either 'Y' or 'N'."
D ^DIR K DIR G:$D(DIRUT) EXIT S FBACT=Y
I FBACT D G:$D(DIRUT) EXIT
. S DIR(0)="D",DIR("A")="Consider vendor active when activity since"
. S DIR("B")=$$FMTE^XLFDT($E($$FMADD^XLFDT(DT,-540),1,5)_"01")
. D ^DIR K DIR Q:$D(DIRUT) S FBACT("D")=Y
;
S DIR(0)="Y",DIR("A")="Print detailed vendor demographic data"
S DIR("B")="NO"
D ^DIR K DIR G:$D(DIRUT) EXIT S FBVD=Y
;
S VAR="FBACT^FBACT(^FBVD",PGM="QEN^FBFPDS" D ZIS^FBAAUTL G:FBPOP EXIT
;
QEN ; queued entry point
U IO
S FBOUT=0
; gather/sort data
K ^TMP($J)
S (FBIEN,FBT)=0 F S FBIEN=$O(^FBAAV(FBIEN)) Q:'FBIEN D Q:FBOUT
. S FBT=FBT+1
. I '(FBT#100) W:$E(IOST,1,2)="C-" "." I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,FBOUT=1 Q
. S FBBT=$P($G(^FBAAV(FBIEN,1)),U,10)
. I FBBT]"" Q ; FPDS Data exists *** groups? $O(^FBAAV(FBIEN,2,0))
. ; processing vendors with blank FPDS data
. Q:$P($G(^FBAAV(FBIEN,"ADEL")),U)="Y" ; Austin Deleted: Don't report.
. I FBACT D Q:'FBVENACT ; if user just asked for active vendors
. . S FBVENACT=0 ; init vendor active flag
. . ; is vendor active in Outpatient Medical
. . S FBX=$O(^FBAAC("AX",FBIEN,0))
. . S FBX("D")=$S(FBX:9999999.9999-FBX,1:"") ; treatment date
. . I FBX("D")'<FBACT("D") S FBVENACT=1 Q ; active medical vendor
. . ; or is vendor active in Pharmacy
. . S FBI=$O(^FBAA(162.1,"AN",FBIEN," "),-1) ; highest ien for vendor
. . S FBX("D")=$S(FBI:$P($G(^FBAA(162.1,FBI,0)),U,2),1:"") ;invoice date
. . I FBX("D")'<FBACT("D") S FBVENACT=1 Q ; active pharmacy vendor
. . ; or is vendor active in Inpatient
. . S FBX=$O(^FBAAI("AF",FBIEN,0))
. . S FBX("D")=$S(FBX:9999999.9999-FBX,1:"") ; invoice date
. . I FBX("D")'<FBACT("D") S FBVENACT=1 Q ; active inpatient vendor
. ; save vendor in list
. S FBNAME=$P($G(^FBAAV(FBIEN,0)),U) S:FBNAME="" FBNAME="UNKNOWN"
. S ^TMP($J,FBNAME,FBIEN)=""
;
; print data
S $P(FBDASH,"=",80)="",$P(FBDASH1,"-",80)="",FBPG=0
S FBDTR=$$FMTE^XLFDT($$NOW^XLFDT())
D HD
S FBT=0
S FBNAME="" F S FBNAME=$O(^TMP($J,FBNAME)) Q:FBNAME="" D Q:FBOUT
. S FBIEN=0 F S FBIEN=$O(^TMP($J,FBNAME,FBIEN)) Q:'FBIEN D Q:FBOUT
. . S FBT=FBT+1
. . S FBY(0)=$G(^FBAAV(FBIEN,0))
. . S FBNAME=$S($P(FBY(0),U)]"":$P(FBY(0),U),1:"UNKNOWN")
. . S FBID=$S($P(FBY(0),U,2)]"":$P(FBY(0),U,2),1:"UNKNOWN")
. . I 'FBVD D:$Y+6>IOSL HD Q:FBOUT W !,FBNAME,?50,"ID: ",FBID Q
. . ;
. . I $Y+17>IOSL D HD Q:FBOUT
. . F FBX=1,"ADEL","AMS" S FBY(FBX)=$G(^FBAAV(FBIEN,FBX))
. . W !!,$J("Name:",13),?15,$E(FBNAME,1,30),?48,"ID Number: ",FBID
. . I $P(FBY("ADEL"),U)="Y" W !?19,"==> FLAGGED FOR DELETION <=="
. . E I $$CKVEN^FBAADV(FBIEN) W !?20,"==> AWAITING AUSTIN APPROVAL <=="
. . W !,$J("Address:",13),?15,$P(FBY(0),U,3)
. . W ?48,"Specialty: ",$E($$GET1^DIQ(161.2,FBIEN,.05),1,20)
. . I $P(FBY(0),U,14)]"" W !,$J("Address [2]:",13),?15,$P(FBY(0),U,14)
. . W !,$J("City:",13),?15,$P(FBY(0),U,4)
. . W ?53,"Type:",?59,$$EXTERNAL^DILFD(161.2,6,"",$P(FBY(0),U,7))
. . W !,$J("State:",13),?15,$$GET1^DIQ(161.2,FBIEN,4)
. . S FBX=$$GET1^DIQ(161.2,FBIEN,7)
. . W ?39,"Participation Code:",?59,$S(FBX]"":$E(FBX,1,21),1:"UNKNOWN")
. . W !,$J("ZIP:",13),?15,$P(FBY(0),U,6)
. . W ?39,"Medicare ID Number:",?59,$P(FBY(0),U,17)
. . W !,$J("County:",13),?15,$$GET1^DIQ(161.2,FBIEN,5.5)
. . W ?52,"Chain: ",$P(FBY(0),U,10)
. . W !,$J("Phone:",13),?15,$P(FBY(1),U)
. . W !,$J("Fax:",13),?15,$P(FBY(1),U,9)
. . W:$P(FBY("AMS"),U,2)="Y" ?44,"Pricer Exempt: Yes"
. . W !,$J("Type (FPDS):",13)
. . W ?15,$$EXTERNAL^DILFD(161.2,24,"",$P(FBY(1),U,10))
. . S (FBC,FBI)=0 F S FBI=$O(^FBAAV(FBIEN,2,FBI)) Q:'FBI D
. . . S FBX=$P($G(^FBAAV(FBIEN,2,FBI,0)),U) Q:'FBX
. . . S FBX=$$GET1^DIQ(420.6,FBX,1) Q:FBX=""
. . . S FBC=FBC+1
. . . I '(FBC#2) W !,$J("Group (FPDS):",13),?15,$E(FBX,1,21)
. . . I (FBC#2) W ?45,"Group (FPDS):",?59,$E(FBX,1,21)
. . W !,$J("Austin Name:",13),?15,$P(FBY("AMS"),U)
. . W !,$J("Last Change ",13),?44,"Last Change"
. . I $P(FBY("ADEL"),U,5)]"" W " by ",$S($P(FBY("ADEL"),U,5)="000":"Non-Fee User",1:"Station "_$P(FBY("ADEL"),U,5))
. . W !,$J("TO Austin:",13),?15,$$DATX^FBAAUTL($P(FBY("ADEL"),U,2))
. . W ?46,"FROM Austin: ",$$DATX^FBAAUTL($P(FBY("ADEL"),U,4))
;
I FBOUT W !!,"JOB STOPPED AT USER REQUEST"
I 'FBOUT W !!,"TOTAL number of vendors missing FPDS data: ",FBT
I 'FBOUT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
D ^%ZISC
;
EXIT ;
I $D(ZTQUEUED) S ZTREQ="@"
K ^TMP($J),DIROUT,DIRUT,DTOUT,DUOUT,X,Y
K FBDASH,FBDASH1,FBDTR,FBPG,FBOUT,FBPOP
K FBACT,FBBT,FBC,FBI,FBID,FBIEN,FBNAME,FBT,FBVD,FBVENACT,FBX,FBY
Q
;
HD ; header
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,FBOUT=1 Q
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 FBPG=FBPG+1
W !,"FEE BASIS VENDOR'S WITH BLANK FPDS DATA",?49,FBDTR,?72,"page ",FBPG
I $G(FBACT) W !,"of those with activity since ",$$FMTE^XLFDT(FBACT("D"))
W !,FBDASH
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBFPDS 5529 printed Dec 13, 2024@01:58:29 Page 2
FBFPDS ;WCIOFO/SAB-REPORT OF VENDORS WITHOUT FPDS DATA ;9/15/97
+1 ;;3.5;FEE BASIS;**9**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
EN ; entry point
+1 ;
+2 SET DIR(0)="Y"
SET DIR("A")="Only check FPDS data for active vendors"
+3 SET DIR("B")="YES"
+4 SET DIR("?",1)="Enter YES if only active vendors should be checked for"
+5 SET DIR("?",2)="missing FPDS data. A vendor is considered active if there"
+6 SET DIR("?",3)="has been a treatment/invoice after a user-specified date."
+7 SET DIR("?",4)=" "
+8 SET DIR("?")="Enter either 'Y' or 'N'."
+9 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET FBACT=Y
+10 IF FBACT
Begin DoDot:1
+11 SET DIR(0)="D"
SET DIR("A")="Consider vendor active when activity since"
+12 SET DIR("B")=$$FMTE^XLFDT($EXTRACT($$FMADD^XLFDT(DT,-540),1,5)_"01")
+13 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET FBACT("D")=Y
End DoDot:1
if $DATA(DIRUT)
GOTO EXIT
+14 ;
+15 SET DIR(0)="Y"
SET DIR("A")="Print detailed vendor demographic data"
+16 SET DIR("B")="NO"
+17 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET FBVD=Y
+18 ;
+19 SET VAR="FBACT^FBACT(^FBVD"
SET PGM="QEN^FBFPDS"
DO ZIS^FBAAUTL
if FBPOP
GOTO EXIT
+20 ;
QEN ; queued entry point
+1 USE IO
+2 SET FBOUT=0
+3 ; gather/sort data
+4 KILL ^TMP($JOB)
+5 SET (FBIEN,FBT)=0
FOR
SET FBIEN=$ORDER(^FBAAV(FBIEN))
if 'FBIEN
QUIT
Begin DoDot:1
+6 SET FBT=FBT+1
+7 IF '(FBT#100)
if $EXTRACT(IOST,1,2)="C-"
WRITE "."
IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET FBOUT=1
QUIT
+8 SET FBBT=$PIECE($GET(^FBAAV(FBIEN,1)),U,10)
+9 ; FPDS Data exists *** groups? $O(^FBAAV(FBIEN,2,0))
IF FBBT]""
QUIT
+10 ; processing vendors with blank FPDS data
+11 ; Austin Deleted: Don't report.
if $PIECE($GET(^FBAAV(FBIEN,"ADEL")),U)="Y"
QUIT
+12 ; if user just asked for active vendors
IF FBACT
Begin DoDot:2
+13 ; init vendor active flag
SET FBVENACT=0
+14 ; is vendor active in Outpatient Medical
+15 SET FBX=$ORDER(^FBAAC("AX",FBIEN,0))
+16 ; treatment date
SET FBX("D")=$SELECT(FBX:9999999.9999-FBX,1:"")
+17 ; active medical vendor
IF FBX("D")'<FBACT("D")
SET FBVENACT=1
QUIT
+18 ; or is vendor active in Pharmacy
+19 ; highest ien for vendor
SET FBI=$ORDER(^FBAA(162.1,"AN",FBIEN," "),-1)
+20 ;invoice date
SET FBX("D")=$SELECT(FBI:$PIECE($GET(^FBAA(162.1,FBI,0)),U,2),1:"")
+21 ; active pharmacy vendor
IF FBX("D")'<FBACT("D")
SET FBVENACT=1
QUIT
+22 ; or is vendor active in Inpatient
+23 SET FBX=$ORDER(^FBAAI("AF",FBIEN,0))
+24 ; invoice date
SET FBX("D")=$SELECT(FBX:9999999.9999-FBX,1:"")
+25 ; active inpatient vendor
IF FBX("D")'<FBACT("D")
SET FBVENACT=1
QUIT
End DoDot:2
if 'FBVENACT
QUIT
+26 ; save vendor in list
+27 SET FBNAME=$PIECE($GET(^FBAAV(FBIEN,0)),U)
if FBNAME=""
SET FBNAME="UNKNOWN"
+28 SET ^TMP($JOB,FBNAME,FBIEN)=""
End DoDot:1
if FBOUT
QUIT
+29 ;
+30 ; print data
+31 SET $PIECE(FBDASH,"=",80)=""
SET $PIECE(FBDASH1,"-",80)=""
SET FBPG=0
+32 SET FBDTR=$$FMTE^XLFDT($$NOW^XLFDT())
+33 DO HD
+34 SET FBT=0
+35 SET FBNAME=""
FOR
SET FBNAME=$ORDER(^TMP($JOB,FBNAME))
if FBNAME=""
QUIT
Begin DoDot:1
+36 SET FBIEN=0
FOR
SET FBIEN=$ORDER(^TMP($JOB,FBNAME,FBIEN))
if 'FBIEN
QUIT
Begin DoDot:2
+37 SET FBT=FBT+1
+38 SET FBY(0)=$GET(^FBAAV(FBIEN,0))
+39 SET FBNAME=$SELECT($PIECE(FBY(0),U)]"":$PIECE(FBY(0),U),1:"UNKNOWN")
+40 SET FBID=$SELECT($PIECE(FBY(0),U,2)]"":$PIECE(FBY(0),U,2),1:"UNKNOWN")
+41 IF 'FBVD
if $Y+6>IOSL
DO HD
if FBOUT
QUIT
WRITE !,FBNAME,?50,"ID: ",FBID
QUIT
+42 ;
+43 IF $Y+17>IOSL
DO HD
if FBOUT
QUIT
+44 FOR FBX=1,"ADEL","AMS"
SET FBY(FBX)=$GET(^FBAAV(FBIEN,FBX))
+45 WRITE !!,$JUSTIFY("Name:",13),?15,$EXTRACT(FBNAME,1,30),?48,"ID Number: ",FBID
+46 IF $PIECE(FBY("ADEL"),U)="Y"
WRITE !?19,"==> FLAGGED FOR DELETION <=="
+47 IF '$TEST
IF $$CKVEN^FBAADV(FBIEN)
WRITE !?20,"==> AWAITING AUSTIN APPROVAL <=="
+48 WRITE !,$JUSTIFY("Address:",13),?15,$PIECE(FBY(0),U,3)
+49 WRITE ?48,"Specialty: ",$EXTRACT($$GET1^DIQ(161.2,FBIEN,.05),1,20)
+50 IF $PIECE(FBY(0),U,14)]""
WRITE !,$JUSTIFY("Address [2]:",13),?15,$PIECE(FBY(0),U,14)
+51 WRITE !,$JUSTIFY("City:",13),?15,$PIECE(FBY(0),U,4)
+52 WRITE ?53,"Type:",?59,$$EXTERNAL^DILFD(161.2,6,"",$PIECE(FBY(0),U,7))
+53 WRITE !,$JUSTIFY("State:",13),?15,$$GET1^DIQ(161.2,FBIEN,4)
+54 SET FBX=$$GET1^DIQ(161.2,FBIEN,7)
+55 WRITE ?39,"Participation Code:",?59,$SELECT(FBX]"":$EXTRACT(FBX,1,21),1:"UNKNOWN")
+56 WRITE !,$JUSTIFY("ZIP:",13),?15,$PIECE(FBY(0),U,6)
+57 WRITE ?39,"Medicare ID Number:",?59,$PIECE(FBY(0),U,17)
+58 WRITE !,$JUSTIFY("County:",13),?15,$$GET1^DIQ(161.2,FBIEN,5.5)
+59 WRITE ?52,"Chain: ",$PIECE(FBY(0),U,10)
+60 WRITE !,$JUSTIFY("Phone:",13),?15,$PIECE(FBY(1),U)
+61 WRITE !,$JUSTIFY("Fax:",13),?15,$PIECE(FBY(1),U,9)
+62 if $PIECE(FBY("AMS"),U,2)="Y"
WRITE ?44,"Pricer Exempt: Yes"
+63 WRITE !,$JUSTIFY("Type (FPDS):",13)
+64 WRITE ?15,$$EXTERNAL^DILFD(161.2,24,"",$PIECE(FBY(1),U,10))
+65 SET (FBC,FBI)=0
FOR
SET FBI=$ORDER(^FBAAV(FBIEN,2,FBI))
if 'FBI
QUIT
Begin DoDot:3
+66 SET FBX=$PIECE($GET(^FBAAV(FBIEN,2,FBI,0)),U)
if 'FBX
QUIT
+67 SET FBX=$$GET1^DIQ(420.6,FBX,1)
if FBX=""
QUIT
+68 SET FBC=FBC+1
+69 IF '(FBC#2)
WRITE !,$JUSTIFY("Group (FPDS):",13),?15,$EXTRACT(FBX,1,21)
+70 IF (FBC#2)
WRITE ?45,"Group (FPDS):",?59,$EXTRACT(FBX,1,21)
End DoDot:3
+71 WRITE !,$JUSTIFY("Austin Name:",13),?15,$PIECE(FBY("AMS"),U)
+72 WRITE !,$JUSTIFY("Last Change ",13),?44,"Last Change"
+73 IF $PIECE(FBY("ADEL"),U,5)]""
WRITE " by ",$SELECT($PIECE(FBY("ADEL"),U,5)="000":"Non-Fee User",1:"Station "_$PIECE(FBY("ADEL"),U,5))
+74 WRITE !,$JUSTIFY("TO Austin:",13),?15,$$DATX^FBAAUTL($PIECE(FBY("ADEL"),U,2))
+75 WRITE ?46,"FROM Austin: ",$$DATX^FBAAUTL($PIECE(FBY("ADEL"),U,4))
End DoDot:2
if FBOUT
QUIT
End DoDot:1
if FBOUT
QUIT
+76 ;
+77 IF FBOUT
WRITE !!,"JOB STOPPED AT USER REQUEST"
+78 IF 'FBOUT
WRITE !!,"TOTAL number of vendors missing FPDS data: ",FBT
+79 IF 'FBOUT
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+80 DO ^%ZISC
+81 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL ^TMP($JOB),DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 KILL FBDASH,FBDASH1,FBDTR,FBPG,FBOUT,FBPOP
+4 KILL FBACT,FBBT,FBC,FBI,FBID,FBIEN,FBNAME,FBT,FBVD,FBVENACT,FBX,FBY
+5 QUIT
+6 ;
HD ; header
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET FBOUT=1
QUIT
+2 IF $EXTRACT(IOST,1,2)="C-"
IF FBPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBOUT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"!FBPG
WRITE @IOF
+4 SET FBPG=FBPG+1
+5 WRITE !,"FEE BASIS VENDOR'S WITH BLANK FPDS DATA",?49,FBDTR,?72,"page ",FBPG
+6 IF $GET(FBACT)
WRITE !,"of those with activity since ",$$FMTE^XLFDT(FBACT("D"))
+7 WRITE !,FBDASH
+8 QUIT
