- 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 Feb 18, 2025@23:39:09 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)