Changeset 623 for WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP82.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP82.m (modified) (1 diff)

WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP82.m

@@ -1 @@
-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**;21-MAR-94;Build 39
-        ;;Per VHA Directive 2004-038, 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)
-        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
-        I Y="E" D COMP W !,"The NPI has been deleted.",!
-        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
+IBCEP82 ;ALB/CLT, Special cross references and data entry for fields in file 355.93 ; 14 Apr 2006  9:41 AM
+ ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16
+ ;
+ ; 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 ;Routine primary entry point
+ N DTOUT,DUOUT,DIR,DIE,DIC,DR,X,Y
+ N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB
+ S IBIEN=DA,IBOLDNPI=""
+EN1 ;
+ 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)=$P($G(^IBA(355.93,DA,0)),U,14)
+ D ^DIR S IBCHECK=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)!(X="")!(Y=IBOLDNPI) G XIT
+ S IBNPI=Y
+ I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,"Not a valid NPI.  Please try again.",! G EN1
+ I $$NPIUSED^IBCEP81(IBNPI) G EN1
+ 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)=""
+ G XIT
+ ;
+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=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
+ I Y="E" D COMP W !,"The NPI has been deleted.",!
+ I Y="V" S IBCHECK=2 D INACT W !,"The NPI is now inactive.",!
+ 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 ACTI
+ S ^IBA(355.93,"NPIHISTORY",IBNPI,DA(1))=""
+ 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