- 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 Dec 13, 2024@02:11:49 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