XUSNPIED ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;6/3/08 17:19
;;8.0;KERNEL;**420,410,435,480**;Jul 10, 1995;Build 38
;;Per VHA Directive 2004-038, this routine should not be modified
Q
;
SIGNON ; run at user sign-on to display message if NPI value is needed.
D SIGNON^XUSNPIE1
Q
;
CLEREDIT ; Input editing of NPI value for clerical staff - ask provider
N IEN,DIC,PROVNAME,DATEVAL,DESCRIP,DONE,IENS,NPIVAL1,NPIVAL2,Y,XX
F W ! S DIC="^VA(200,",DIC(0)="AEQ" S DIC("A")="Select Provider: " D ^DIC Q:Y'>0 S IEN=+Y D EDITNPI(IEN)
Q
;
USEREDIT ; Entry point for provider to enter own data
I $$NPISTATS(DUZ)="" W !,$C(7),"Please see your local NPI facilitator to add the NPI",! H 3 Q
D EDITNPI(DUZ)
Q
;
EDITNPI(IEN) ;
D EDITNPI^XUSNPIE3(IEN)
Q
;
EDRLNPI(IEN) ; Edit AUTHORIZES RELEASE OF NPI field
; NOTE: *** This field is no longer being used, and should always be set to YES 05/13/08 tkw***
Q:$P($G(^VA(200,+$G(IEN),"NPI")),U,3)=1
N DIE,DR,DA S DIE="^VA(200,",DA=IEN,DR="41.97////1" D ^DIE
Q
;
CLERXMPT ;
D CLERXMPT^XUSNPIE1
Q
;
CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing
Q $$CHKGLOB^XUSNPIDA()
;
DOUSER(XUUSER,XUGLOB) ; check user for needing an NPI status value
N PCLASS,XUDONE,PVAL,CODE,NPISTATS,XUVALUE,D0,EXPIRATN,I,NPIFLD,NPISUBFL
S NPISTATS=41.98,NPISUBFL=200.042,NPIFLD=.03
I $$GET1^DIQ(200,XUUSER_",",NPISTATS)'="" Q ; user is already flagged
S PCLASS=0,XUDONE=0 F S PCLASS=$O(^VA(200,XUUSER,"USC1",PCLASS)) Q:PCLASS'>0 S D0=^(PCLASS,0) D Q:XUDONE
. S EXPIRATN=$P(D0,U,3)>0 I EXPIRATN Q
. S PVAL=$P(D0,U),CODE=$$GET1^DIQ(8932.1,PVAL_",",6) I CODE'="",$D(@XUGLOB@(CODE)) D S XUDONE=1 Q
. . S XUVALUE="N" N NPIVAL F I=1:1 S NPIVAL=$$GET1^DIQ(NPISUBFL,I_","_XUUSER_",",NPIFLD) Q:NPIVAL="" S XUVALUE="D" Q
. . N XUFDA S XUFDA(200,XUUSER_",",NPISTATS)=XUVALUE
. . D FILE^DIE("","XUFDA")
. . Q
. Q
Q
;
CBOLIST ; list ^ delimited output to CBO exchange mail group.
N DATE,DOMAIN,ADDRESS,STATNAME,COUNT,GLOBLOC,GLOBOUT
N IEN,NPI,PROVNAME,TAXDESCR,TAXONOMY,STATION,STATUS,OPTION
I '$$PROD^XUPROD() Q ; messages from production systems only
S DATE=(1700+$E(DT,1,3))_"-"_$E(DT,4,5)_"-"_$E(DT,6,7)
S DOMAIN=$G(^XTV(8989.3,1,0)),DOMAIN=$P(DOMAIN,U)
S STATION=$$NS^XUAF4($$KSP^XUPARAM("INST"))
S ADDRESS=$P(STATION,U) ;$$GET1^DIQ(4.2,DOMAIN_",",.01)
S STATION=$P(STATION,U,2) ;$$GET1^DIQ(4.2,DOMAIN_",",5.5)
S OPTION=3
S GLOBLOC=$$GETDATA(OPTION,0,0) ; get most of data into location specified by GLOBLOC
S COUNT=0,GLOBOUT=$NA(^TMP($J,"XUSNPIOUT")) K @GLOBOUT
S COUNT=1,@GLOBOUT@(COUNT)="--START"
S GLOBLOC=$NA(@GLOBLOC@(" "," "))
S PROVNAME="" F S PROVNAME=$O(@GLOBLOC@(PROVNAME)) Q:PROVNAME="" S IEN=0 F S IEN=$O(@GLOBLOC@(PROVNAME,IEN)) Q:IEN'>0 D
. S TAXDESCR="" F S TAXDESCR=$O(@GLOBLOC@(PROVNAME,IEN,TAXDESCR)) Q:TAXDESCR="" S TAXONOMY=$P(^(TAXDESCR),U,4),NPI=$P(^(TAXDESCR),U,3) D
. . S STATUS=$$NPISTATS(IEN)
. . S COUNT=COUNT+1,@GLOBOUT@(COUNT)=PROVNAME_U_STATION_U_NPI_U_TAXONOMY_U_TAXDESCR_U_DATE_U_STATUS
. . Q
. Q
S COUNT=COUNT+1,@GLOBOUT@(COUNT)="--END"
; and generate mail message
N XMTEXT,XMDUZ,XMY,XMSUB
S XMTEXT=$E(GLOBOUT,1,$L(GLOBOUT)-1)_",",XMDUZ=0.5,XMY("VHACONPINPF@DOMAIN.EXT")=""
S XMSUB="NPI LIST "_DATE_" FOR "_ADDRESS_" ("_STATION_")"
D ^XMD
Q
;
PRINTOPT ;
D PRINTOPT^XUSNPIE2
Q
GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers
Q $$GETDATA^XUSNPIE2(OPTION,XUSSORT,XUSDIV)
;
CHEKNPI(IEN) ; returns whether status is Needs, will check and update if not set
N VALUE,FDA
S VALUE=$E($$GET1^DIQ(200,IEN_",",41.98))
I VALUE="N" S FDA(200,IEN_",",41.98)="" D FILE^DIE("","FDA") S VALUE="" ; XU*8*435 JLI
I VALUE="",$$CHKTAXON(IEN) K FDA S FDA(200,IEN_",",41.98)="N" D FILE^DIE("","FDA") S VALUE="N"
Q VALUE="N"
;
NEEDSNPI(IEN) ; returns whether current status is N
Q $$NPISTATS(IEN)="N"
;
HASNPI(IEN) ; returns whether current status is D (Done)
Q $$NPISTATS(IEN)="D"
;
EXMPTNPI(IEN) ; returns whether current status is E (Exempt)
Q $$NPISTATS(IEN)="E"
;
NPISTATS(IEN) ; returns one letter status indicator
N VAL
S VAL=$E($$GET1^DIQ(200,IEN_",",41.98))
I (VAL="")!(VAL="N") S VAL=$$CHEKNPI(IEN)
Q $E($$GET1^DIQ(200,IEN_",",41.98))
;
GETNPI(IEN) ; returns current NPI value
Q $$GET1^DIQ(200,IEN_",",41.99)
;
GETTAXON(IEN,DESCRREF) ; returns Taxonomy value (X12) and sets description in DESCRREF, otherwise -1
N I,POINTER,TAXON
S TAXON=-1,DESCRREF=" "
;F I=0:0 S I=$O(^VA(200,IEN,"USC1",I)) Q:I'>0 I $P(^(I,0),U,3)'>0 S POINTER=+^(0) S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) Q
S POINTER=+$$GET^XUA4A72(IEN) I POINTER>0 S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) ; XU*8*435 make sure active on today
I TAXON="" S TAXON=-1,DESCRREF=" "
Q TAXON
;
CHKTAXON(IEN,TAXONOMY) ; checks whether taxonomy value (X12) is in list of billable otherwise 0-1
N DESCRIP,XUSGLOB
I $G(TAXONOMY)="" S TAXONOMY=$$GETTAXON(IEN,.DESCRIP)
S XUSGLOB=$$CHKGLOB()
Q $D(@XUSGLOB@(TAXONOMY))
;
DATE10(DATE) ; returns date in mm/dd/yyyyy format
Q $E(DATE,4,5)_"/"_$E(DATE,6,7)_"/"_(1700+$E(DATE,1,3))
;
POSTINIT ; runs post init
D POSTINIT^XUSNPIE1
Q
;
CBOQUEUE ; queues CBO List to run on first day of month
D CBOQUEUE^XUSNPIE1
Q
ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width
Q $$ALIGNRGT^XUSNPIE2(TEXT,WIDTH)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSNPIED 5527 printed Sep 23, 2025@19:48:57 Page 2
XUSNPIED ;FO-OAKLAND/JLI - DATA ENTRY FOR INITIAL NPI VALUES ;6/3/08 17:19
+1 ;;8.0;KERNEL;**420,410,435,480**;Jul 10, 1995;Build 38
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
+4 ;
SIGNON ; run at user sign-on to display message if NPI value is needed.
+1 DO SIGNON^XUSNPIE1
+2 QUIT
+3 ;
CLEREDIT ; Input editing of NPI value for clerical staff - ask provider
+1 NEW IEN,DIC,PROVNAME,DATEVAL,DESCRIP,DONE,IENS,NPIVAL1,NPIVAL2,Y,XX
+2 FOR
WRITE !
SET DIC="^VA(200,"
SET DIC(0)="AEQ"
SET DIC("A")="Select Provider: "
DO ^DIC
if Y'>0
QUIT
SET IEN=+Y
DO EDITNPI(IEN)
+3 QUIT
+4 ;
USEREDIT ; Entry point for provider to enter own data
+1 IF $$NPISTATS(DUZ)=""
WRITE !,$CHAR(7),"Please see your local NPI facilitator to add the NPI",!
HANG 3
QUIT
+2 DO EDITNPI(DUZ)
+3 QUIT
+4 ;
EDITNPI(IEN) ;
+1 DO EDITNPI^XUSNPIE3(IEN)
+2 QUIT
+3 ;
EDRLNPI(IEN) ; Edit AUTHORIZES RELEASE OF NPI field
+1 ; NOTE: *** This field is no longer being used, and should always be set to YES 05/13/08 tkw***
+2 if $PIECE($GET(^VA(200,+$GET(IEN),"NPI")),U,3)=1
QUIT
+3 NEW DIE,DR,DA
SET DIE="^VA(200,"
SET DA=IEN
SET DR="41.97////1"
DO ^DIE
+4 QUIT
+5 ;
CLERXMPT ;
+1 DO CLERXMPT^XUSNPIE1
+2 QUIT
+3 ;
CHKGLOB() ; returns global location of TAXONOMY values also rebuilds if they are missing
+1 QUIT $$CHKGLOB^XUSNPIDA()
+2 ;
DOUSER(XUUSER,XUGLOB) ; check user for needing an NPI status value
+1 NEW PCLASS,XUDONE,PVAL,CODE,NPISTATS,XUVALUE,D0,EXPIRATN,I,NPIFLD,NPISUBFL
+2 SET NPISTATS=41.98
SET NPISUBFL=200.042
SET NPIFLD=.03
+3 ; user is already flagged
IF $$GET1^DIQ(200,XUUSER_",",NPISTATS)'=""
QUIT
+4 SET PCLASS=0
SET XUDONE=0
FOR
SET PCLASS=$ORDER(^VA(200,XUUSER,"USC1",PCLASS))
if PCLASS'>0
QUIT
SET D0=^(PCLASS,0)
Begin DoDot:1
+5 SET EXPIRATN=$PIECE(D0,U,3)>0
IF EXPIRATN
QUIT
+6 SET PVAL=$PIECE(D0,U)
SET CODE=$$GET1^DIQ(8932.1,PVAL_",",6)
IF CODE'=""
IF $DATA(@XUGLOB@(CODE))
Begin DoDot:2
+7 SET XUVALUE="N"
NEW NPIVAL
FOR I=1:1
SET NPIVAL=$$GET1^DIQ(NPISUBFL,I_","_XUUSER_",",NPIFLD)
if NPIVAL=""
QUIT
SET XUVALUE="D"
QUIT
+8 NEW XUFDA
SET XUFDA(200,XUUSER_",",NPISTATS)=XUVALUE
+9 DO FILE^DIE("","XUFDA")
+10 QUIT
End DoDot:2
SET XUDONE=1
QUIT
+11 QUIT
End DoDot:1
if XUDONE
QUIT
+12 QUIT
+13 ;
CBOLIST ; list ^ delimited output to CBO exchange mail group.
+1 NEW DATE,DOMAIN,ADDRESS,STATNAME,COUNT,GLOBLOC,GLOBOUT
+2 NEW IEN,NPI,PROVNAME,TAXDESCR,TAXONOMY,STATION,STATUS,OPTION
+3 ; messages from production systems only
IF '$$PROD^XUPROD()
QUIT
+4 SET DATE=(1700+$EXTRACT(DT,1,3))_"-"_$EXTRACT(DT,4,5)_"-"_$EXTRACT(DT,6,7)
+5 SET DOMAIN=$GET(^XTV(8989.3,1,0))
SET DOMAIN=$PIECE(DOMAIN,U)
+6 SET STATION=$$NS^XUAF4($$KSP^XUPARAM("INST"))
+7 ;$$GET1^DIQ(4.2,DOMAIN_",",.01)
SET ADDRESS=$PIECE(STATION,U)
+8 ;$$GET1^DIQ(4.2,DOMAIN_",",5.5)
SET STATION=$PIECE(STATION,U,2)
+9 SET OPTION=3
+10 ; get most of data into location specified by GLOBLOC
SET GLOBLOC=$$GETDATA(OPTION,0,0)
+11 SET COUNT=0
SET GLOBOUT=$NAME(^TMP($JOB,"XUSNPIOUT"))
KILL @GLOBOUT
+12 SET COUNT=1
SET @GLOBOUT@(COUNT)="--START"
+13 SET GLOBLOC=$NAME(@GLOBLOC@(" "," "))
+14 SET PROVNAME=""
FOR
SET PROVNAME=$ORDER(@GLOBLOC@(PROVNAME))
if PROVNAME=""
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(@GLOBLOC@(PROVNAME,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+15 SET TAXDESCR=""
FOR
SET TAXDESCR=$ORDER(@GLOBLOC@(PROVNAME,IEN,TAXDESCR))
if TAXDESCR=""
QUIT
SET TAXONOMY=$PIECE(^(TAXDESCR),U,4)
SET NPI=$PIECE(^(TAXDESCR),U,3)
Begin DoDot:2
+16 SET STATUS=$$NPISTATS(IEN)
+17 SET COUNT=COUNT+1
SET @GLOBOUT@(COUNT)=PROVNAME_U_STATION_U_NPI_U_TAXONOMY_U_TAXDESCR_U_DATE_U_STATUS
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 SET COUNT=COUNT+1
SET @GLOBOUT@(COUNT)="--END"
+21 ; and generate mail message
+22 NEW XMTEXT,XMDUZ,XMY,XMSUB
+23 SET XMTEXT=$EXTRACT(GLOBOUT,1,$LENGTH(GLOBOUT)-1)_","
SET XMDUZ=0.5
SET XMY("VHACONPINPF@DOMAIN.EXT")=""
+24 SET XMSUB="NPI LIST "_DATE_" FOR "_ADDRESS_" ("_STATION_")"
+25 DO ^XMD
+26 QUIT
+27 ;
PRINTOPT ;
+1 DO PRINTOPT^XUSNPIE2
+2 QUIT
GETDATA(OPTION,XUSSORT,XUSDIV) ; get data for reports for providers
+1 QUIT $$GETDATA^XUSNPIE2(OPTION,XUSSORT,XUSDIV)
+2 ;
CHEKNPI(IEN) ; returns whether status is Needs, will check and update if not set
+1 NEW VALUE,FDA
+2 SET VALUE=$EXTRACT($$GET1^DIQ(200,IEN_",",41.98))
+3 ; XU*8*435 JLI
IF VALUE="N"
SET FDA(200,IEN_",",41.98)=""
DO FILE^DIE("","FDA")
SET VALUE=""
+4 IF VALUE=""
IF $$CHKTAXON(IEN)
KILL FDA
SET FDA(200,IEN_",",41.98)="N"
DO FILE^DIE("","FDA")
SET VALUE="N"
+5 QUIT VALUE="N"
+6 ;
NEEDSNPI(IEN) ; returns whether current status is N
+1 QUIT $$NPISTATS(IEN)="N"
+2 ;
HASNPI(IEN) ; returns whether current status is D (Done)
+1 QUIT $$NPISTATS(IEN)="D"
+2 ;
EXMPTNPI(IEN) ; returns whether current status is E (Exempt)
+1 QUIT $$NPISTATS(IEN)="E"
+2 ;
NPISTATS(IEN) ; returns one letter status indicator
+1 NEW VAL
+2 SET VAL=$EXTRACT($$GET1^DIQ(200,IEN_",",41.98))
+3 IF (VAL="")!(VAL="N")
SET VAL=$$CHEKNPI(IEN)
+4 QUIT $EXTRACT($$GET1^DIQ(200,IEN_",",41.98))
+5 ;
GETNPI(IEN) ; returns current NPI value
+1 QUIT $$GET1^DIQ(200,IEN_",",41.99)
+2 ;
GETTAXON(IEN,DESCRREF) ; returns Taxonomy value (X12) and sets description in DESCRREF, otherwise -1
+1 NEW I,POINTER,TAXON
+2 SET TAXON=-1
SET DESCRREF=" "
+3 ;F I=0:0 S I=$O(^VA(200,IEN,"USC1",I)) Q:I'>0 I $P(^(I,0),U,3)'>0 S POINTER=+^(0) S TAXON=$$GET1^DIQ(8932.1,POINTER_",",6),DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1) Q
+4 ; XU*8*435 make sure active on today
SET POINTER=+$$GET^XUA4A72(IEN)
IF POINTER>0
SET TAXON=$$GET1^DIQ(8932.1,POINTER_",",6)
SET DESCRREF=$$GET1^DIQ(8932.1,POINTER_",",1)
+5 IF TAXON=""
SET TAXON=-1
SET DESCRREF=" "
+6 QUIT TAXON
+7 ;
CHKTAXON(IEN,TAXONOMY) ; checks whether taxonomy value (X12) is in list of billable otherwise 0-1
+1 NEW DESCRIP,XUSGLOB
+2 IF $GET(TAXONOMY)=""
SET TAXONOMY=$$GETTAXON(IEN,.DESCRIP)
+3 SET XUSGLOB=$$CHKGLOB()
+4 QUIT $DATA(@XUSGLOB@(TAXONOMY))
+5 ;
DATE10(DATE) ; returns date in mm/dd/yyyyy format
+1 QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"/"_(1700+$EXTRACT(DATE,1,3))
+2 ;
POSTINIT ; runs post init
+1 DO POSTINIT^XUSNPIE1
+2 QUIT
+3 ;
CBOQUEUE ; queues CBO List to run on first day of month
+1 DO CBOQUEUE^XUSNPIE1
+2 QUIT
ALIGNRGT(TEXT,WIDTH) ; align text right in a specified width
+1 QUIT $$ALIGNRGT^XUSNPIE2(TEXT,WIDTH)
