VBECDCM1 ;hoifo/gjc-VBECS MAPPING TABLE delete utilities.;Nov 21, 2002
;;2.0;VBEC;;Jun 05, 2015;Build 4
;
;Medical Device #:
;Note: The food and Drug Administration classifies this software as a
;medical device. As such, it may not be changed in any way.
;Modifications to this software may result in an adulterated medical
;device under 21CFR820, the use of which is considered to be a
;violation of US Federal Statutes. Acquiring and implementing this
;software through the Freedom of Information Act requires the
;implementer to assume total responsibility for the software, and
;become a registered manufacturer of a medical device, subject to FDA
;regulations.
;
;Call to $$NEWERR^%ZTER is supported by IA: 1621
;Call to IX^DIC is supported by IA: 10006
;Call to FILE^DIE is supported by IA: 2053
;Call to ^DIK is supported by IA: 10013
;Call to ^DIR is supported by IA: 10026
;Execution of ^%ZOSF("TEST") is supported by IA: 10096
;
EN613 ; decouple antibodies/antigens
S VBECFN=61.3,VBECNME="Antibodies/Antigens"
D ASK,XIT
Q
EN654 ; decouple transfusion reactions
S VBECFN=65.4,VBECNME="Transfusion Reactions"
D ASK,XIT
Q
ENP613 ; purge VistA antibodies/antigens
S VBECFN=61.3,VBECNME="Antibodies/Antigens"
D PURGALL K VBECFN,VBECNME
Q
ENP654 ; purge VistA transfusion reactions mapping
S VBECFN=65.4,VBECNME="Transfusion Reactions"
D PURGALL K VBECFN,VBECNME
Q
;
PURGALL ; purge all the records in the VBECS MAPPING TABLE (#6005) file
; initialize the error trap
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^VBECDCU1"
E S X="D ERR^VBECDCU1",@^%ZOSF("TRAP")
Q:'$$LOCK^VBECDCU2(6005)
N VBECXIT S VBECXIT=0
I $O(^VBEC(6005,"AB",VBECFN,""))'="" D Q:VBECXIT
.;Data has been mapped, ask user if purge should proceed.
.N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
.S DIR(0)="Y",DIR("B")="No"
.S DIR("A")=VBECNME_" have been mapped, are you sure you want to purge"
.S DIR("?")="Enter 'Yes' to purge "_VBECNME_", or 'No' to exit without purging."
.D ^DIR
.I $D(DIRUT)#2 S VBECXIT=1 Q
.S VBECXIT=$S(Y=0:1,1:0)
.;If the user takes the default of 'No', the value of Y is zero.
.;Set VBECXIT accordingly to exit without purging.
.Q
S DIK="^VBEC(6005,",CNT=0
W !,"Please be patient, this may take awhile"
S:VBECFN'=66.01 VBEC01=VBECFN_"-"
S:VBECFN=66.01 VBEC01=VBECFN
I VBEC01'=66.01 F S VBEC01=$O(^VBEC(6005,"B",VBEC01)) Q:VBEC01=""!(+VBEC01'=VBECFN) D PURGE(VBEC01,.CNT) ; not blood supplier
D:VBEC01=66.01 PURGE(VBEC01,.CNT) ; blood supplier
W:CNT !!,"Done, total number of records deleted: "_CNT
W:'CNT !!,"No record(s) to delete."
D UNLOCK^VBECDCU2(6005)
K %,CNT,DIC,VBEC01,X,Y
Q
;
PURGE(VBEC01,CNT) ; purge at the record level using DIK
; input: VBEC01=sub-file number or file number-ien VBEC MATCHING TABLE
; file.
; CNT=The number of records purged.
N %,DA,DIK,X,Y S DA=0,DIK="^VBEC(6005,"
F S DA=$O(^VBEC(6005,"B",VBEC01,DA)) Q:'DA D
.D ^DIK S CNT=CNT+1
.W:'(CNT#100) "." ; process is active
.Q
Q
;
SINGLE ; decouple relations for a single record
; initialize the error trap
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^VBECDCU1"
E S X="D ERR^VBECDCU1",@^%ZOSF("TRAP")
Q:'$$LOCK^VBECDCU2(6005)
S VBECFILE=$$ATTR^VBECDCU1() ; select data attribute family
I VBECFILE="^" D KILSIN Q
K D,DIC,DO S D="N",DIC="^VBEC(6005,",DIC(0)="QEFASZ",VBECFILE=+VBECFILE
S DIC("S")="N VBEC S VBEC=$G(^(0)) I $P(VBEC,U,5)'="""",(+$P(VBEC,U)=VBECFILE)"
S DIC("W")="W $S($P(^(0),U,3)'="""":"" (""_$P(^(0),U,3)_"")"",1:"""")"
D IX^DIC K D,DIC,DO I +Y=-1 D KILSIN Q
S VBECIEN=+Y,VBECREC=$P(Y(0),U,2)_" ("_$P(Y(0),U,3)_")"
D DECUP(VBECIEN)
W !!,"Mapping for "_VBECREC_" decoupled.",!
KILSIN D UNLOCK^VBECDCU2(6005) K VBECFILE,VBECIEN,VBECREC,X,Y
Q
;
ASK ; decouple records from the VBECS MAPPING TABLE (#6005) file
; initialize the error trap
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^VBECDCU1"
E S X="D ERR^VBECDCU1",@^%ZOSF("TRAP")
S Y=$$YN() Q:Y=0 ; user chooses not to decouple
S CNT=0 W !!?3,"Please be patient, this may take a while",!
Q:'$$LOCK^VBECDCU2(6005)
S VBECGUID=""
F S VBECGUID=$O(^VBEC(6005,"AB",VBECFN,VBECGUID)) Q:VBECGUID="" D
.S VBECIEN=0
.F S VBECIEN=$O(^VBEC(6005,"AB",VBECFN,VBECGUID,VBECIEN)) Q:'VBECIEN D
..D DECUP(VBECIEN)
..S CNT=CNT+1 W:'(CNT#100) "." ; process is active
..Q
.Q
W !?3,"Finished decoupling ",CNT," mapped records from the VBECS MAPPING TABLE (#6005)",!?3,"file. For VistA "_VBECNME_" data types."
D UNLOCK^VBECDCU2(6005)
Q
;
DECUP(Y) ; delete the STANDARD VBECS DATA (#.05), CHECKSUM (#.06), &
; TIMESTAMP (#.07) field level data (essentially unmap)
;input: Y=ien of record in file 6005
K VBECFDA S VBECFDA(8,6005,Y_",",.05)="@"
D FILE^DIE("E","VBECFDA(8)") K VBECFDA
Q
;
XIT ; kill and quit
K CNT,VBECFDA,VBECFN,VBECGUID,VBECIEN,VBECNME,X,Y
Q
;
YN() ; yes/no to decoupling question...
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="Y",DIR("A")="Are you sure you want to decouple mappings",DIR("B")="No"
S DIR("?")="Enter 'Yes' to decouple mappings, or 'No' to exit without decoupling mappings."
D ^DIR S:$D(DIRUT) Y=0
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECDCM1 5249 printed Sep 23, 2025@20:20:13 Page 2
VBECDCM1 ;hoifo/gjc-VBECS MAPPING TABLE delete utilities.;Nov 21, 2002
+1 ;;2.0;VBEC;;Jun 05, 2015;Build 4
+2 ;
+3 ;Medical Device #:
+4 ;Note: The food and Drug Administration classifies this software as a
+5 ;medical device. As such, it may not be changed in any way.
+6 ;Modifications to this software may result in an adulterated medical
+7 ;device under 21CFR820, the use of which is considered to be a
+8 ;violation of US Federal Statutes. Acquiring and implementing this
+9 ;software through the Freedom of Information Act requires the
+10 ;implementer to assume total responsibility for the software, and
+11 ;become a registered manufacturer of a medical device, subject to FDA
+12 ;regulations.
+13 ;
+14 ;Call to $$NEWERR^%ZTER is supported by IA: 1621
+15 ;Call to IX^DIC is supported by IA: 10006
+16 ;Call to FILE^DIE is supported by IA: 2053
+17 ;Call to ^DIK is supported by IA: 10013
+18 ;Call to ^DIR is supported by IA: 10026
+19 ;Execution of ^%ZOSF("TEST") is supported by IA: 10096
+20 ;
EN613 ; decouple antibodies/antigens
+1 SET VBECFN=61.3
SET VBECNME="Antibodies/Antigens"
+2 DO ASK
DO XIT
+3 QUIT
EN654 ; decouple transfusion reactions
+1 SET VBECFN=65.4
SET VBECNME="Transfusion Reactions"
+2 DO ASK
DO XIT
+3 QUIT
ENP613 ; purge VistA antibodies/antigens
+1 SET VBECFN=61.3
SET VBECNME="Antibodies/Antigens"
+2 DO PURGALL
KILL VBECFN,VBECNME
+3 QUIT
ENP654 ; purge VistA transfusion reactions mapping
+1 SET VBECFN=65.4
SET VBECNME="Transfusion Reactions"
+2 DO PURGALL
KILL VBECFN,VBECNME
+3 QUIT
+4 ;
PURGALL ; purge all the records in the VBECS MAPPING TABLE (#6005) file
+1 ; initialize the error trap
+2 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^VBECDCU1"
+3 IF '$TEST
SET X="D ERR^VBECDCU1"
SET @^%ZOSF("TRAP")
+4 if '$$LOCK^VBECDCU2(6005)
QUIT
+5 NEW VBECXIT
SET VBECXIT=0
+6 IF $ORDER(^VBEC(6005,"AB",VBECFN,""))'=""
Begin DoDot:1
+7 ;Data has been mapped, ask user if purge should proceed.
+8 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+9 SET DIR(0)="Y"
SET DIR("B")="No"
+10 SET DIR("A")=VBECNME_" have been mapped, are you sure you want to purge"
+11 SET DIR("?")="Enter 'Yes' to purge "_VBECNME_", or 'No' to exit without purging."
+12 DO ^DIR
+13 IF $DATA(DIRUT)#2
SET VBECXIT=1
QUIT
+14 SET VBECXIT=$SELECT(Y=0:1,1:0)
+15 ;If the user takes the default of 'No', the value of Y is zero.
+16 ;Set VBECXIT accordingly to exit without purging.
+17 QUIT
End DoDot:1
if VBECXIT
QUIT
+18 SET DIK="^VBEC(6005,"
SET CNT=0
+19 WRITE !,"Please be patient, this may take awhile"
+20 if VBECFN'=66.01
SET VBEC01=VBECFN_"-"
+21 if VBECFN=66.01
SET VBEC01=VBECFN
+22 ; not blood supplier
IF VBEC01'=66.01
FOR
SET VBEC01=$ORDER(^VBEC(6005,"B",VBEC01))
if VBEC01=""!(+VBEC01'=VBECFN)
QUIT
DO PURGE(VBEC01,.CNT)
+23 ; blood supplier
if VBEC01=66.01
DO PURGE(VBEC01,.CNT)
+24 if CNT
WRITE !!,"Done, total number of records deleted: "_CNT
+25 if 'CNT
WRITE !!,"No record(s) to delete."
+26 DO UNLOCK^VBECDCU2(6005)
+27 KILL %,CNT,DIC,VBEC01,X,Y
+28 QUIT
+29 ;
PURGE(VBEC01,CNT) ; purge at the record level using DIK
+1 ; input: VBEC01=sub-file number or file number-ien VBEC MATCHING TABLE
+2 ; file.
+3 ; CNT=The number of records purged.
+4 NEW %,DA,DIK,X,Y
SET DA=0
SET DIK="^VBEC(6005,"
+5 FOR
SET DA=$ORDER(^VBEC(6005,"B",VBEC01,DA))
if 'DA
QUIT
Begin DoDot:1
+6 DO ^DIK
SET CNT=CNT+1
+7 ; process is active
if '(CNT#100)
WRITE "."
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
SINGLE ; decouple relations for a single record
+1 ; initialize the error trap
+2 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^VBECDCU1"
+3 IF '$TEST
SET X="D ERR^VBECDCU1"
SET @^%ZOSF("TRAP")
+4 if '$$LOCK^VBECDCU2(6005)
QUIT
+5 ; select data attribute family
SET VBECFILE=$$ATTR^VBECDCU1()
+6 IF VBECFILE="^"
DO KILSIN
QUIT
+7 KILL D,DIC,DO
SET D="N"
SET DIC="^VBEC(6005,"
SET DIC(0)="QEFASZ"
SET VBECFILE=+VBECFILE
+8 SET DIC("S")="N VBEC S VBEC=$G(^(0)) I $P(VBEC,U,5)'="""",(+$P(VBEC,U)=VBECFILE)"
+9 SET DIC("W")="W $S($P(^(0),U,3)'="""":"" (""_$P(^(0),U,3)_"")"",1:"""")"
+10 DO IX^DIC
KILL D,DIC,DO
IF +Y=-1
DO KILSIN
QUIT
+11 SET VBECIEN=+Y
SET VBECREC=$PIECE(Y(0),U,2)_" ("_$PIECE(Y(0),U,3)_")"
+12 DO DECUP(VBECIEN)
+13 WRITE !!,"Mapping for "_VBECREC_" decoupled.",!
KILSIN DO UNLOCK^VBECDCU2(6005)
KILL VBECFILE,VBECIEN,VBECREC,X,Y
+1 QUIT
+2 ;
ASK ; decouple records from the VBECS MAPPING TABLE (#6005) file
+1 ; initialize the error trap
+2 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^VBECDCU1"
+3 IF '$TEST
SET X="D ERR^VBECDCU1"
SET @^%ZOSF("TRAP")
+4 ; user chooses not to decouple
SET Y=$$YN()
if Y=0
QUIT
+5 SET CNT=0
WRITE !!?3,"Please be patient, this may take a while",!
+6 if '$$LOCK^VBECDCU2(6005)
QUIT
+7 SET VBECGUID=""
+8 FOR
SET VBECGUID=$ORDER(^VBEC(6005,"AB",VBECFN,VBECGUID))
if VBECGUID=""
QUIT
Begin DoDot:1
+9 SET VBECIEN=0
+10 FOR
SET VBECIEN=$ORDER(^VBEC(6005,"AB",VBECFN,VBECGUID,VBECIEN))
if 'VBECIEN
QUIT
Begin DoDot:2
+11 DO DECUP(VBECIEN)
+12 ; process is active
SET CNT=CNT+1
if '(CNT#100)
WRITE "."
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 WRITE !?3,"Finished decoupling ",CNT," mapped records from the VBECS MAPPING TABLE (#6005)",!?3,"file. For VistA "_VBECNME_" data types."
+16 DO UNLOCK^VBECDCU2(6005)
+17 QUIT
+18 ;
DECUP(Y) ; delete the STANDARD VBECS DATA (#.05), CHECKSUM (#.06), &
+1 ; TIMESTAMP (#.07) field level data (essentially unmap)
+2 ;input: Y=ien of record in file 6005
+3 KILL VBECFDA
SET VBECFDA(8,6005,Y_",",.05)="@"
+4 DO FILE^DIE("E","VBECFDA(8)")
KILL VBECFDA
+5 QUIT
+6 ;
XIT ; kill and quit
+1 KILL CNT,VBECFDA,VBECFN,VBECGUID,VBECIEN,VBECNME,X,Y
+2 QUIT
+3 ;
YN() ; yes/no to decoupling question...
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to decouple mappings"
SET DIR("B")="No"
+3 SET DIR("?")="Enter 'Yes' to decouple mappings, or 'No' to exit without decoupling mappings."
+4 DO ^DIR
if $DATA(DIRUT)
SET Y=0
+5 QUIT Y
+6 ;
