XUSNPIE1 ;FO-OAKLAND/JLI - NATIONAL PROVIDER IDENTIFIER DATA CAPTURE ;3/31/2021
;;8.0;KERNEL;**420,410,435,454,462,480,753**; July 10, 1995;Build 1
;;Per VHA Directive 2004-038, this routine should not be modified
Q
;
SET(XUSIEN,XUSNPI) ;
; set value for NPI related fields (#41.97-41.99) in file #200
N XUSFDA,XUSIENS,X
S X=$G(^VA(200,XUSIEN,"NPI"))
S XUSIENS=XUSIEN_","
S XUSFDA(200,XUSIENS,41.99)=XUSNPI
S XUSFDA(200,XUSIENS,41.98)="D"
S XUSFDA(200,XUSIENS,41.97)=1
D FILE^DIE("","XUSFDA")
Q
;
SET1(XUSIEN,XUSNPI) ;
; set value for NPI field (#41.99) in file #4
N OLDNPI S OLDNPI=$P($G(^DIC(4,XUSIEN,"NPI")),"^")
I OLDNPI K ^DIC(4,"ANPI",OLDNPI,XUSIEN)
S ^DIC(4,XUSIEN,"NPI")=XUSNPI,^DIC(4,"ANPI",XUSNPI,XUSIEN)=""
Q
;
SIGNON ; .ACT - run at user sign-on display message if NEEDS AN NPI
N XVAL,DATETIME,OPT,XVALTIME
I $$CHEKNPI^XUSNPIED(DUZ) W !!,"To enter your NPI value enter NPI at a menu prompt to jump to the",!,"edit option.",! H 1
; following to insure CBO List is scheduled to run on first day of month
S XVALTIME=$E(DT,6,7) I '((XVALTIME="01")!(XVALTIME="15")) Q
S XVAL=+$E($$NOW^XLFDT(),6,10) I XVAL>(XVALTIME_".19"),XVAL<(XVALTIME_".1958") D ; 7 PM TO 7:58 PM ON 1ST OF MONTH
. S OPT=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I OPT'>0 L +^TMP("XUS NPI CBO LOCK"):0 Q:'$T D CBOQUEUE L -^TMP("XUS NPI CBO LOCK") Q
. S DATETIME=$$GET1^DIQ(19.2,OPT_",",2)
. I DATETIME'=$$FMTE^XLFDT(DT_".2") L +^DIC(19.2,OPT):0 Q:'$T D SETQUEUE(OPT,DT_".2") L -^DIC(19.2,OPT) Q
. I '$$GET1^DIQ(19.2,OPT_",",99.1) L +^DIC(19.2,OPT):0 Q:'$T D L -^DIC(19.2,OPT)
. . D SETQUEUE(OPT,"@")
. . D SETQUEUE(OPT,DT_".2")
. . Q
. Q
Q
;
SETQUEUE(OPT,VALUE) ;
N FDA S FDA(19.2,OPT_",",2)=VALUE D FILE^DIE("","FDA")
Q
;
POSTINIT ;
N XUGLOB,XUUSER,XIEN,X,ZTDESC,ZTDTH,ZTIO,ZTRTN
;S XIEN=$$FIND1^DIC(19,"","","XUCOMMAND") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI PROVIDER SELF ENTRY")'>0 S X=$$ADD^XPDMENU("XUCOMMAND","XUS NPI PROVIDER SELF ENTRY","NPI","")
;S XIEN=$$FIND1^DIC(19,"","","XU USER SIGN-ON") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI SIGNON CHECK")'>0 S X=$$ADD^XPDMENU("XU USER SIGN-ON","XUS NPI SIGNON CHECK","","")
; get global containing Taxonomy values
S XUGLOB=$$CHKGLOB^XUSNPIED()
; go through file 200 and ma
S XUUSER=0 F S XUUSER=$O(^VA(200,XUUSER)) Q:XUUSER'>0 I $$ACTIVE^XUSER(XUUSER) D DOUSER^XUSNPIED(XUUSER,XUGLOB)
; and send CBO a starting point list
;S ZTIO="",ZTDTH=$$NOW^XLFDT(),ZTRTN="CBOLIST^XUSNPIED",ZTDESC="XUS NPI CBOLIST MESSAGE GENERATION" D ^%ZTLOAD
; set up to generate CBO list monthly
D CBOQUEUE
Q
;
CBOQUEUE ;
N FDA,XUSVAL
; check for already queued
S XUSVAL=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST") I XUSVAL>0 D Q
. S FDA(19.2,XUSVAL_",",2)=$$SETDATE()
. S FDA(19.2,XUSVAL_",",6)="1M(1@2000,15@2000)"
. N ZTQUEUED S ZTQUEUED=1 D FILE^DIE("","FDA") K ZTQUEUED
. Q
; no set up queued job
S XUSVAL=$$FIND1^DIC(19,"","","XUS NPI CBO LIST") Q:XUSVAL'>0 S FDA(19.2,"+1,",.01)=XUSVAL
S FDA(19.2,"+1,",2)=$$SETDATE()
S FDA(19.2,"+1,",6)="1M(1@2000,15@2000)"
N ZTQUEUED S ZTQUEUED=1 D UPDATE^DIE("","FDA") K ZTQUEUED
Q
;
SETDATE() ;
Q $S($E($$NOW^XLFDT(),6,10)<1.2:DT,$E($$NOW^XLFDT(),6,10)<15.2:$E(DT,1,5)_"15",$E(DT,4,5)>11:(($E(DT,1,3)+1)_"0101"),1:($E(DT,1,5)+1)_"01")_".2"
;
CHKOLD1(IEN) ;
D CHKOLD1^XUSNPIE2(IEN)
Q
;
CLERXMPT ;
D CLERXMPT^XUSNPIE2
Q
;
CHKDGT(XUSNPI,XUSDA,XUSQI) ; INPUT TRANSFORM
N XUS S XUS=$$CHKDGT^XUSNPI(XUSNPI)
I XUS'>0 Q 0
N XUSQIK S XUSQIK=$$QI^XUSNPI(XUSNPI) I XUSQIK=0 Q 1
; Check whether NPI is already being used. If so, issue error or warning.
N NPIUSED,XUSRSLT
S NPIUSED=$$NPIUSED^XUSNPI1(XUSNPI,XUSQI,XUSQIK,XUSDA,.XUSRSLT,1)
; If an error was encountered, quit 0.
I NPIUSED=1 Q 0
; If a warning was encountered, quit 1 (Person on file 200 and 355.93 can share NPI)
I NPIUSED=2 Q 1
I XUSDA=$P(XUSQIK,"^",2) Q 1 ; p753
; If current provider previously had this NPI, make sure the NPI being added is the most
; current one in the EFFECTIVE DATE/TIME multiple (history).
N XUSROOT S XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
I $E(XUSROOT)'="^" S XUSROOT="^"_XUSROOT
N XUS1 S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_"""A"""_")"
N XUS2 S XUS2=$O(@XUS1,-1) I XUS2'>0 Q 1
S XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_XUS2_","_0_")"
S XUS2=$G(@XUS1) I $P(XUS2,"^",3)=XUSNPI Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSNPIE1 4489 printed Sep 23, 2025@19:48:54 Page 2
XUSNPIE1 ;FO-OAKLAND/JLI - NATIONAL PROVIDER IDENTIFIER DATA CAPTURE ;3/31/2021
+1 ;;8.0;KERNEL;**420,410,435,454,462,480,753**; July 10, 1995;Build 1
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
+4 ;
SET(XUSIEN,XUSNPI) ;
+1 ; set value for NPI related fields (#41.97-41.99) in file #200
+2 NEW XUSFDA,XUSIENS,X
+3 SET X=$GET(^VA(200,XUSIEN,"NPI"))
+4 SET XUSIENS=XUSIEN_","
+5 SET XUSFDA(200,XUSIENS,41.99)=XUSNPI
+6 SET XUSFDA(200,XUSIENS,41.98)="D"
+7 SET XUSFDA(200,XUSIENS,41.97)=1
+8 DO FILE^DIE("","XUSFDA")
+9 QUIT
+10 ;
SET1(XUSIEN,XUSNPI) ;
+1 ; set value for NPI field (#41.99) in file #4
+2 NEW OLDNPI
SET OLDNPI=$PIECE($GET(^DIC(4,XUSIEN,"NPI")),"^")
+3 IF OLDNPI
KILL ^DIC(4,"ANPI",OLDNPI,XUSIEN)
+4 SET ^DIC(4,XUSIEN,"NPI")=XUSNPI
SET ^DIC(4,"ANPI",XUSNPI,XUSIEN)=""
+5 QUIT
+6 ;
SIGNON ; .ACT - run at user sign-on display message if NEEDS AN NPI
+1 NEW XVAL,DATETIME,OPT,XVALTIME
+2 IF $$CHEKNPI^XUSNPIED(DUZ)
WRITE !!,"To enter your NPI value enter NPI at a menu prompt to jump to the",!,"edit option.",!
HANG 1
+3 ; following to insure CBO List is scheduled to run on first day of month
+4 SET XVALTIME=$EXTRACT(DT,6,7)
IF '((XVALTIME="01")!(XVALTIME="15"))
QUIT
+5 ; 7 PM TO 7:58 PM ON 1ST OF MONTH
SET XVAL=+$EXTRACT($$NOW^XLFDT(),6,10)
IF XVAL>(XVALTIME_".19")
IF XVAL<(XVALTIME_".1958")
Begin DoDot:1
+6 SET OPT=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST")
IF OPT'>0
LOCK +^TMP("XUS NPI CBO LOCK"):0
if '$TEST
QUIT
DO CBOQUEUE
LOCK -^TMP("XUS NPI CBO LOCK")
QUIT
+7 SET DATETIME=$$GET1^DIQ(19.2,OPT_",",2)
+8 IF DATETIME'=$$FMTE^XLFDT(DT_".2")
LOCK +^DIC(19.2,OPT):0
if '$TEST
QUIT
DO SETQUEUE(OPT,DT_".2")
LOCK -^DIC(19.2,OPT)
QUIT
+9 IF '$$GET1^DIQ(19.2,OPT_",",99.1)
LOCK +^DIC(19.2,OPT):0
if '$TEST
QUIT
Begin DoDot:2
+10 DO SETQUEUE(OPT,"@")
+11 DO SETQUEUE(OPT,DT_".2")
+12 QUIT
End DoDot:2
LOCK -^DIC(19.2,OPT)
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
SETQUEUE(OPT,VALUE) ;
+1 NEW FDA
SET FDA(19.2,OPT_",",2)=VALUE
DO FILE^DIE("","FDA")
+2 QUIT
+3 ;
POSTINIT ;
+1 NEW XUGLOB,XUUSER,XIEN,X,ZTDESC,ZTDTH,ZTIO,ZTRTN
+2 ;S XIEN=$$FIND1^DIC(19,"","","XUCOMMAND") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI PROVIDER SELF ENTRY")'>0 S X=$$ADD^XPDMENU("XUCOMMAND","XUS NPI PROVIDER SELF ENTRY","NPI","")
+3 ;S XIEN=$$FIND1^DIC(19,"","","XU USER SIGN-ON") I XIEN>0,$$FIND1^DIC(19.01,","_XIEN_",","","XUS NPI SIGNON CHECK")'>0 S X=$$ADD^XPDMENU("XU USER SIGN-ON","XUS NPI SIGNON CHECK","","")
+4 ; get global containing Taxonomy values
+5 SET XUGLOB=$$CHKGLOB^XUSNPIED()
+6 ; go through file 200 and ma
+7 SET XUUSER=0
FOR
SET XUUSER=$ORDER(^VA(200,XUUSER))
if XUUSER'>0
QUIT
IF $$ACTIVE^XUSER(XUUSER)
DO DOUSER^XUSNPIED(XUUSER,XUGLOB)
+8 ; and send CBO a starting point list
+9 ;S ZTIO="",ZTDTH=$$NOW^XLFDT(),ZTRTN="CBOLIST^XUSNPIED",ZTDESC="XUS NPI CBOLIST MESSAGE GENERATION" D ^%ZTLOAD
+10 ; set up to generate CBO list monthly
+11 DO CBOQUEUE
+12 QUIT
+13 ;
CBOQUEUE ;
+1 NEW FDA,XUSVAL
+2 ; check for already queued
+3 SET XUSVAL=$$FIND1^DIC(19.2,"","","XUS NPI CBO LIST")
IF XUSVAL>0
Begin DoDot:1
+4 SET FDA(19.2,XUSVAL_",",2)=$$SETDATE()
+5 SET FDA(19.2,XUSVAL_",",6)="1M(1@2000,15@2000)"
+6 NEW ZTQUEUED
SET ZTQUEUED=1
DO FILE^DIE("","FDA")
KILL ZTQUEUED
+7 QUIT
End DoDot:1
QUIT
+8 ; no set up queued job
+9 SET XUSVAL=$$FIND1^DIC(19,"","","XUS NPI CBO LIST")
if XUSVAL'>0
QUIT
SET FDA(19.2,"+1,",.01)=XUSVAL
+10 SET FDA(19.2,"+1,",2)=$$SETDATE()
+11 SET FDA(19.2,"+1,",6)="1M(1@2000,15@2000)"
+12 NEW ZTQUEUED
SET ZTQUEUED=1
DO UPDATE^DIE("","FDA")
KILL ZTQUEUED
+13 QUIT
+14 ;
SETDATE() ;
+1 QUIT $SELECT($EXTRACT($$NOW^XLFDT(),6,10)<1.2:DT,$EXTRACT($$NOW^XLFDT(),6,10)<15.2:$EXTRACT(DT,1,5)_"15",$EXTRACT(DT,4,5)>11:(($EXTRACT(DT,1,3)+1)_"0101"),1:($EXTRACT(DT,1,5)+1)_"01")_".2"
+2 ;
CHKOLD1(IEN) ;
+1 DO CHKOLD1^XUSNPIE2(IEN)
+2 QUIT
+3 ;
CLERXMPT ;
+1 DO CLERXMPT^XUSNPIE2
+2 QUIT
+3 ;
CHKDGT(XUSNPI,XUSDA,XUSQI) ; INPUT TRANSFORM
+1 NEW XUS
SET XUS=$$CHKDGT^XUSNPI(XUSNPI)
+2 IF XUS'>0
QUIT 0
+3 NEW XUSQIK
SET XUSQIK=$$QI^XUSNPI(XUSNPI)
IF XUSQIK=0
QUIT 1
+4 ; Check whether NPI is already being used. If so, issue error or warning.
+5 NEW NPIUSED,XUSRSLT
+6 SET NPIUSED=$$NPIUSED^XUSNPI1(XUSNPI,XUSQI,XUSQIK,XUSDA,.XUSRSLT,1)
+7 ; If an error was encountered, quit 0.
+8 IF NPIUSED=1
QUIT 0
+9 ; If a warning was encountered, quit 1 (Person on file 200 and 355.93 can share NPI)
+10 IF NPIUSED=2
QUIT 1
+11 ; p753
IF XUSDA=$PIECE(XUSQIK,"^",2)
QUIT 1
+12 ; If current provider previously had this NPI, make sure the NPI being added is the most
+13 ; current one in the EFFECTIVE DATE/TIME multiple (history).
+14 NEW XUSROOT
SET XUSROOT=$$GET^XPAR("PKG.KERNEL","XUSNPI QUALIFIED IDENTIFIER",XUSQI)
+15 IF $EXTRACT(XUSROOT)'="^"
SET XUSROOT="^"_XUSROOT
+16 NEW XUS1
SET XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_"""A"""_")"
+17 NEW XUS2
SET XUS2=$ORDER(@XUS1,-1)
IF XUS2'>0
QUIT 1
+18 SET XUS1=XUSROOT_XUSDA_","_"""NPISTATUS"""_","_XUS2_","_0_")"
+19 SET XUS2=$GET(@XUS1)
IF $PIECE(XUS2,"^",3)=XUSNPI
QUIT 1
+20 QUIT 0
