XUSNPIE2 ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ; Dec 16, 2021@08:24:28
;;8.0;KERNEL;**410,435,454,462,480,519,752,764**;Jul 10, 1995;Build 1
;;Per VHA Directive 2004-038, this routine should not be modified
Q
;
PRINTOPT ;
N DIR,%ZIS,ION,OPTION,PRNTFRMT,XUSDIV,XUSSORT,XUSRESO,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,XUSER
K IO("Q")
W !,"Select one of the following:",!!,?11,"1",?21,"All providers",!,?11,"2",?21,"All providers without NPI numbers",!
S DIR(0)="N^1:2",DIR("A")="Select a report option",DIR("B")="1" D ^DIR K DIR Q:Y'>0 S OPTION=+Y
S XUSRESO="" D Q:XUSRESO=""
. S DIR(0)="S^P:Providers who are not residents;R:Residents only;B:Both"
. S DIR("B")="P",DIR("A")="Selection: "
. D ^DIR K DIR Q:"PRB"'[Y
. S XUSRESO=Y Q
; Change of XU*8*519 #1 (add 3 lines of code below)
W !!,"Select one of the following:",!!,?11,"1",?21,"ACTIVE users only",!,?11,"2",?21,"ACTIVE and DISUSERed users",!
S DIR(0)="N^1:2",DIR("A")="Select a report option",DIR("B")="1" D ^DIR K DIR Q:Y'>0 S XUSER=+Y
; End XU*8*519 #1
;
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Sort by DIVISION" D ^DIR K DIR Q:Y="^" S XUSDIV=+Y
S PRNTFRMT=1
I XUSDIV S DIR(0)="N^1:2",DIR("A")="Output type (1=Printed text or 2=^-delimited)" D ^DIR K DIR Q:Y'>0 S PRNTFRMT=Y
S DIR(0)="Y",DIR("B")="YES",DIR("A")="Sort by SERVICE/SECTION"_$S(XUSDIV>0:" (as well)",1:"") D ^DIR K DIR Q:Y="^" S XUSSORT=+Y
W !!,">>> Report processing time is approximately 10 minutes."
W !," Recommend text output be queued to a network printer."
W !
S %ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTSAVE("OPTION")="",ZTSAVE("XUSSORT")="",ZTSAVE("XUSDIV")="",ZTSAVE("PRNTFRMT")="",ZTSAVE("XUSRESO")="",ZTSAVE("XUSER")=""
. S ZTIO=ION,ZTRTN="DQ^XUSNPIE2",ZTDESC="NPI PRINT JOB FOR OPTION "_OPTION
. D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS Q
;
DQ ; entry point for queued print job
U IO D PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO,XUSER)
U IO D ^%ZISC
Q
;
PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO,XUSER) ;
; PRINT PROVIDER INFO
;
; OPTION SPECIFIES TYPE OF PRINT - 1=ALL PROVIDERS, 2=NEEDS NPI ONLY
; XUSSORT INDICATES WHETHER SORTED BY SERVICE/SECTION
; XUSDIV INDICATES WHETHER SORTED BY DIVISION
; PRNTFRMT INDICATES TYPE OF OUTPUT, PRINTED OR ^-DELIMITED
;
; ZEXCEPT: IOSL - KERNEL VARIABLE
S XUSER=$G(XUSER) ;add p 519
N PAGENUM,LINENUM,PROVNAME,TAXDESCR,TAXONOMY,SERVSECT,DIRUT,DTOUT
N GLOBLOC,IEN,NPI,DATETIME,GLOBVALU,NCOUNT,GLOBLOC1,XUSDIVNM,CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE,MULTDIV,MULTDIVC,XUSDIS
S CNTTOTAL=0,CNTNONE=0,CNTEXMPT=0,CNTDONE=0,XUSDIS=""
S PAGENUM=0,LINENUM=0
S DATETIME=$$NOW^XLFDT()
S XUSNPIBA="XUSNPIPRNT"
S GLOBLOC1=$$GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO,XUSER)
I PRNTFRMT'=1 W !,"PROVIDER_NAME^LAST4^IEN^NPI^TAXONOMY_CODE^TAXONOMY DESCRIPTION"_$S(XUSDIV:"^DIVISION",1:"")_$S(XUSSORT:"^SERVICE/SECTION",1:"")
S GLOBLOC=GLOBLOC1,XUSDIVNM="" F S XUSDIVNM=$O(@GLOBLOC1@(XUSDIVNM)) Q:XUSDIVNM="" D Q:$D(DIRUT)!$D(DTOUT)
. S SERVSECT="" F S SERVSECT=$O(@GLOBLOC1@(XUSDIVNM,SERVSECT)) Q:SERVSECT="" S GLOBLOC=$NA(@GLOBLOC1@(XUSDIVNM,SERVSECT)) D Q:$D(DIRUT)!$D(DTOUT)
. . I PRNTFRMT=1 D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO,XUSER) Q:$D(DIRUT)!$D(DTOUT)
. . S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" Q:$D(DIRUT)!$D(DTOUT) S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D Q:$D(DIRUT)!$D(DTOUT)
. . . S NCOUNT=0
. . . S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S GLOBVALU=@GLOBLOC@(PROVNAME,IEN,TAXDESCR) D
. . . . S NPI=$P(GLOBVALU,U,3),TAXONOMY=$P(GLOBVALU,U,4),XUSDIS=$P(GLOBVALU,U,6)
. . . . I PRNTFRMT=1 S NCOUNT=NCOUNT+1 W:NCOUNT=1 !,PROVNAME,?33,$$ALIGNRGT(IEN,11),?49,NPI,?65,XUSDIS W !,?6,TAXONOMY," ",TAXDESCR
. . . . I PRNTFRMT'=1 W !,PROVNAME_U_$E($$GET1^DIQ(200,IEN_",",9),6,9)_U_IEN_U_NPI_U_TAXONOMY_U_TAXDESCR_$S(XUSDIV:U_XUSDIVNM,1:"")_$S(XUSSORT:U_SERVSECT,1:"")
. . . . Q
. . . I PRNTFRMT=1 S LINENUM=LINENUM+NCOUNT+1 I LINENUM>(IOSL-4) D HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO,XUSER) Q:$D(DIRUT)!$D(DTOUT)
. . . Q
. . Q
. Q
I '($D(DIRUT)!$D(DTOUT)),PRNTFRMT=1 D
. S PROVNAME="" I $O(@GLOBLOC@(PROVNAME))="" W !,?20,"* * * N O D A T A F O U N D * * *",!! I 1
. E D
. . N TOTTYP S TOTTYP=$S(XUSRESO="R":"Residents",1:"Billable Providers")
. . W !!,"Total "_TOTTYP_":",?43,CNTTOTAL,!,TOTTYP_" with an NPI:",?43,CNTDONE,!,"EXEMPT "_TOTTYP_":",?43,CNTEXMPT,!,TOTTYP_" Still Needing an NPI:",?43,CNTNONE
. . I $G(MULTDIV)>0 W !!,MULTDIV," Providers were repeated a total of ",MULTDIVC," times",!," due to listing under multiple divisions"
. . Q
. W !!,?27,"*** End of Report ***"
. Q
Q
;
; ZEXCEPT: IOF,IOST KERNEL IO VARIABLES
; ZEXCEPT: DIRUT,DTOUT NEWED IN CALLING PRNTPROV - INDICATE QUIT TO PRNTPROV
N TEMPVAL,DIR,X,Y
S PAGNOREF=PAGNOREF+1
S XUSER=$G(XUSER) ; add p 519
; Don't page feed on the first page
IF PAGNOREF>1 I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR I 'Y S DIRUT=1 Q
IF PAGNOREF>1 W @IOF
W:$E(IOST,1,2)'="C-" !
W "Active Provider Report ("_$S(XUSRESO="P":"no residents)",XUSRESO="R":"residents only)",1:"includes residents)")
W ?48,$$FMTE^XLFDT(DATETIME)," Page: ",PAGNOREF
W !,"Report Option: Provider List Active ",$S(XUSER=2:"and Disuser ",1:""),"Providers",$S(OPTION=2:" Without NPI Numbers",1:"")
W !!,"Provider Name",?39,"IEN",?49,$S(OPTION'=2:"NPI",1:""),?65,$S(XUSER=2:"Disuser",1:"")
W !," Taxonomy"
W !,"--------------------------------------------------------------------------------"
S LINNOREF=6
I XUSDIV W !,"DIVISION: ",XUSDIVNM," " S LINNOREF=LINNOREF+1
I XUSSORT W:'XUSDIV ! W "SERVICE/SECTION: ",SERVSECT S:'XUSDIV LINNOREF=LINNOREF+1
Q
;
GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO,XUSER) ; get data for reports for providers
N NPI,PROVNAME,TAXDESCR,TAXONOMY,XUSDEFLT,XUSDIVCN,XUSDIVN,XUSDIVNM,XUSGLOB,XUSACTV,XUSSKIP
N XUSIEN,XUSSERVC,XUSVAL,CNTCLEAN,X,XUSDIS
S XUSRESO=$G(XUSRESO)
S XUSER=$G(XUSER) I XUSER="" S XUSER=1 ;add p 519 - active users only reported
S XUSDIS="" ; p 519
; ZEXCEPT: CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - NEWed and initialized in PRNTPROV or killed based on CNTCLEAN
S CNTCLEAN=0 I '$D(CNTTOTAL) S CNTCLEAN=1
S XUSGLOB=$NA(^TMP($J,"XUSNPIPRNT")) K @XUSGLOB
I 'XUSDIV S XUSDIVNM(1)=" ",XUSDEFLT=" "
I XUSDIV S XUSDEFLT=$$NS^XUAF4($$KSP^XUPARAM("INST")),XUSDEFLT=$P(XUSDEFLT,U)
I 'XUSSORT S XUSSERVC=" "
N XUS1,XUS2
F XUSIEN=0:0 S XUSIEN=$O(^VA(200,XUSIEN)) Q:(XUSIEN'>0)!(XUSIEN'=+XUSIEN) D
. ; Don't report TERMINATED
. S XUSACTV=$$ACTIVE^XUSER(XUSIEN)
. I XUSACTV=""!($P(XUSACTV,U,2)="TERMINATED") Q ;p 519
. I XUSER=1,$P(XUSACTV,U)=0 Q ;p 519
. S XUSDIS="" I $P(XUSACTV,U,2)="DISUSER" S XUSDIS="Yes" ;p 519
. ; Don't report users with null NPI ENTRY STATUS
. S XUSVAL=$$CHEKNPI^XUSNPIED(XUSIEN),XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN)
. I $$GETNPI^XUSNPIED(XUSIEN)>0 S $P(^VA(200,XUSIEN,"NPI"),"^",2)="D",XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN) ; p764
. Q:XUSVAL=""
. S PROVNAME=$$GET1^DIQ(200,XUSIEN_",",.01),NPI=$$GETNPI^XUSNPIED(XUSIEN),TAXONOMY=$$GETTAXON^XUSNPIED(XUSIEN,.TAXDESCR) I TAXONOMY=-1 S TAXONOMY=" ",TAXDESCR=" "
. ; Determine whether provider is a resident for local reports.
. I OPTION'=3,XUSRESO'="B" S XUSSKIP=0 D Q:XUSSKIP
. . I XUSRESO="R",TAXONOMY'="390200000X" S XUSSKIP=1 Q
. . I XUSRESO="P",TAXONOMY="390200000X" S XUSSKIP=1
. . Q
. I NPI="",$$EXMPTNPI^XUSNPIED(XUSIEN) S NPI="EXEMPTED "
. I NPI="",XUSVAL="D" S XUSVAL="N",$P(^VA(200,XUSIEN,"NPI"),"^",2)=XUSVAL ;p752 to correct the NPI ENTRY STATUS
. S CNTTOTAL=$G(CNTTOTAL)+1 S:NPI="" CNTNONE=$G(CNTNONE)+1 S:NPI="EXEMPTED " CNTEXMPT=$G(CNTEXMPT)+1 S:NPI?10N CNTDONE=$G(CNTDONE)+1
. I '((XUSVAL="N")!(OPTION'=2)) Q
. I XUSSORT S XUSSERVC=$$GET1^DIQ(200,XUSIEN_",",29) I XUSSERVC="" S XUSSERVC=" "
. I XUSDIV D
. . K XUSDIVNM S XUSDIVCN=0,XUSDIVNM(1)=XUSDEFLT
. . F XUSDIVN=0:0 S XUSDIVN=$O(^VA(200,XUSIEN,2,XUSDIVN)) Q:XUSDIVN'>0 S XUSDIVCN=XUSDIVCN+1,XUSDIVNM(XUSDIVCN)=$$GET1^DIQ(200.02,XUSDIVN_","_XUSIEN_",",.01)
. . I XUSDIVCN>1 S MULTDIV=$G(MULTDIV)+1,MULTDIVC=$G(MULTDIVC)+XUSDIVCN-1
. . Q
. F XUSDIVN=0:0 S XUSDIVN=$O(XUSDIVNM(XUSDIVN)) Q:XUSDIVN'>0 D
. . S X=PROVNAME_U_XUSIEN_U_NPI_U_TAXONOMY_U_TAXDESCR I XUSDIS="Yes" S X=X_U_XUSDIS ;p 519 add piece #6 on X
. . S @XUSGLOB@(XUSDIVNM(XUSDIVN),XUSSERVC,PROVNAME,XUSIEN,TAXDESCR)=X
. . Q
. Q
I CNTCLEAN K CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE
Q XUSGLOB
;
ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width
N RESULT
S $P(RESULT," ",WIDTH)=" ",RESULT=RESULT_TEXT,RESULT=$E(RESULT,$L(RESULT)-WIDTH+1,$L(RESULT))
Q RESULT
;
CHKOLD1(IEN) ; check for earlier value, and activate if present
N IEN1,STATUS,NPI,DATE,XUFDA
S IEN1=$O(^VA(200,IEN,"NPISTATUS"," "),-1) I IEN1>0 D I STATUS=0 D CHKOLD1(IEN)
. S STATUS=^VA(200,IEN,"NPISTATUS",IEN1,0),NPI=$P(STATUS,U,3),DATE=$P(STATUS,U),STATUS=$P(STATUS,U,2)
. I STATUS=0 D DELETNPI(IEN,IEN1,DATE) Q ; entry making it INACTIVE - remove it
. I STATUS=1 D SET^XUSNPIE1(IEN,NPI)
. Q
Q
;
DELETNPI(IEN,OIEN,ODATEVAL) ;
N XUFDA
I $D(ODATEVAL) S XUFDA(200.042,OIEN_","_IEN_",",.01)="@" D FILE^DIE("","XUFDA")
I $O(^VA(200,IEN,"NPISTATUS",0))>0 Q
N XUFDA
I $$GET1^DIQ(200,IEN_",",41.99) S XUFDA(200,IEN_",",41.99)="@"
I $$GET1^DIQ(200,IEN_",",41.98)'="" S XUFDA(200,IEN_",",41.98)="@"
I $D(XUFDA) D FILE^DIE("","XUFDA")
Q
;
CLERXMPT ; edit entry indicating whether a provider is exempt from needing an NPI
N DIC,DIR,FDA,IEN,Y
W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="select Provider: " D ^DIC Q:Y'>0 S IEN=+Y
I $$HASNPI^XUSNPIED(IEN) W !,"This Provider already has an NPI value. Nothing to do." Q
I '$$CHEKNPI^XUSNPIED(IEN),'$$EXMPTNPI^XUSNPIED(IEN) W !,"This Provider does not appear to need an NPI or Exemption." Q
I $$EXMPTNPI^XUSNPIED(IEN) D Q ; currently marked as Exempt
. S DIR(0)="Y",DIR("A")="Provider is currently EXEMPT from needing an NPI, set to NEEDS an NPI (Y/N)" D ^DIR I 'Y Q
. S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA")
. W !,$S($$NEEDSNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to NEEDS an NPI")
. Q
; check to make sure provider should be exempt
S DIR(0)="Y",DIR("A")="Confirm that Provider should be Exempt from needing an NPI (Y/N)" D ^DIR I 'Y Q
; and update file to show as exempt
S FDA(200,IEN_",",41.98)="E" D FILE^DIE("","FDA")
W !,$S($$EXMPTNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to EXEMPT")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSNPIE2 10822 printed Sep 23, 2025@19:48:55 Page 2
XUSNPIE2 ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ; Dec 16, 2021@08:24:28
+1 ;;8.0;KERNEL;**410,435,454,462,480,519,752,764**;Jul 10, 1995;Build 1
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
+4 ;
PRINTOPT ;
+1 NEW DIR,%ZIS,ION,OPTION,PRNTFRMT,XUSDIV,XUSSORT,XUSRESO,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,XUSER
+2 KILL IO("Q")
+3 WRITE !,"Select one of the following:",!!,?11,"1",?21,"All providers",!,?11,"2",?21,"All providers without NPI numbers",!
+4 SET DIR(0)="N^1:2"
SET DIR("A")="Select a report option"
SET DIR("B")="1"
DO ^DIR
KILL DIR
if Y'>0
QUIT
SET OPTION=+Y
+5 SET XUSRESO=""
Begin DoDot:1
+6 SET DIR(0)="S^P:Providers who are not residents;R:Residents only;B:Both"
+7 SET DIR("B")="P"
SET DIR("A")="Selection: "
+8 DO ^DIR
KILL DIR
if "PRB"'[Y
QUIT
+9 SET XUSRESO=Y
QUIT
End DoDot:1
if XUSRESO=""
QUIT
+10 ; Change of XU*8*519 #1 (add 3 lines of code below)
+11 WRITE !!,"Select one of the following:",!!,?11,"1",?21,"ACTIVE users only",!,?11,"2",?21,"ACTIVE and DISUSERed users",!
+12 SET DIR(0)="N^1:2"
SET DIR("A")="Select a report option"
SET DIR("B")="1"
DO ^DIR
KILL DIR
if Y'>0
QUIT
SET XUSER=+Y
+13 ; End XU*8*519 #1
+14 ;
+15 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Sort by DIVISION"
DO ^DIR
KILL DIR
if Y="^"
QUIT
SET XUSDIV=+Y
+16 SET PRNTFRMT=1
+17 IF XUSDIV
SET DIR(0)="N^1:2"
SET DIR("A")="Output type (1=Printed text or 2=^-delimited)"
DO ^DIR
KILL DIR
if Y'>0
QUIT
SET PRNTFRMT=Y
+18 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Sort by SERVICE/SECTION"_$SELECT(XUSDIV>0:" (as well)",1:"")
DO ^DIR
KILL DIR
if Y="^"
QUIT
SET XUSSORT=+Y
+19 WRITE !!,">>> Report processing time is approximately 10 minutes."
+20 WRITE !," Recommend text output be queued to a network printer."
+21 WRITE !
+22 SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+23 IF $DATA(IO("Q"))
Begin DoDot:1
+24 SET ZTSAVE("OPTION")=""
SET ZTSAVE("XUSSORT")=""
SET ZTSAVE("XUSDIV")=""
SET ZTSAVE("PRNTFRMT")=""
SET ZTSAVE("XUSRESO")=""
SET ZTSAVE("XUSER")=""
+25 SET ZTIO=ION
SET ZTRTN="DQ^XUSNPIE2"
SET ZTDESC="NPI PRINT JOB FOR OPTION "_OPTION
+26 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued as Task "_ZTSK
DO HOME^%ZIS
QUIT
End DoDot:1
QUIT
+27 ;
DQ ; entry point for queued print job
+1 USE IO
DO PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO,XUSER)
+2 USE IO
DO ^%ZISC
+3 QUIT
+4 ;
PRNTPROV(OPTION,XUSSORT,XUSDIV,PRNTFRMT,XUSRESO,XUSER) ;
+1 ; PRINT PROVIDER INFO
+2 ;
+3 ; OPTION SPECIFIES TYPE OF PRINT - 1=ALL PROVIDERS, 2=NEEDS NPI ONLY
+4 ; XUSSORT INDICATES WHETHER SORTED BY SERVICE/SECTION
+5 ; XUSDIV INDICATES WHETHER SORTED BY DIVISION
+6 ; PRNTFRMT INDICATES TYPE OF OUTPUT, PRINTED OR ^-DELIMITED
+7 ;
+8 ; ZEXCEPT: IOSL - KERNEL VARIABLE
+9 ;add p 519
SET XUSER=$GET(XUSER)
+10 NEW PAGENUM,LINENUM,PROVNAME,TAXDESCR,TAXONOMY,SERVSECT,DIRUT,DTOUT
+11 NEW GLOBLOC,IEN,NPI,DATETIME,GLOBVALU,NCOUNT,GLOBLOC1,XUSDIVNM,CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE,MULTDIV,MULTDIVC,XUSDIS
+12 SET CNTTOTAL=0
SET CNTNONE=0
SET CNTEXMPT=0
SET CNTDONE=0
SET XUSDIS=""
+13 SET PAGENUM=0
SET LINENUM=0
+14 SET DATETIME=$$NOW^XLFDT()
+15 SET XUSNPIBA="XUSNPIPRNT"
+16 SET GLOBLOC1=$$GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO,XUSER)
+17 IF PRNTFRMT'=1
WRITE !,"PROVIDER_NAME^LAST4^IEN^NPI^TAXONOMY_CODE^TAXONOMY DESCRIPTION"_$SELECT(XUSDIV:"^DIVISION",1:"")_$SELECT(XUSSORT:"^SERVICE/SECTION",1:"")
+18 SET GLOBLOC=GLOBLOC1
SET XUSDIVNM=""
FOR
SET XUSDIVNM=$ORDER(@GLOBLOC1@(XUSDIVNM))
if XUSDIVNM=""
QUIT
Begin DoDot:1
+19 SET SERVSECT=""
FOR
SET SERVSECT=$ORDER(@GLOBLOC1@(XUSDIVNM,SERVSECT))
if SERVSECT=""
QUIT
SET GLOBLOC=$NAME(@GLOBLOC1@(XUSDIVNM,SERVSECT))
Begin DoDot:2
+20 IF PRNTFRMT=1
DO HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO,XUSER)
if $DATA(DIRUT)!$DATA(DTOUT)
QUIT
+21 SET PROVNAME=""
FOR
SET PROVNAME=$ORDER(@GLOBLOC@(PROVNAME))
if PROVNAME=""
QUIT
if $DATA(DIRUT)!$DATA(DTOUT)
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(@GLOBLOC@(PROVNAME,IEN))
if IEN'>0
QUIT
Begin DoDot:3
+22 SET NCOUNT=0
+23 SET TAXDESCR=""
FOR
SET TAXDESCR=$ORDER(@GLOBLOC@(PROVNAME,IEN,TAXDESCR))
if TAXDESCR=""
QUIT
SET GLOBVALU=@GLOBLOC@(PROVNAME,IEN,TAXDESCR)
Begin DoDot:4
+24 SET NPI=$PIECE(GLOBVALU,U,3)
SET TAXONOMY=$PIECE(GLOBVALU,U,4)
SET XUSDIS=$PIECE(GLOBVALU,U,6)
+25 IF PRNTFRMT=1
SET NCOUNT=NCOUNT+1
if NCOUNT=1
WRITE !,PROVNAME,?33,$$ALIGNRGT(IEN,11),?49,NPI,?65,XUSDIS
WRITE !,?6,TAXONOMY," ",TAXDESCR
+26 IF PRNTFRMT'=1
WRITE !,PROVNAME_U_$EXTRACT($$GET1^DIQ(200,IEN_",",9),6,9)_U_IEN_U_NPI_U_TAXONOMY_U_TAXDESCR_$SELECT(XUSDIV:U_XUSDIVNM,1:"")_$SELECT(XUSSORT:U_SERVSECT,1:"")
+27 QUIT
End DoDot:4
+28 IF PRNTFRMT=1
SET LINENUM=LINENUM+NCOUNT+1
IF LINENUM>(IOSL-4)
DO HEADER(OPTION,DATETIME,.PAGENUM,.LINENUM,XUSDIV,XUSDIVNM,XUSSORT,SERVSECT,XUSRESO,XUSER)
if $DATA(DIRUT)!$DATA(DTOUT)
QUIT
+29 QUIT
End DoDot:3
if $DATA(DIRUT)!$DATA(DTOUT)
QUIT
+30 QUIT
End DoDot:2
if $DATA(DIRUT)!$DATA(DTOUT)
QUIT
+31 QUIT
End DoDot:1
if $DATA(DIRUT)!$DATA(DTOUT)
QUIT
+32 IF '($DATA(DIRUT)!$DATA(DTOUT))
IF PRNTFRMT=1
Begin DoDot:1
+33 SET PROVNAME=""
IF $ORDER(@GLOBLOC@(PROVNAME))=""
WRITE !,?20,"* * * N O D A T A F O U N D * * *",!!
IF 1
+34 IF '$TEST
Begin DoDot:2
+35 NEW TOTTYP
SET TOTTYP=$SELECT(XUSRESO="R":"Residents",1:"Billable Providers")
+36 WRITE !!,"Total "_TOTTYP_":",?43,CNTTOTAL,!,TOTTYP_" with an NPI:",?43,CNTDONE,!,"EXEMPT "_TOTTYP_":",?43,CNTEXMPT,!,TOTTYP_" Still Needing an NPI:",?43,CNTNONE
+37 IF $GET(MULTDIV)>0
WRITE !!,MULTDIV," Providers were repeated a total of ",MULTDIVC," times",!," due to listing under multiple divisions"
+38 QUIT
End DoDot:2
+39 WRITE !!,?27,"*** End of Report ***"
+40 QUIT
End DoDot:1
+41 QUIT
+42 ;
+1 ; ZEXCEPT: IOF,IOST KERNEL IO VARIABLES
+2 ; ZEXCEPT: DIRUT,DTOUT NEWED IN CALLING PRNTPROV - INDICATE QUIT TO PRNTPROV
+3 NEW TEMPVAL,DIR,X,Y
+4 SET PAGNOREF=PAGNOREF+1
+5 ; add p 519
SET XUSER=$GET(XUSER)
+6 ; Don't page feed on the first page
+7 IF PAGNOREF>1
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET DIRUT=1
QUIT
+8 IF PAGNOREF>1
WRITE @IOF
+9 if $EXTRACT(IOST,1,2)'="C-"
WRITE !
+10 WRITE "Active Provider Report ("_$SELECT(XUSRESO="P":"no residents)",XUSRESO="R":"residents only)",1:"includes residents)")
+11 WRITE ?48,$$FMTE^XLFDT(DATETIME)," Page: ",PAGNOREF
+12 WRITE !,"Report Option: Provider List Active ",$SELECT(XUSER=2:"and Disuser ",1:""),"Providers",$SELECT(OPTION=2:" Without NPI Numbers",1:"")
+13 WRITE !!,"Provider Name",?39,"IEN",?49,$SELECT(OPTION'=2:"NPI",1:""),?65,$SELECT(XUSER=2:"Disuser",1:"")
+14 WRITE !," Taxonomy"
+15 WRITE !,"--------------------------------------------------------------------------------"
+16 SET LINNOREF=6
+17 IF XUSDIV
WRITE !,"DIVISION: ",XUSDIVNM," "
SET LINNOREF=LINNOREF+1
+18 IF XUSSORT
if 'XUSDIV
WRITE !
WRITE "SERVICE/SECTION: ",SERVSECT
if 'XUSDIV
SET LINNOREF=LINNOREF+1
+19 QUIT
+20 ;
GETDATA(OPTION,XUSSORT,XUSDIV,XUSRESO,XUSER) ; get data for reports for providers
+1 NEW NPI,PROVNAME,TAXDESCR,TAXONOMY,XUSDEFLT,XUSDIVCN,XUSDIVN,XUSDIVNM,XUSGLOB,XUSACTV,XUSSKIP
+2 NEW XUSIEN,XUSSERVC,XUSVAL,CNTCLEAN,X,XUSDIS
+3 SET XUSRESO=$GET(XUSRESO)
+4 ;add p 519 - active users only reported
SET XUSER=$GET(XUSER)
IF XUSER=""
SET XUSER=1
+5 ; p 519
SET XUSDIS=""
+6 ; ZEXCEPT: CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE - NEWed and initialized in PRNTPROV or killed based on CNTCLEAN
+7 SET CNTCLEAN=0
IF '$DATA(CNTTOTAL)
SET CNTCLEAN=1
+8 SET XUSGLOB=$NAME(^TMP($JOB,"XUSNPIPRNT"))
KILL @XUSGLOB
+9 IF 'XUSDIV
SET XUSDIVNM(1)=" "
SET XUSDEFLT=" "
+10 IF XUSDIV
SET XUSDEFLT=$$NS^XUAF4($$KSP^XUPARAM("INST"))
SET XUSDEFLT=$PIECE(XUSDEFLT,U)
+11 IF 'XUSSORT
SET XUSSERVC=" "
+12 NEW XUS1,XUS2
+13 FOR XUSIEN=0:0
SET XUSIEN=$ORDER(^VA(200,XUSIEN))
if (XUSIEN'>0)!(XUSIEN'=+XUSIEN)
QUIT
Begin DoDot:1
+14 ; Don't report TERMINATED
+15 SET XUSACTV=$$ACTIVE^XUSER(XUSIEN)
+16 ;p 519
IF XUSACTV=""!($PIECE(XUSACTV,U,2)="TERMINATED")
QUIT
+17 ;p 519
IF XUSER=1
IF $PIECE(XUSACTV,U)=0
QUIT
+18 ;p 519
SET XUSDIS=""
IF $PIECE(XUSACTV,U,2)="DISUSER"
SET XUSDIS="Yes"
+19 ; Don't report users with null NPI ENTRY STATUS
+20 SET XUSVAL=$$CHEKNPI^XUSNPIED(XUSIEN)
SET XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN)
+21 ; p764
IF $$GETNPI^XUSNPIED(XUSIEN)>0
SET $PIECE(^VA(200,XUSIEN,"NPI"),"^",2)="D"
SET XUSVAL=$$NPISTATS^XUSNPIED(XUSIEN)
+22 if XUSVAL=""
QUIT
+23 SET PROVNAME=$$GET1^DIQ(200,XUSIEN_",",.01)
SET NPI=$$GETNPI^XUSNPIED(XUSIEN)
SET TAXONOMY=$$GETTAXON^XUSNPIED(XUSIEN,.TAXDESCR)
IF TAXONOMY=-1
SET TAXONOMY=" "
SET TAXDESCR=" "
+24 ; Determine whether provider is a resident for local reports.
+25 IF OPTION'=3
IF XUSRESO'="B"
SET XUSSKIP=0
Begin DoDot:2
+26 IF XUSRESO="R"
IF TAXONOMY'="390200000X"
SET XUSSKIP=1
QUIT
+27 IF XUSRESO="P"
IF TAXONOMY="390200000X"
SET XUSSKIP=1
+28 QUIT
End DoDot:2
if XUSSKIP
QUIT
+29 IF NPI=""
IF $$EXMPTNPI^XUSNPIED(XUSIEN)
SET NPI="EXEMPTED "
+30 ;p752 to correct the NPI ENTRY STATUS
IF NPI=""
IF XUSVAL="D"
SET XUSVAL="N"
SET $PIECE(^VA(200,XUSIEN,"NPI"),"^",2)=XUSVAL
+31 SET CNTTOTAL=$GET(CNTTOTAL)+1
if NPI=""
SET CNTNONE=$GET(CNTNONE)+1
if NPI="EXEMPTED "
SET CNTEXMPT=$GET(CNTEXMPT)+1
if NPI?10N
SET CNTDONE=$GET(CNTDONE)+1
+32 IF '((XUSVAL="N")!(OPTION'=2))
QUIT
+33 IF XUSSORT
SET XUSSERVC=$$GET1^DIQ(200,XUSIEN_",",29)
IF XUSSERVC=""
SET XUSSERVC=" "
+34 IF XUSDIV
Begin DoDot:2
+35 KILL XUSDIVNM
SET XUSDIVCN=0
SET XUSDIVNM(1)=XUSDEFLT
+36 FOR XUSDIVN=0:0
SET XUSDIVN=$ORDER(^VA(200,XUSIEN,2,XUSDIVN))
if XUSDIVN'>0
QUIT
SET XUSDIVCN=XUSDIVCN+1
SET XUSDIVNM(XUSDIVCN)=$$GET1^DIQ(200.02,XUSDIVN_","_XUSIEN_",",.01)
+37 IF XUSDIVCN>1
SET MULTDIV=$GET(MULTDIV)+1
SET MULTDIVC=$GET(MULTDIVC)+XUSDIVCN-1
+38 QUIT
End DoDot:2
+39 FOR XUSDIVN=0:0
SET XUSDIVN=$ORDER(XUSDIVNM(XUSDIVN))
if XUSDIVN'>0
QUIT
Begin DoDot:2
+40 ;p 519 add piece #6 on X
SET X=PROVNAME_U_XUSIEN_U_NPI_U_TAXONOMY_U_TAXDESCR
IF XUSDIS="Yes"
SET X=X_U_XUSDIS
+41 SET @XUSGLOB@(XUSDIVNM(XUSDIVN),XUSSERVC,PROVNAME,XUSIEN,TAXDESCR)=X
+42 QUIT
End DoDot:2
+43 QUIT
End DoDot:1
+44 IF CNTCLEAN
KILL CNTTOTAL,CNTNONE,CNTEXMPT,CNTDONE
+45 QUIT XUSGLOB
+46 ;
ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width
+1 NEW RESULT
+2 SET $PIECE(RESULT," ",WIDTH)=" "
SET RESULT=RESULT_TEXT
SET RESULT=$EXTRACT(RESULT,$LENGTH(RESULT)-WIDTH+1,$LENGTH(RESULT))
+3 QUIT RESULT
+4 ;
CHKOLD1(IEN) ; check for earlier value, and activate if present
+1 NEW IEN1,STATUS,NPI,DATE,XUFDA
+2 SET IEN1=$ORDER(^VA(200,IEN,"NPISTATUS"," "),-1)
IF IEN1>0
Begin DoDot:1
+3 SET STATUS=^VA(200,IEN,"NPISTATUS",IEN1,0)
SET NPI=$PIECE(STATUS,U,3)
SET DATE=$PIECE(STATUS,U)
SET STATUS=$PIECE(STATUS,U,2)
+4 ; entry making it INACTIVE - remove it
IF STATUS=0
DO DELETNPI(IEN,IEN1,DATE)
QUIT
+5 IF STATUS=1
DO SET^XUSNPIE1(IEN,NPI)
+6 QUIT
End DoDot:1
IF STATUS=0
DO CHKOLD1(IEN)
+7 QUIT
+8 ;
DELETNPI(IEN,OIEN,ODATEVAL) ;
+1 NEW XUFDA
+2 IF $DATA(ODATEVAL)
SET XUFDA(200.042,OIEN_","_IEN_",",.01)="@"
DO FILE^DIE("","XUFDA")
+3 IF $ORDER(^VA(200,IEN,"NPISTATUS",0))>0
QUIT
+4 NEW XUFDA
+5 IF $$GET1^DIQ(200,IEN_",",41.99)
SET XUFDA(200,IEN_",",41.99)="@"
+6 IF $$GET1^DIQ(200,IEN_",",41.98)'=""
SET XUFDA(200,IEN_",",41.98)="@"
+7 IF $DATA(XUFDA)
DO FILE^DIE("","XUFDA")
+8 QUIT
+9 ;
CLERXMPT ; edit entry indicating whether a provider is exempt from needing an NPI
+1 NEW DIC,DIR,FDA,IEN,Y
+2 WRITE !
SET DIC="^VA(200,"
SET DIC(0)="AEQ"
SET DIC("A")="select Provider: "
DO ^DIC
if Y'>0
QUIT
SET IEN=+Y
+3 IF $$HASNPI^XUSNPIED(IEN)
WRITE !,"This Provider already has an NPI value. Nothing to do."
QUIT
+4 IF '$$CHEKNPI^XUSNPIED(IEN)
IF '$$EXMPTNPI^XUSNPIED(IEN)
WRITE !,"This Provider does not appear to need an NPI or Exemption."
QUIT
+5 ; currently marked as Exempt
IF $$EXMPTNPI^XUSNPIED(IEN)
Begin DoDot:1
+6 SET DIR(0)="Y"
SET DIR("A")="Provider is currently EXEMPT from needing an NPI, set to NEEDS an NPI (Y/N)"
DO ^DIR
IF 'Y
QUIT
+7 SET FDA(200,IEN_",",41.98)="N"
DO FILE^DIE("","FDA")
+8 WRITE !,$SELECT($$NEEDSNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to NEEDS an NPI")
+9 QUIT
End DoDot:1
QUIT
+10 ; check to make sure provider should be exempt
+11 SET DIR(0)="Y"
SET DIR("A")="Confirm that Provider should be Exempt from needing an NPI (Y/N)"
DO ^DIR
IF 'Y
QUIT
+12 ; and update file to show as exempt
+13 SET FDA(200,IEN_",",41.98)="E"
DO FILE^DIE("","FDA")
+14 WRITE !,$SELECT($$EXMPTNPI^XUSNPIED(IEN):"File updated",1:"Ecountered a problem updating file, status NOT set to EXEMPT")
+15 QUIT
