IBCEP82 ;ALB/CLT - Special cross references and data entry for fields in file 355.93 ;18 Apr 2008 3:46 PM
;;2.0;INTEGRATED BILLING;**343,374,377,391,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
; Call at tags only
Q
;This routine will ask for the NPI, check for duplicate entries, and check for proper
;format using the double-add-double formula. If the NPI is being deleted it will ask
;the user why it is being deleted.
;If it is being deleted because of an erroneous entry it will be completely deleted.
;If it is a valid NPI being deleted because of possible inappropriate usage it will be
;maintained in the history cross reference to preclude anyone from using this NPI again.
;
EN(IBNPRV) ;Routine primary entry point
N DTOUT,DUOUT,DA,DIR,DIE,DIC,DR,X,Y,IBKEY
N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB
S IBOLDNPI="",IBNPI="",IBKEY="XUSNPIMTL"
EN1 ;
S (DA,IBIEN)=IBNPRV
K DIR
S DIR(0)="FO^10:10",DIR("A")="NPI",DIR("?")="Enter a 10 digit National Provider Identifier"
I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI,IBNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
;Sole Proprietor IB*2*516
I $P($G(^IBA(355.93,DA,0)),U,17)="Y" D
. N IBA35593
. S IBA35593=$P($G(^IBA(355.93,DA,0)),U,18)
. I IBA35593,$P($G(^IBA(355.93,IBA35593,0)),U,14)]"" S DIR("B")=$P(^(0),U,14)
D ^DIR S IBCHECK=$S(Y=IBOLDNPI:2,1:0)
I X="^" W *7,!," EXIT NOT ALLOWED ??" G EN1
I $E(X)="^" W *7,!," JUMPING NOT ALLOWED ??" G EN1
I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN1
I $G(DUOUT)!$G(DTOUT) G XIT
I $G(IBOLDNPI)="",$G(X)="" G XIT
S IBNPI=$S(X="":$G(IBOLDNPI),1:X)
I '$$PROC(IBNPI,IBOLDNPI,IBIEN) G EN1
G XIT
;
EN2(IBNPRV,INDENT) ; entry point from input templates IB SCREEN82 and IB SCREEN8H
N DTOUT,DUOUT,DA,DIR,DIE,DIC,DR,X,Y,IBKEY
N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB,SPACES
S IBNPI="",IBKEY="XUSNPIMTL",IBOLDNPI="",SPACES=" "
EN21 ;
S (DA,IBIEN)=IBNPRV
K DIR
S DIR(0)="FO^10:10",DIR("A")=$E(SPACES,1,INDENT)_"NPI",DIR("?")=$E(SPACES,1,INDENT)_"Enter a 10 digit National Provider Identifier"
I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI,IBNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
D ^DIR S IBCHECK=$S(Y=IBOLDNPI:2,1:0)
I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN21
I $G(DUOUT)!$G(DTOUT) G XIT
I $G(IBOLDNPI)="",$G(X)="" G XIT
S IBNPI=$S(X="":$G(IBOLDNPI),1:X)
I '$$PROC(IBNPI,IBOLDNPI,IBIEN) G EN21
G XIT
;
PROC(IBNPI,IBOLDNPI,IBIEN) ; process new NPI
I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,$E($G(SPACES),1,+$G(INDENT))_"Not a valid NPI. Please try again.",! Q 0
I $$NPIUSED^IBCEP81(IBNPI,IBOLDNPI,IBIEN,IBCHECK,IBKEY)=1 Q 0
S IBCHECK=1
I IBOLDNPI="" D ACTI
I IBOLDNPI'="" D:IBNPI'=IBOLDNPI INACT
S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI,^IBA(355.93,"NPI",IBNPI,IBIEN)="",^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)=""
Q 1
;
ACTI ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD
S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
S DIC("DR")=".02////^S X=1;.03////^S X=IBNPI;.04////^S X=DUZ"
D FILE^DICN
S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI
Q
;
DEL ;NPI HAS BEEN DELETED
;If the user deletes the NPI this subroutine will determine why it was deleted and, if it was because it was found
;in a false identity situation, will mark it in history to never be used again.
S IBNPI=$G(DIR("B"))
K DIR
S DIR(0)="Y"
S DIR("A")="Are you sure you wish to delete this NPI"
S DIR("?")="You have indicated you wish to delete the NPI. This is a second chance check."
D ^DIR
G:Y(0)="NO" XIT
;S DIR(0)="S^E:ERROR;V:VALID",DIR("A")="Was this a Valid NPI or an NPI entered in Error"
;S DIR("?",1)="An example of an NPI entered in error is if the entry person transposed numbers,"
;S DIR("?",2)="or if the NPI for one provider is accidentally assigned to a different provider."
;S DIR("?")="Enter an 'E' for Error or a 'V' for Valid."
;D ^DIR
D COMP W !,"This NPI will be designated as Entered in Error.",!
;I Y="V" S IBCHECK=2 D INACT W !,"The NPI is now inactive.",!
;Q:$D(DTOUT)!($D(DUOUT))
S IBOLDNPI=IBNPI D WARND(IBIEN,IBOLDNPI,IBKEY)
Q
;
COMP ;COMPLETELY DELETE THE NPI
;This subroutine will delete the NPI from the file 355.93.
S OIEN=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,"A"),-1)
D DELNPI(IBIEN,OIEN)
K ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA)
S IBRB=0
D ; Find the most recent status '0' (inactive) NPI entry in the list.
. N IBRBLST,IBRBTMP
. ; Don't want to roll back to the same number you are deleting.
. S IBRBLST(IBOLDNPI)=""
. S IBRBTMP="A"
. ; Go through each entry in reverse order
. F S IBRBTMP=$O(^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP),-1) Q:'IBRBTMP D Q:IBRB'=0
.. S IBRBLST=^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP,0)
.. ; If this is an 'active' entry then ignore it.
.. I $P(IBRBLST,U,2)=1 Q
.. ; If this entry does not have an NPI then ignore it.
.. I $P(IBRBLST,U,3)="" Q
.. ;If this is an inactive entry then report it.
.. I $P(IBRBLST,U,2)=0 S IBRB=IBRBTMP Q
.. Q
. Q
I IBRB>0 D ROLLBACK
Q
;
DELNPI(IEN,OIEN) ;DELETE-INVALID removes NPI from file.
NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
NEW DP,DM,DK,DL,DIEL
S DIE="^IBA(355.93,",DA=IEN,DR="41.01////@"
D ^DIE
S DA(1)=IEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=OIEN
D ^DIK
Q
;
INACT ;INACTIVATE AN ENTRY
;This subroutine makes two entries in the NPI multiple field:
;one for the deactivation of the old NPI and the second
;for the activation of a new NPI.
S DA(1)=IBIEN,DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DIC(0)="L",X=$$NOW^XLFDT()
S DIC("DR")=".02////^S X=0;.03////^S X=IBOLDNPI;.04////^S X=DUZ"
D FILE^DICN
S ^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA(1))=""
K ^IBA(355.93,"NPI",IBOLDNPI,DA(1))
S $P(^IBA(355.93,IBIEN,0),U,14)=""
I $G(IBCHECK)<2 D
.D ACTI
.S ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))=""
.D WARNR(IBIEN,IBOLDNPI,IBKEY)
Q
;
ROLLBACK ;Rollback or delete NPI
S IBRBNPI=$P(^IBA(355.93,IBIEN,"NPISTATUS",IBRB,0),U,3)
NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
NEW DP,DM,DK,DL,DIEL
S DA(1)=IBIEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=IBRB
D ^DIK
S $P(^IBA(355.93,IBIEN,0),U,14)=IBRBNPI,^IBA(355.93,"NPI",IBRBNPI,IBIEN)=""
Q
;
XIT ;CLEAN AND EXIT
Q
;
XR ;Set the primary taxonomy code cross reference for field 42
N ATAX S ATAX=""
I $D(^IBA(355.93,DA(1),"TAXONOMY","D")) D:X=1
. F S ATAX=$O(^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)) Q:ATAX="" D
.. K ^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)
.. I ATAX'=DA S $P(^IBA(355.93,DA(1),"TAXONOMY",ATAX,0),U,2)=0,^IBA(355.93,DA(1),"TAXONOMY","D",0,ATAX)=""
S ^IBA(355.93,DA(1),"TAXONOMY","D",X,DA)=""
Q
;
KXR ;Kill primary taxonomy code cross reference for field 42
N K
F K=0,1 K ^IBA(355.93,DA(1),"TAXONOMY","D",K,DA)
Q
;
WARNR(IBIEN,IBOLDNPI,IBKEY) ;Warn user that the old NPI that was replaced is currently used by an entry in the New Person file (#200)
N IBIEN200
Q:$G(IBOLDNPI)=""
S IBIEN200=$O(^VA(200,"ANPI",IBOLDNPI,""))
Q:IBIEN200=""
W !!,"WARNING: NPI ",IBOLDNPI," is also associated with Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",!
I $O(^XUSEC(IBKEY,""))="" W !!,"There are no holders of the ",IBKEY," security key on the VistA system. Contact your IRM department for further direction." Q
W !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key."
D MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI)
Q
;
WARND(IBIEN,IBOLDNPI,IBKEY) ;Warn user that the old NPI that was deleted is currently used by an entry in the New Person file (#200)
N IBIEN200
Q:$G(IBOLDNPI)=""
S IBIEN200=$O(^VA(200,"ANPI",IBOLDNPI,""))
Q:IBIEN200=""
W !!,"WARNING: NPI ",IBOLDNPI," is also associated with VA Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",!
I $O(^XUSEC(IBKEY,""))="" W !!,"There are no holders of the ",IBKEY," security key on the VistA system. Contact your IRM department for further direction." Q
W !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key."
D MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI)
Q
;
MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI) ;Send mailman message for replacement of NPI
;This subroutine is supported by IA# 10070
;Lookups in NEW PERSON file (#200) are supported by IA#10076
N IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG
S IBIEN2=0 F S IBIEN2=$O(^XUSEC(IBKEY,IBIEN2)) Q:IBIEN2="" S XMY(IBIEN2)=""
S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMSUB="NPI Replacement"
S IBMSG(1)="The NPI "_IBOLDNPI_" was changed to "_IBNPI_" for"
S IBMSG(2)=$$GET1^DIQ(355.93,IBIEN,.01)_" in the IB NON/OTHER VA BILLING PROVIDER"
S IBMSG(3)="file. The NPI "_IBOLDNPI_" is also associated with"
S IBMSG(4)=$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file."
S IBMSG(5)=""
S IBMSG(6)="The same change may need to be made to the NEW PERSON file using the"
S IBMSG(7)="Add/Edit NPI values for Providers option."
S XMTEXT="IBMSG(" D ^XMD
Q
;
MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI) ;Send mailman message for deletion of an NPI
;This subroutine is supported by IA# 10070
;Lookups in NEW PERSON file (#200) are supported by IA#10076
N IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG
S IBIEN2=0 F S IBIEN2=$O(^XUSEC(IBKEY,IBIEN2)) Q:IBIEN2="" S XMY(IBIEN2)=""
S XMDUZ=$S($G(DUZ):DUZ,1:.5),XMSUB="NPI Deletion"
S IBMSG(1)="The NPI "_IBOLDNPI_" was deleted for "_$$GET1^DIQ(355.93,IBIEN,.01)
S IBMSG(2)="in the IB NON/OTHER VA BILLING PROVIDER file. The NPI "_IBOLDNPI_" is also"
S IBMSG(3)="associated with "_$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file."
S IBMSG(4)=""
S IBMSG(5)="The same change may need to be made to the NEW PERSON file using the"
S IBMSG(6)="Add/Edit NPI values for Providers option."
S XMTEXT="IBMSG(" D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP82 9840 printed Oct 16, 2024@18:12:30 Page 2
IBCEP82 ;ALB/CLT - Special cross references and data entry for fields in file 355.93 ;18 Apr 2008 3:46 PM
+1 ;;2.0;INTEGRATED BILLING;**343,374,377,391,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Call at tags only
+5 QUIT
+6 ;This routine will ask for the NPI, check for duplicate entries, and check for proper
+7 ;format using the double-add-double formula. If the NPI is being deleted it will ask
+8 ;the user why it is being deleted.
+9 ;If it is being deleted because of an erroneous entry it will be completely deleted.
+10 ;If it is a valid NPI being deleted because of possible inappropriate usage it will be
+11 ;maintained in the history cross reference to preclude anyone from using this NPI again.
+12 ;
EN(IBNPRV) ;Routine primary entry point
+1 NEW DTOUT,DUOUT,DA,DIR,DIE,DIC,DR,X,Y,IBKEY
+2 NEW IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB
+3 SET IBOLDNPI=""
SET IBNPI=""
SET IBKEY="XUSNPIMTL"
EN1 ;
+1 SET (DA,IBIEN)=IBNPRV
+2 KILL DIR
+3 SET DIR(0)="FO^10:10"
SET DIR("A")="NPI"
SET DIR("?")="Enter a 10 digit National Provider Identifier"
+4 IF $GET(DA)
if $PIECE($GET(^IBA(355.93,DA,0)),U,14)'=""
SET (DIR("B"),IBOLDNPI,IBNPI)=$PIECE($GET(^IBA(355.93,DA,0)),U,14)
+5 ;Sole Proprietor IB*2*516
+6 IF $PIECE($GET(^IBA(355.93,DA,0)),U,17)="Y"
Begin DoDot:1
+7 NEW IBA35593
+8 SET IBA35593=$PIECE($GET(^IBA(355.93,DA,0)),U,18)
+9 IF IBA35593
IF $PIECE($GET(^IBA(355.93,IBA35593,0)),U,14)]""
SET DIR("B")=$PIECE(^(0),U,14)
End DoDot:1
+10 DO ^DIR
SET IBCHECK=$SELECT(Y=IBOLDNPI:2,1:0)
+11 IF X="^"
WRITE *7,!," EXIT NOT ALLOWED ??"
GOTO EN1
+12 IF $EXTRACT(X)="^"
WRITE *7,!," JUMPING NOT ALLOWED ??"
GOTO EN1
+13 IF X="@"
if IBOLDNPI'=""
GOTO DEL
WRITE *7,"??"
GOTO EN1
+14 IF $GET(DUOUT)!$GET(DTOUT)
GOTO XIT
+15 IF $GET(IBOLDNPI)=""
IF $GET(X)=""
GOTO XIT
+16 SET IBNPI=$SELECT(X="":$GET(IBOLDNPI),1:X)
+17 IF '$$PROC(IBNPI,IBOLDNPI,IBIEN)
GOTO EN1
+18 GOTO XIT
+19 ;
EN2(IBNPRV,INDENT) ; entry point from input templates IB SCREEN82 and IB SCREEN8H
+1 NEW DTOUT,DUOUT,DA,DIR,DIE,DIC,DR,X,Y,IBKEY
+2 NEW IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB,SPACES
+3 SET IBNPI=""
SET IBKEY="XUSNPIMTL"
SET IBOLDNPI=""
SET SPACES=" "
EN21 ;
+1 SET (DA,IBIEN)=IBNPRV
+2 KILL DIR
+3 SET DIR(0)="FO^10:10"
SET DIR("A")=$EXTRACT(SPACES,1,INDENT)_"NPI"
SET DIR("?")=$EXTRACT(SPACES,1,INDENT)_"Enter a 10 digit National Provider Identifier"
+4 IF $GET(DA)
if $PIECE($GET(^IBA(355.93,DA,0)),U,14)'=""
SET (DIR("B"),IBOLDNPI,IBNPI)=$PIECE($GET(^IBA(355.93,DA,0)),U,14)
+5 DO ^DIR
SET IBCHECK=$SELECT(Y=IBOLDNPI:2,1:0)
+6 IF X="@"
if IBOLDNPI'=""
GOTO DEL
WRITE *7,"??"
GOTO EN21
+7 IF $GET(DUOUT)!$GET(DTOUT)
GOTO XIT
+8 IF $GET(IBOLDNPI)=""
IF $GET(X)=""
GOTO XIT
+9 SET IBNPI=$SELECT(X="":$GET(IBOLDNPI),1:X)
+10 IF '$$PROC(IBNPI,IBOLDNPI,IBIEN)
GOTO EN21
+11 GOTO XIT
+12 ;
PROC(IBNPI,IBOLDNPI,IBIEN) ; process new NPI
+1 IF '$$CHKDGT^XUSNPI(IBNPI)
WRITE !,*7,$EXTRACT($GET(SPACES),1,+$GET(INDENT))_"Not a valid NPI. Please try again.",!
QUIT 0
+2 IF $$NPIUSED^IBCEP81(IBNPI,IBOLDNPI,IBIEN,IBCHECK,IBKEY)=1
QUIT 0
+3 SET IBCHECK=1
+4 IF IBOLDNPI=""
DO ACTI
+5 IF IBOLDNPI'=""
if IBNPI'=IBOLDNPI
DO INACT
+6 SET $PIECE(^IBA(355.93,IBIEN,0),U,14)=IBNPI
SET ^IBA(355.93,"NPI",IBNPI,IBIEN)=""
SET ^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)=""
+7 QUIT 1
+8 ;
ACTI ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD
+1 SET DA(1)=IBIEN
SET DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"","
SET DIC(0)="L"
SET X=$$NOW^XLFDT()
+2 SET DIC("DR")=".02////^S X=1;.03////^S X=IBNPI;.04////^S X=DUZ"
+3 DO FILE^DICN
+4 SET $PIECE(^IBA(355.93,IBIEN,0),U,14)=IBNPI
+5 QUIT
+6 ;
DEL ;NPI HAS BEEN DELETED
+1 ;If the user deletes the NPI this subroutine will determine why it was deleted and, if it was because it was found
+2 ;in a false identity situation, will mark it in history to never be used again.
+3 SET IBNPI=$GET(DIR("B"))
+4 KILL DIR
+5 SET DIR(0)="Y"
+6 SET DIR("A")="Are you sure you wish to delete this NPI"
+7 SET DIR("?")="You have indicated you wish to delete the NPI. This is a second chance check."
+8 DO ^DIR
+9 if Y(0)="NO"
GOTO XIT
+10 ;S DIR(0)="S^E:ERROR;V:VALID",DIR("A")="Was this a Valid NPI or an NPI entered in Error"
+11 ;S DIR("?",1)="An example of an NPI entered in error is if the entry person transposed numbers,"
+12 ;S DIR("?",2)="or if the NPI for one provider is accidentally assigned to a different provider."
+13 ;S DIR("?")="Enter an 'E' for Error or a 'V' for Valid."
+14 ;D ^DIR
+15 DO COMP
WRITE !,"This NPI will be designated as Entered in Error.",!
+16 ;I Y="V" S IBCHECK=2 D INACT W !,"The NPI is now inactive.",!
+17 ;Q:$D(DTOUT)!($D(DUOUT))
+18 SET IBOLDNPI=IBNPI
DO WARND(IBIEN,IBOLDNPI,IBKEY)
+19 QUIT
+20 ;
COMP ;COMPLETELY DELETE THE NPI
+1 ;This subroutine will delete the NPI from the file 355.93.
+2 SET OIEN=$ORDER(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,"A"),-1)
+3 DO DELNPI(IBIEN,OIEN)
+4 KILL ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA)
+5 SET IBRB=0
+6 ; Find the most recent status '0' (inactive) NPI entry in the list.
Begin DoDot:1
+7 NEW IBRBLST,IBRBTMP
+8 ; Don't want to roll back to the same number you are deleting.
+9 SET IBRBLST(IBOLDNPI)=""
+10 SET IBRBTMP="A"
+11 ; Go through each entry in reverse order
+12 FOR
SET IBRBTMP=$ORDER(^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP),-1)
if 'IBRBTMP
QUIT
Begin DoDot:2
+13 SET IBRBLST=^IBA(355.93,IBIEN,"NPISTATUS",IBRBTMP,0)
+14 ; If this is an 'active' entry then ignore it.
+15 IF $PIECE(IBRBLST,U,2)=1
QUIT
+16 ; If this entry does not have an NPI then ignore it.
+17 IF $PIECE(IBRBLST,U,3)=""
QUIT
+18 ;If this is an inactive entry then report it.
+19 IF $PIECE(IBRBLST,U,2)=0
SET IBRB=IBRBTMP
QUIT
+20 QUIT
End DoDot:2
if IBRB'=0
QUIT
+21 QUIT
End DoDot:1
+22 IF IBRB>0
DO ROLLBACK
+23 QUIT
+24 ;
DELNPI(IEN,OIEN) ;DELETE-INVALID removes NPI from file.
+1 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
+2 NEW DP,DM,DK,DL,DIEL
+3 SET DIE="^IBA(355.93,"
SET DA=IEN
SET DR="41.01////@"
+4 DO ^DIE
+5 SET DA(1)=IEN
SET DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"","
SET DA=OIEN
+6 DO ^DIK
+7 QUIT
+8 ;
INACT ;INACTIVATE AN ENTRY
+1 ;This subroutine makes two entries in the NPI multiple field:
+2 ;one for the deactivation of the old NPI and the second
+3 ;for the activation of a new NPI.
+4 SET DA(1)=IBIEN
SET DIC="^IBA(355.93,"_DA(1)_",""NPISTATUS"","
SET DIC(0)="L"
SET X=$$NOW^XLFDT()
+5 SET DIC("DR")=".02////^S X=0;.03////^S X=IBOLDNPI;.04////^S X=DUZ"
+6 DO FILE^DICN
+7 SET ^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA(1))=""
+8 KILL ^IBA(355.93,"NPI",IBOLDNPI,DA(1))
+9 SET $PIECE(^IBA(355.93,IBIEN,0),U,14)=""
+10 IF $GET(IBCHECK)<2
Begin DoDot:1
+11 DO ACTI
+12 SET ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))=""
+13 DO WARNR(IBIEN,IBOLDNPI,IBKEY)
End DoDot:1
+14 QUIT
+15 ;
ROLLBACK ;Rollback or delete NPI
+1 SET IBRBNPI=$PIECE(^IBA(355.93,IBIEN,"NPISTATUS",IBRB,0),U,3)
+2 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
+3 NEW DP,DM,DK,DL,DIEL
+4 SET DA(1)=IBIEN
SET DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"","
SET DA=IBRB
+5 DO ^DIK
+6 SET $PIECE(^IBA(355.93,IBIEN,0),U,14)=IBRBNPI
SET ^IBA(355.93,"NPI",IBRBNPI,IBIEN)=""
+7 QUIT
+8 ;
XIT ;CLEAN AND EXIT
+1 QUIT
+2 ;
XR ;Set the primary taxonomy code cross reference for field 42
+1 NEW ATAX
SET ATAX=""
+2 IF $DATA(^IBA(355.93,DA(1),"TAXONOMY","D"))
if X=1
Begin DoDot:1
+3 FOR
SET ATAX=$ORDER(^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX))
if ATAX=""
QUIT
Begin DoDot:2
+4 KILL ^IBA(355.93,DA(1),"TAXONOMY","D",1,ATAX)
+5 IF ATAX'=DA
SET $PIECE(^IBA(355.93,DA(1),"TAXONOMY",ATAX,0),U,2)=0
SET ^IBA(355.93,DA(1),"TAXONOMY","D",0,ATAX)=""
End DoDot:2
End DoDot:1
+6 SET ^IBA(355.93,DA(1),"TAXONOMY","D",X,DA)=""
+7 QUIT
+8 ;
KXR ;Kill primary taxonomy code cross reference for field 42
+1 NEW K
+2 FOR K=0,1
KILL ^IBA(355.93,DA(1),"TAXONOMY","D",K,DA)
+3 QUIT
+4 ;
WARNR(IBIEN,IBOLDNPI,IBKEY) ;Warn user that the old NPI that was replaced is currently used by an entry in the New Person file (#200)
+1 NEW IBIEN200
+2 if $GET(IBOLDNPI)=""
QUIT
+3 SET IBIEN200=$ORDER(^VA(200,"ANPI",IBOLDNPI,""))
+4 if IBIEN200=""
QUIT
+5 WRITE !!,"WARNING: NPI ",IBOLDNPI," is also associated with Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",!
+6 IF $ORDER(^XUSEC(IBKEY,""))=""
WRITE !!,"There are no holders of the ",IBKEY," security key on the VistA system. Contact your IRM department for further direction."
QUIT
+7 WRITE !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key."
+8 DO MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI)
+9 QUIT
+10 ;
WARND(IBIEN,IBOLDNPI,IBKEY) ;Warn user that the old NPI that was deleted is currently used by an entry in the New Person file (#200)
+1 NEW IBIEN200
+2 if $GET(IBOLDNPI)=""
QUIT
+3 SET IBIEN200=$ORDER(^VA(200,"ANPI",IBOLDNPI,""))
+4 if IBIEN200=""
QUIT
+5 WRITE !!,"WARNING: NPI ",IBOLDNPI," is also associated with VA Provider ",$$GET1^DIQ(200,IBIEN200,.01),".",!
+6 IF $ORDER(^XUSEC(IBKEY,""))=""
WRITE !!,"There are no holders of the ",IBKEY," security key on the VistA system. Contact your IRM department for further direction."
QUIT
+7 WRITE !,"A MailMan message has been sent to holders of the "_""""_IBKEY_""""_" security key."
+8 DO MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI)
+9 QUIT
+10 ;
MAILR(IBIEN,IBKEY,IBIEN200,IBOLDNPI) ;Send mailman message for replacement of NPI
+1 ;This subroutine is supported by IA# 10070
+2 ;Lookups in NEW PERSON file (#200) are supported by IA#10076
+3 NEW IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG
+4 SET IBIEN2=0
FOR
SET IBIEN2=$ORDER(^XUSEC(IBKEY,IBIEN2))
if IBIEN2=""
QUIT
SET XMY(IBIEN2)=""
+5 SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMSUB="NPI Replacement"
+6 SET IBMSG(1)="The NPI "_IBOLDNPI_" was changed to "_IBNPI_" for"
+7 SET IBMSG(2)=$$GET1^DIQ(355.93,IBIEN,.01)_" in the IB NON/OTHER VA BILLING PROVIDER"
+8 SET IBMSG(3)="file. The NPI "_IBOLDNPI_" is also associated with"
+9 SET IBMSG(4)=$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file."
+10 SET IBMSG(5)=""
+11 SET IBMSG(6)="The same change may need to be made to the NEW PERSON file using the"
+12 SET IBMSG(7)="Add/Edit NPI values for Providers option."
+13 SET XMTEXT="IBMSG("
DO ^XMD
+14 QUIT
+15 ;
MAILD(IBIEN,IBKEY,IBIEN200,IBOLDNPI) ;Send mailman message for deletion of an NPI
+1 ;This subroutine is supported by IA# 10070
+2 ;Lookups in NEW PERSON file (#200) are supported by IA#10076
+3 NEW IBIEN2,XMDUZ,XMSUB,XMTEXT,XMY,IBMSG,XMZ,XMMG
+4 SET IBIEN2=0
FOR
SET IBIEN2=$ORDER(^XUSEC(IBKEY,IBIEN2))
if IBIEN2=""
QUIT
SET XMY(IBIEN2)=""
+5 SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMSUB="NPI Deletion"
+6 SET IBMSG(1)="The NPI "_IBOLDNPI_" was deleted for "_$$GET1^DIQ(355.93,IBIEN,.01)
+7 SET IBMSG(2)="in the IB NON/OTHER VA BILLING PROVIDER file. The NPI "_IBOLDNPI_" is also"
+8 SET IBMSG(3)="associated with "_$$GET1^DIQ(200,IBIEN200,.01)_" in the NEW PERSON file."
+9 SET IBMSG(4)=""
+10 SET IBMSG(5)="The same change may need to be made to the NEW PERSON file using the"
+11 SET IBMSG(6)="Add/Edit NPI values for Providers option."
+12 SET XMTEXT="IBMSG("
DO ^XMD
+13 QUIT
