- 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 Feb 19, 2025@00:10:35 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 ;