- 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 Feb 18, 2025@23:24:55 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
