VBECDCM2 ;hoifo/gjc-VBECS MAPPING TABLE add, edit & 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 FILE^DIE is supported by IA: 2053
;Call to UPDATE^DIE is supported by IA: 2053
;Call to ^DIK is supported by IA: 10013
;Call to $$ROOT^DILFD is supported by IA: 2055
;Call to $$NOW^XLFDT is supported by IA: 10103
;Execution of ^%ZOSF("TEST") is supported by IA: 10096
;
EN654 ; handle transfusion reactions.
I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^VBECDCU1"
E S X="D ERR^VBECDCU1",@^%ZOSF("TRAP")
;
;initially add trans. reactions to file 6005
;
I +$O(^VBEC(6005,"AA","65.4-"))'=65.4 D
.Q:'$$LOCK^VBECDCU2(65.4)
.W !!,"Adding site configured 'Transfusion Reaction' information into the VBECS MAPPING",!,"TABLE file (#6005)."
.S (CNT,VBECY)=0
.F S VBECY=$O(^LAB(65.4,VBECY)) Q:'VBECY D ;trans. react.
..S VBECY(0)=$G(^LAB(65.4,VBECY,0)) Q:$P(VBECY(0),U,2)'="T"
..S CNT=CNT+1 D POP6005(65.4,VBECY,$P(VBECY(0),U),$P(VBECY(0),U,3))
..W:'(CNT#100) "."
..Q
.D UNLOCK^VBECDCU2(65.4)
.Q
S:+$O(^VBEC(6005,"AA","65.4-"))=65.4 VBECFLG=1
I W !!,CNT_" transfusion record"_$S(CNT=1:"",1:"s")_" added.",!
;
;handle transfusion reaction edit, and add events here
;
E D
.S VBECFLG=0 Q:'$$LOCK^VBECDCU2(65.4) ;RLM 10/27/05
.S VBECY=0 F S VBECY=$O(^LAB(65.4,VBECY)) Q:'VBECY D
..S VBECY(0)=$G(^LAB(65.4,VBECY,0)),VBEC01=65.4_"-"_VBECY
..S VBECIEN=+$O(^VBEC(6005,"B",VBEC01,0)),VBECIEN(0)=$G(^VBEC(6005,VBECIEN,0))
..;
..;if transfusion reaction not filed in 6005, add it
..I 'VBECIEN,($P(VBECY(0),U,2)="T") S VBECFLG=1 D POP6005(65.4,VBECY,$P(VBECY(0),U),$P(VBECY(0),U,3)) ;if added, no need to perform edit check
..Q:'VBECIEN
..;
..;check if the name or identifier attribute has been edited
..;if parent record changes from TRANSFUSION REACTION delete from 6005
..I $P(VBECY(0),U,2)'="T" D Q
...K DA,DIK S DA=VBECIEN,DIK="^VBEC(6005,",VBECFLG=1 D ^DIK
...K %,DA,DIC,DIK,X,Y
...Q
..S VBECTOT=0,VBECTOT=$$CHECKSUM^VBECDCU2($P(VBECY(0),U))
..S VBECTOT=VBECTOT+$$CHECKSUM^VBECDCU2($P(VBECY(0),U,3))
..I VBECTOT'=$P(VBECIEN(0),U,6) D S VBECFLG=1 K VBECTOT
...S:$P(VBECY(0),U)'=$P(VBECIEN(0),U,2) VBECFDA(6005,VBECIEN_",",.02)=$P(VBECY(0),U)
...S:$P(VBECY(0),U,3)'=$P(VBECIEN(0),U,3) VBECFDA(6005,VBECIEN_",",.03)=$P(VBECY(0),U,3)
...S VBECFDA(6005,VBECIEN_",",.05)="@"
...S VBECFDA(6005,VBECIEN_",",.06)=VBECTOT
...S VBECFDA(6005,VBECIEN_",",.07)=+$E($$NOW^XLFDT(),1,12)
...D FILE^DIE("","VBECFDA")
...Q
..Q
.D UNLOCK^VBECDCU2(65.4)
.Q
; handle delete transaction reaction actions here
D DELETE(65.4)
I $G(VBECFLG) W !!,"Transfusion Reaction information updated.",! ;RLM 10/27/05
E W !!,"Transfusion Reaction information current, not updated.",!
D XIT
Q
;
XIT ; unlock, kill, and quit
L -^VBEC(6005)
K CNT,DIR,DIRUT,DTOUT,DUOUT,VBEC01,VBECANTI,VBECFLD,VBECFLE,VBECFLG,VBECHLP,VBECIEN,VBECRT,VBECTMP,VBECXIT,VBECX,VBECY,VBECYN,X,Y
K ^TMP($J,"VBEC SUPPLIER")
Q
;
POP6005(VBECFILE,VBECIEN,VBEC01,VBECID,VBECANTI) ; Populate the
; VBECS MAPPING TABLE file (#6005) with antigen/antibody & blood
; transfusion reaction data.
; Input: VBECFILE=VistA file referenced (required)
; VBECIEN=VistA internal entry number referenced
; VBEC01=value of the .01 field (required, external)
; VBECID=file identifier
; VBECANTI=antibody/antigen identifier
;
S VBECTOT=0,VBECTOT=$$CHECKSUM^VBECDCU2(VBEC01)
S VBECTOT=VBECTOT+$$CHECKSUM^VBECDCU2(VBECID)
S:$G(VBECANTI)'="" VBECTOT=VBECTOT+$$CHECKSUM^VBECDCU2(VBECANTI)
F S COUNT=(+$O(^VBEC(6005,$C(32)),-1)+1) Q:'($D(^VBEC(6005,COUNT,0))#2)
S VBECFDA(6005,"+"_COUNT_",",.01)=VBECFILE_"-"_VBECIEN
S VBECFDA(6005,"+"_COUNT_",",.02)=VBEC01
S:$G(VBECID)'="" VBECFDA(6005,"+"_COUNT_",",.03)=VBECID
S:$G(VBECANTI)'="" VBECFDA(6005,"+"_COUNT_",",.04)=VBECANTI
S VBECFDA(6005,"+"_COUNT_",",.06)=VBECTOT
S VBECFDA(6005,"+"_COUNT_",",.07)=+$E($$NOW^XLFDT(),1,12)
D UPDATE^DIE("E","VBECFDA") K COUNT,VBECFDA,VBECTOT
Q
;
DELETE(VBECFN) ; delete individual record from file 6005 that no longer exist
; in their parent files.
;Input: VBECFN=the file number of the parent file
;return: VBECFLG=indicates if updates (deletions) to file 6005 occurred
N VBEC6005,VBECIEN,VBECRT,VBECX K %,DA,DIC,DIK,X,Y
S VBECX=VBECFN_"-",VBECRT=$$ROOT^DILFD(VBECFN,"",1)
F S VBECX=$O(^VBEC(6005,"B",VBECX)) Q:VBECX=""!(+VBECX'=VBECFN) D
.S VBEC6005=$O(^VBEC(6005,"B",VBECX,0)) Q:VBEC6005=0
.S VBECIEN=+$P(VBECX,"-",2)
.I $D(@VBECRT@(VBECIEN,0))#2 Q ;data resides in the parent file
.S DIK="^VBEC(6005,",DA=VBEC6005,VBECFLG=1 D ^DIK K %,DA,DIC,DIK,X,Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECDCM2 5362 printed Dec 13, 2024@02:44:04 Page 2
VBECDCM2 ;hoifo/gjc-VBECS MAPPING TABLE add, edit & 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 FILE^DIE is supported by IA: 2053
+16 ;Call to UPDATE^DIE is supported by IA: 2053
+17 ;Call to ^DIK is supported by IA: 10013
+18 ;Call to $$ROOT^DILFD is supported by IA: 2055
+19 ;Call to $$NOW^XLFDT is supported by IA: 10103
+20 ;Execution of ^%ZOSF("TEST") is supported by IA: 10096
+21 ;
EN654 ; handle transfusion reactions.
+1 IF $$NEWERR^%ZTER
NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^VBECDCU1"
+2 IF '$TEST
SET X="D ERR^VBECDCU1"
SET @^%ZOSF("TRAP")
+3 ;
+4 ;initially add trans. reactions to file 6005
+5 ;
+6 IF +$ORDER(^VBEC(6005,"AA","65.4-"))'=65.4
Begin DoDot:1
+7 if '$$LOCK^VBECDCU2(65.4)
QUIT
+8 WRITE !!,"Adding site configured 'Transfusion Reaction' information into the VBECS MAPPING",!,"TABLE file (#6005)."
+9 SET (CNT,VBECY)=0
+10 ;trans. react.
FOR
SET VBECY=$ORDER(^LAB(65.4,VBECY))
if 'VBECY
QUIT
Begin DoDot:2
+11 SET VBECY(0)=$GET(^LAB(65.4,VBECY,0))
if $PIECE(VBECY(0),U,2)'="T"
QUIT
+12 SET CNT=CNT+1
DO POP6005(65.4,VBECY,$PIECE(VBECY(0),U),$PIECE(VBECY(0),U,3))
+13 if '(CNT#100)
WRITE "."
+14 QUIT
End DoDot:2
+15 DO UNLOCK^VBECDCU2(65.4)
+16 QUIT
End DoDot:1
+17 if +$ORDER(^VBEC(6005,"AA","65.4-"))=65.4
SET VBECFLG=1
+18 IF $TEST
WRITE !!,CNT_" transfusion record"_$SELECT(CNT=1:"",1:"s")_" added.",!
+19 ;
+20 ;handle transfusion reaction edit, and add events here
+21 ;
+22 IF '$TEST
Begin DoDot:1
+23 ;RLM 10/27/05
SET VBECFLG=0
if '$$LOCK^VBECDCU2(65.4)
QUIT
+24 SET VBECY=0
FOR
SET VBECY=$ORDER(^LAB(65.4,VBECY))
if 'VBECY
QUIT
Begin DoDot:2
+25 SET VBECY(0)=$GET(^LAB(65.4,VBECY,0))
SET VBEC01=65.4_"-"_VBECY
+26 SET VBECIEN=+$ORDER(^VBEC(6005,"B",VBEC01,0))
SET VBECIEN(0)=$GET(^VBEC(6005,VBECIEN,0))
+27 ;
+28 ;if transfusion reaction not filed in 6005, add it
+29 ;if added, no need to perform edit check
IF 'VBECIEN
IF ($PIECE(VBECY(0),U,2)="T")
SET VBECFLG=1
DO POP6005(65.4,VBECY,$PIECE(VBECY(0),U),$PIECE(VBECY(0),U,3))
+30 if 'VBECIEN
QUIT
+31 ;
+32 ;check if the name or identifier attribute has been edited
+33 ;if parent record changes from TRANSFUSION REACTION delete from 6005
+34 IF $PIECE(VBECY(0),U,2)'="T"
Begin DoDot:3
+35 KILL DA,DIK
SET DA=VBECIEN
SET DIK="^VBEC(6005,"
SET VBECFLG=1
DO ^DIK
+36 KILL %,DA,DIC,DIK,X,Y
+37 QUIT
End DoDot:3
QUIT
+38 SET VBECTOT=0
SET VBECTOT=$$CHECKSUM^VBECDCU2($PIECE(VBECY(0),U))
+39 SET VBECTOT=VBECTOT+$$CHECKSUM^VBECDCU2($PIECE(VBECY(0),U,3))
+40 IF VBECTOT'=$PIECE(VBECIEN(0),U,6)
Begin DoDot:3
+41 if $PIECE(VBECY(0),U)'=$PIECE(VBECIEN(0),U,2)
SET VBECFDA(6005,VBECIEN_",",.02)=$PIECE(VBECY(0),U)
+42 if $PIECE(VBECY(0),U,3)'=$PIECE(VBECIEN(0),U,3)
SET VBECFDA(6005,VBECIEN_",",.03)=$PIECE(VBECY(0),U,3)
+43 SET VBECFDA(6005,VBECIEN_",",.05)="@"
+44 SET VBECFDA(6005,VBECIEN_",",.06)=VBECTOT
+45 SET VBECFDA(6005,VBECIEN_",",.07)=+$EXTRACT($$NOW^XLFDT(),1,12)
+46 DO FILE^DIE("","VBECFDA")
+47 QUIT
End DoDot:3
SET VBECFLG=1
KILL VBECTOT
+48 QUIT
End DoDot:2
+49 DO UNLOCK^VBECDCU2(65.4)
+50 QUIT
End DoDot:1
+51 ; handle delete transaction reaction actions here
+52 DO DELETE(65.4)
+53 ;RLM 10/27/05
IF $GET(VBECFLG)
WRITE !!,"Transfusion Reaction information updated.",!
+54 IF '$TEST
WRITE !!,"Transfusion Reaction information current, not updated.",!
+55 DO XIT
+56 QUIT
+57 ;
XIT ; unlock, kill, and quit
+1 LOCK -^VBEC(6005)
+2 KILL CNT,DIR,DIRUT,DTOUT,DUOUT,VBEC01,VBECANTI,VBECFLD,VBECFLE,VBECFLG,VBECHLP,VBECIEN,VBECRT,VBECTMP,VBECXIT,VBECX,VBECY,VBECYN,X,Y
+3 KILL ^TMP($JOB,"VBEC SUPPLIER")
+4 QUIT
+5 ;
POP6005(VBECFILE,VBECIEN,VBEC01,VBECID,VBECANTI) ; Populate the
+1 ; VBECS MAPPING TABLE file (#6005) with antigen/antibody & blood
+2 ; transfusion reaction data.
+3 ; Input: VBECFILE=VistA file referenced (required)
+4 ; VBECIEN=VistA internal entry number referenced
+5 ; VBEC01=value of the .01 field (required, external)
+6 ; VBECID=file identifier
+7 ; VBECANTI=antibody/antigen identifier
+8 ;
+9 SET VBECTOT=0
SET VBECTOT=$$CHECKSUM^VBECDCU2(VBEC01)
+10 SET VBECTOT=VBECTOT+$$CHECKSUM^VBECDCU2(VBECID)
+11 if $GET(VBECANTI)'=""
SET VBECTOT=VBECTOT+$$CHECKSUM^VBECDCU2(VBECANTI)
+12 FOR
SET COUNT=(+$ORDER(^VBEC(6005,$CHAR(32)),-1)+1)
if '($DATA(^VBEC(6005,COUNT,0))#2)
QUIT
+13 SET VBECFDA(6005,"+"_COUNT_",",.01)=VBECFILE_"-"_VBECIEN
+14 SET VBECFDA(6005,"+"_COUNT_",",.02)=VBEC01
+15 if $GET(VBECID)'=""
SET VBECFDA(6005,"+"_COUNT_",",.03)=VBECID
+16 if $GET(VBECANTI)'=""
SET VBECFDA(6005,"+"_COUNT_",",.04)=VBECANTI
+17 SET VBECFDA(6005,"+"_COUNT_",",.06)=VBECTOT
+18 SET VBECFDA(6005,"+"_COUNT_",",.07)=+$EXTRACT($$NOW^XLFDT(),1,12)
+19 DO UPDATE^DIE("E","VBECFDA")
KILL COUNT,VBECFDA,VBECTOT
+20 QUIT
+21 ;
DELETE(VBECFN) ; delete individual record from file 6005 that no longer exist
+1 ; in their parent files.
+2 ;Input: VBECFN=the file number of the parent file
+3 ;return: VBECFLG=indicates if updates (deletions) to file 6005 occurred
+4 NEW VBEC6005,VBECIEN,VBECRT,VBECX
KILL %,DA,DIC,DIK,X,Y
+5 SET VBECX=VBECFN_"-"
SET VBECRT=$$ROOT^DILFD(VBECFN,"",1)
+6 FOR
SET VBECX=$ORDER(^VBEC(6005,"B",VBECX))
if VBECX=""!(+VBECX'=VBECFN)
QUIT
Begin DoDot:1
+7 SET VBEC6005=$ORDER(^VBEC(6005,"B",VBECX,0))
if VBEC6005=0
QUIT
+8 SET VBECIEN=+$PIECE(VBECX,"-",2)
+9 ;data resides in the parent file
IF $DATA(@VBECRT@(VBECIEN,0))#2
QUIT
+10 SET DIK="^VBEC(6005,"
SET DA=VBEC6005
SET VBECFLG=1
DO ^DIK
KILL %,DA,DIC,DIK,X,Y
End DoDot:1
+11 QUIT
+12 ;
