BSTSRPC1 ;GDIT/HS/BEE - SNOMED Utilities - RPC Calls ; 10 Aug 2012 9:24 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
DETAIL(DATA,DTSID) ;EP - BSTS GET CONCEPT DETAIL
;
;Description
; Returns the detail for a passed in concept
;
;Input
; DTSID - The internal DTS IEN
;
;Output
; ^TMP("BSTSRPC1") - Name of global (passed by reference) in which the data is stored.
;
;Variables Used
; UID - Unique TMP global subscript.
;
N UID,II,STS,SVAR,REC,CIEN,CONCID
;
I $G(DTSID)="" S BMXSEC="BSTS GET CONCEPT DETAIL - DTSID is Null" Q
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BSTSRPC1",UID))
K @DATA
S II=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPC1 D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
D HDR
;
;Look for the entry in local cache
S CONCID="",CIEN=$O(^BSTS(9002318.4,"D",36,DTSID,""))
I CIEN]"" S CONCID=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I")
;
;Perform local lookup
I CONCID]"" S STS=$$CNCLKP^BSTSAPI("SVAR",CONCID)
;
;Perform lookup
I CONCID="" S STS=$$DTSLKP^BSTSAPI("SVAR",DTSID)
;
;Output Results
S REC=1 I $D(SVAR(REC)) D
. NEW PRBD,PRBT,CONC,DTS,FSND,FSNT,PRED,PRET
. NEW ICD,LAT,DFSTS,REPI,PAF,SEL
. ;
. ;Problem Description and Term
. S PRBD=$G(SVAR(REC,"PRB","DSC"))
. S PRBT=$G(SVAR(REC,"PRB","TRM"))
. S CONC=$G(SVAR(REC,"CON"))
. S DTS=$G(SVAR(REC,"DTS"))
. S FSND=$G(SVAR(REC,"FSN","DSC"))
. S FSNT=$G(SVAR(REC,"FSN","TRM"))
. S PRED=$G(SVAR(REC,"PRE","DSC"))
. S PRET=$G(SVAR(REC,"PRE","TRM"))
. S LAT=$S($G(SVAR(REC,"LAT"))=1:1,1:0)
. S DFSTS=$G(SVAR(REC,"STS"))
. S REPI=$S($G(SVAR(REC,"EPI"))=1:1,1:0)
. S PAF=$S($G(SVAR(REC,"ABN"))=1:1,1:0)
. S SEL=$S($G(SVAR(REC,"PAS"))=1:"Y",1:"")
. ;
. ;ICD
. S ICD="" I $D(SVAR(REC,"ICD")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(SVAR(REC,"ICD",ICNT)) Q:ICNT="" D
... NEW ICDE
... S ICDE=$G(SVAR(REC,"ICD",ICNT,"COD"))
... S ICD=ICD_$S(ICD]"":$C(28),1:"")_ICDE
. ;
. ;Save entry
. S II=II+1,@DATA@(II)=PRBD_U_PRBT_U_PRED_U_PRET_U_CONC_U_DTS_U_FSND_U_FSNT
. S @DATA@(II)=@DATA@(II)_U_ICD_U_LAT_U_DFSTS_U_REPI_U_PAF_U_SEL_$C(30)
;
DONE ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
TAHEAD(DATA,NMID,COUNT,SEARCH,SUBSETS) ;EP - BSTS SEARCH TYPE AHEAD
;
;Description
; This call returns some recommended concepts based on what the user has typed
; in so far. Since the call has to be very fast, straight global reads are being
; performed instead of FileMan utility reads.
;
;Input
; NMID - External codeset namespace id
; COUNT - Number of results to return
; SEARCH - String to search on
; SUBSET(S) - Subsets to limit results to - delimit subsets by "~"
;
;Output
; ^TMP("BSTSRPC1") - Name of global (passed by reference) in which the data is stored.
;
;Variables Used
; UID - Unique TMP global subscript.
;
N UID,II,WORD,WRD,TIEN,SUBLST,I,P,SUB,FND,CIEN,R,CNT,FLVL,UPTRM,UPSRC,OWRD,TRM,OWLST
;
;Check input variables
S:$G(NMID)="" NMID=36 ;Default to SNOMED
S:$G(COUNT)="" COUNT=10
I $TR($G(SEARCH)," ")="" S BMXSEC="BSTS SEARCH TYPE AHEAD - SEARCH is Null" Q
S SUBSETS=$G(SUBSETS)
;
;Implement SNOMED galaxy filtering
I NMID=36,SUBSETS="" S SUBSETS="IHS PROBLEM ALL SNOMED"
;
;Put subsets in an array
I $TR(SUBSETS,"~")]"" F I=1:1:$L(SUBSETS,"~") S SUB=$P(SUBSETS,"~",I) I SUB]"" S SUBLST(SUB)=""
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BSTSRPC1",UID))
K @DATA
S II=0,CNT=1
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSRPC1 D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
S @DATA@(0)="T04096RESULTS"_$C(30)
;
;Process first word in the string to establish base list
S UPSRC=$$UP^XLFSTR(SEARCH)
S WORD=$P(UPSRC," ") I WORD="" G XTAHEAD
S OWRD=$S($L(UPSRC," ")>1:0,1:1)
;
;Match check
S WRD=$$PREV(WORD) F S WRD=$O(^BSTS(9002318.3,"E",NMID,WRD)) Q:(WRD="")!(WRD'[WORD) D I OWRD,CNT>COUNT Q
. ;
. S TIEN="" F S TIEN=$O(^BSTS(9002318.3,"E",NMID,WRD,TIEN)) Q:TIEN="" D I OWRD,CNT>COUNT Q
.. ;
.. ;Subset check
.. S FND="" I $TR(SUBSETS,"~")]"" D Q:FND=""
... S CIEN=$P($G(^BSTS(9002318.3,TIEN,0)),U,3) Q:CIEN=""
... S SUB="" F S SUB=$O(SUBLST(SUB)) Q:SUB="" D I FND Q
.... I $D(^BSTS(9002318.4,CIEN,4,"B",SUB)) S FND=1
.. ;
.. ;Handle single word entry
.. I OWRD D Q
... I '$D(OWLST($$MIXC(WRD))) S R("S",99999-CNT,$$MIXC(WRD))="",OWLST($$MIXC(WRD))="",CNT=CNT+1
.. ;
.. ;Filter out FSN for SNOMED
.. I NMID=36,$P($G(^BSTS(9002318.3,TIEN,0)),U,9)="F" Q
.. ;
.. ;Set up the entry
.. S UPTRM=$$UP^XLFSTR($P($G(^BSTS(9002318.3,TIEN,1)),U)) Q:UPTRM=""
.. S R("R",UPTRM)=TIEN_U_$S(WRD=WORD:3,1:1)
.. S CNT=CNT+1
;
;Now loop through remaining words and filter
;
;Process remaining words
I 'OWRD,$D(R)>9 F P=2:1:$L(UPSRC," ") S WORD=$P(UPSRC," ",P) I WORD]"" D
. S (FND,UPTRM)="" F S UPTRM=$O(R("R",UPTRM)) Q:UPTRM="" D
.. S FND="" F I=1:1:$L(UPTRM," ") S WRD=$P(UPTRM," ",I) I WRD]"",$E(WRD,1,$L(WORD))=WORD D S FND=1 Q
... S $P(R("R",UPTRM),U,2)=$P(R("R",UPTRM),U,2)+$S(WRD=WORD:3,1:1)
.. I 'FND K R("R",UPTRM)
. Q
;
;Add extra weighting
I 'OWRD S UPTRM="" F S UPTRM=$O(R("R",UPTRM)) Q:UPTRM="" D
. I UPSRC=UPTRM S $P(R("R",UPTRM),U,2)=$P(R("R",UPTRM),U,2)+100
. F I=1:1:$L(UPSRC," ") D
.. I $E($P(UPTRM," ",I),1,$L($P(UPSRC," ",I)))=$P(UPSRC," ",I) S $P(R("R",UPTRM),U,2)=$P(R("R",UPTRM),U,2)+5
. S TIEN=$P(R("R",UPTRM),U),TRM=$P($G(^BSTS(9002318.3,TIEN,1)),U) Q:TRM=""
. S R("S",$P(R("R",UPTRM),U,2),TRM)=""
. K R("R",UPTRM)
;
;Now output
S R="" F S R=$O(R("S",R),-1) Q:R="" D I II'<COUNT Q
. S TRM="" F S TRM=$O(R("S",R,TRM)) Q:TRM="" D I II'<COUNT Q
.. S II=II+1,@DATA@(II)=TRM_$C(30)
;
XTAHEAD ;
S II=II+1,@DATA@(II)=$C(31)
Q
;
MIXC(WORD) ;Convert to mix case
;
Q $E(WORD,1)_$$LOW^XLFSTR($E(WORD,2,9999))
;
PREV(WORD) ;Return string right before passed in string
;
NEW L,A,LST
;
;Get last character
S L=$E(WORD,$L(WORD)) Q:L="" ""
;
;Get ASCII of previous character
S A=$A(L) S:A>1 A=A-1
;
;Define highest ASCII
S LST=$C(65535)
;
;Return word string just before word
S WORD=$E(WORD,1,$L(WORD)-1)_$C(A)_LST_LST_LST_LST
;
Q WORD
;
HDR ;
NEW HDR
S HDR="T00050PRB_DSC^T00250PRB_TRM^T00050PREF_DSC^T00250PREF_TRM^T00050CONCID^T00030DTSID^T00050FSN_DSC^T00250FSN_TRM"
S HDR=HDR_"^T04096ICD^T00001PROMPT_LATERALITY^T00020DEFAULT_STATUS^T00001REQUIRE_EPISODICITY^T00001PROMPT_AF^T00001SELECTABLE"
S @DATA@(0)=HDR_$C(30)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
BSTSRPC1 ;GDIT/HS/BEE - SNOMED Utilities - RPC Calls ; 10 Aug 2012 9:24 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 ;
+3 QUIT
+4 ;
DETAIL(DATA,DTSID) ;EP - BSTS GET CONCEPT DETAIL
+1 ;
+2 ;Description
+3 ; Returns the detail for a passed in concept
+4 ;
+5 ;Input
+6 ; DTSID - The internal DTS IEN
+7 ;
+8 ;Output
+9 ; ^TMP("BSTSRPC1") - Name of global (passed by reference) in which the data is stored.
+10 ;
+11 ;Variables Used
+12 ; UID - Unique TMP global subscript.
+13 ;
+14 NEW UID,II,STS,SVAR,REC,CIEN,CONCID
+15 ;
+16 IF $GET(DTSID)=""
SET BMXSEC="BSTS GET CONCEPT DETAIL - DTSID is Null"
QUIT
+17 ;
+18 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+19 SET DATA=$NAME(^TMP("BSTSRPC1",UID))
+20 KILL @DATA
+21 SET II=0
+22 ;
+23 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSRPC1 D UNWIND^%ZTER"
+24 ;
+25 DO HDR
+26 ;
+27 ;Look for the entry in local cache
+28 SET CONCID=""
SET CIEN=$ORDER(^BSTS(9002318.4,"D",36,DTSID,""))
+29 IF CIEN]""
SET CONCID=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I")
+30 ;
+31 ;Perform local lookup
+32 IF CONCID]""
SET STS=$$CNCLKP^BSTSAPI("SVAR",CONCID)
+33 ;
+34 ;Perform lookup
+35 IF CONCID=""
SET STS=$$DTSLKP^BSTSAPI("SVAR",DTSID)
+36 ;
+37 ;Output Results
+38 SET REC=1
IF $DATA(SVAR(REC))
Begin DoDot:1
+39 NEW PRBD,PRBT,CONC,DTS,FSND,FSNT,PRED,PRET
+40 NEW ICD,LAT,DFSTS,REPI,PAF,SEL
+41 ;
+42 ;Problem Description and Term
+43 SET PRBD=$GET(SVAR(REC,"PRB","DSC"))
+44 SET PRBT=$GET(SVAR(REC,"PRB","TRM"))
+45 SET CONC=$GET(SVAR(REC,"CON"))
+46 SET DTS=$GET(SVAR(REC,"DTS"))
+47 SET FSND=$GET(SVAR(REC,"FSN","DSC"))
+48 SET FSNT=$GET(SVAR(REC,"FSN","TRM"))
+49 SET PRED=$GET(SVAR(REC,"PRE","DSC"))
+50 SET PRET=$GET(SVAR(REC,"PRE","TRM"))
+51 SET LAT=$SELECT($GET(SVAR(REC,"LAT"))=1:1,1:0)
+52 SET DFSTS=$GET(SVAR(REC,"STS"))
+53 SET REPI=$SELECT($GET(SVAR(REC,"EPI"))=1:1,1:0)
+54 SET PAF=$SELECT($GET(SVAR(REC,"ABN"))=1:1,1:0)
+55 SET SEL=$SELECT($GET(SVAR(REC,"PAS"))=1:"Y",1:"")
+56 ;
+57 ;ICD
+58 SET ICD=""
IF $DATA(SVAR(REC,"ICD"))
Begin DoDot:2
+59 NEW ICNT
+60 SET ICNT=""
FOR
SET ICNT=$ORDER(SVAR(REC,"ICD",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+61 NEW ICDE
+62 SET ICDE=$GET(SVAR(REC,"ICD",ICNT,"COD"))
+63 SET ICD=ICD_$SELECT(ICD]"":$CHAR(28),1:"")_ICDE
End DoDot:3
End DoDot:2
+64 ;
+65 ;Save entry
+66 SET II=II+1
SET @DATA@(II)=PRBD_U_PRBT_U_PRED_U_PRET_U_CONC_U_DTS_U_FSND_U_FSNT
+67 SET @DATA@(II)=@DATA@(II)_U_ICD_U_LAT_U_DFSTS_U_REPI_U_PAF_U_SEL_$CHAR(30)
End DoDot:1
+68 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
TAHEAD(DATA,NMID,COUNT,SEARCH,SUBSETS) ;EP - BSTS SEARCH TYPE AHEAD
+1 ;
+2 ;Description
+3 ; This call returns some recommended concepts based on what the user has typed
+4 ; in so far. Since the call has to be very fast, straight global reads are being
+5 ; performed instead of FileMan utility reads.
+6 ;
+7 ;Input
+8 ; NMID - External codeset namespace id
+9 ; COUNT - Number of results to return
+10 ; SEARCH - String to search on
+11 ; SUBSET(S) - Subsets to limit results to - delimit subsets by "~"
+12 ;
+13 ;Output
+14 ; ^TMP("BSTSRPC1") - Name of global (passed by reference) in which the data is stored.
+15 ;
+16 ;Variables Used
+17 ; UID - Unique TMP global subscript.
+18 ;
+19 NEW UID,II,WORD,WRD,TIEN,SUBLST,I,P,SUB,FND,CIEN,R,CNT,FLVL,UPTRM,UPSRC,OWRD,TRM,OWLST
+20 ;
+21 ;Check input variables
+22 ;Default to SNOMED
IF $GET(NMID)=""
SET NMID=36
+23 IF $GET(COUNT)=""
SET COUNT=10
+24 IF $TRANSLATE($GET(SEARCH)," ")=""
SET BMXSEC="BSTS SEARCH TYPE AHEAD - SEARCH is Null"
QUIT
+25 SET SUBSETS=$GET(SUBSETS)
+26 ;
+27 ;Implement SNOMED galaxy filtering
+28 IF NMID=36
IF SUBSETS=""
SET SUBSETS="IHS PROBLEM ALL SNOMED"
+29 ;
+30 ;Put subsets in an array
+31 IF $TRANSLATE(SUBSETS,"~")]""
FOR I=1:1:$LENGTH(SUBSETS,"~")
SET SUB=$PIECE(SUBSETS,"~",I)
IF SUB]""
SET SUBLST(SUB)=""
+32 ;
+33 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+34 SET DATA=$NAME(^TMP("BSTSRPC1",UID))
+35 KILL @DATA
+36 SET II=0
SET CNT=1
+37 ;
+38 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSRPC1 D UNWIND^%ZTER"
+39 ;
+40 SET @DATA@(0)="T04096RESULTS"_$CHAR(30)
+41 ;
+42 ;Process first word in the string to establish base list
+43 SET UPSRC=$$UP^XLFSTR(SEARCH)
+44 SET WORD=$PIECE(UPSRC," ")
IF WORD=""
GOTO XTAHEAD
+45 SET OWRD=$SELECT($LENGTH(UPSRC," ")>1:0,1:1)
+46 ;
+47 ;Match check
+48 SET WRD=$$PREV(WORD)
FOR
SET WRD=$ORDER(^BSTS(9002318.3,"E",NMID,WRD))
IF (WRD="")!(WRD'[WORD)
QUIT
Begin DoDot:1
+49 ;
+50 SET TIEN=""
FOR
SET TIEN=$ORDER(^BSTS(9002318.3,"E",NMID,WRD,TIEN))
IF TIEN=""
QUIT
Begin DoDot:2
+51 ;
+52 ;Subset check
+53 SET FND=""
IF $TRANSLATE(SUBSETS,"~")]""
Begin DoDot:3
+54 SET CIEN=$PIECE($GET(^BSTS(9002318.3,TIEN,0)),U,3)
IF CIEN=""
QUIT
+55 SET SUB=""
FOR
SET SUB=$ORDER(SUBLST(SUB))
IF SUB=""
QUIT
Begin DoDot:4
+56 IF $DATA(^BSTS(9002318.4,CIEN,4,"B",SUB))
SET FND=1
End DoDot:4
IF FND
QUIT
End DoDot:3
IF FND=""
QUIT
+57 ;
+58 ;Handle single word entry
+59 IF OWRD
Begin DoDot:3
+60 IF '$DATA(OWLST($$MIXC(WRD)))
SET R("S",99999-CNT,$$MIXC(WRD))=""
SET OWLST($$MIXC(WRD))=""
SET CNT=CNT+1
End DoDot:3
QUIT
+61 ;
+62 ;Filter out FSN for SNOMED
+63 IF NMID=36
IF $PIECE($GET(^BSTS(9002318.3,TIEN,0)),U,9)="F"
QUIT
+64 ;
+65 ;Set up the entry
+66 SET UPTRM=$$UP^XLFSTR($PIECE($GET(^BSTS(9002318.3,TIEN,1)),U))
IF UPTRM=""
QUIT
+67 SET R("R",UPTRM)=TIEN_U_$SELECT(WRD=WORD:3,1:1)
+68 SET CNT=CNT+1
End DoDot:2
IF OWRD
IF CNT>COUNT
QUIT
End DoDot:1
IF OWRD
IF CNT>COUNT
QUIT
+69 ;
+70 ;Now loop through remaining words and filter
+71 ;
+72 ;Process remaining words
+73 IF 'OWRD
IF $DATA(R)>9
FOR P=2:1:$LENGTH(UPSRC," ")
SET WORD=$PIECE(UPSRC," ",P)
IF WORD]""
Begin DoDot:1
+74 SET (FND,UPTRM)=""
FOR
SET UPTRM=$ORDER(R("R",UPTRM))
IF UPTRM=""
QUIT
Begin DoDot:2
+75 SET FND=""
FOR I=1:1:$LENGTH(UPTRM," ")
SET WRD=$PIECE(UPTRM," ",I)
IF WRD]""
IF $EXTRACT(WRD,1,$LENGTH(WORD))=WORD
Begin DoDot:3
+76 SET $PIECE(R("R",UPTRM),U,2)=$PIECE(R("R",UPTRM),U,2)+$SELECT(WRD=WORD:3,1:1)
End DoDot:3
SET FND=1
QUIT
+77 IF 'FND
KILL R("R",UPTRM)
End DoDot:2
+78 QUIT
End DoDot:1
+79 ;
+80 ;Add extra weighting
+81 IF 'OWRD
SET UPTRM=""
FOR
SET UPTRM=$ORDER(R("R",UPTRM))
IF UPTRM=""
QUIT
Begin DoDot:1
+82 IF UPSRC=UPTRM
SET $PIECE(R("R",UPTRM),U,2)=$PIECE(R("R",UPTRM),U,2)+100
+83 FOR I=1:1:$LENGTH(UPSRC," ")
Begin DoDot:2
+84 IF $EXTRACT($PIECE(UPTRM," ",I),1,$LENGTH($PIECE(UPSRC," ",I)))=$PIECE(UPSRC," ",I)
SET $PIECE(R("R",UPTRM),U,2)=$PIECE(R("R",UPTRM),U,2)+5
End DoDot:2
+85 SET TIEN=$PIECE(R("R",UPTRM),U)
SET TRM=$PIECE($GET(^BSTS(9002318.3,TIEN,1)),U)
IF TRM=""
QUIT
+86 SET R("S",$PIECE(R("R",UPTRM),U,2),TRM)=""
+87 KILL R("R",UPTRM)
End DoDot:1
+88 ;
+89 ;Now output
+90 SET R=""
FOR
SET R=$ORDER(R("S",R),-1)
IF R=""
QUIT
Begin DoDot:1
+91 SET TRM=""
FOR
SET TRM=$ORDER(R("S",R,TRM))
IF TRM=""
QUIT
Begin DoDot:2
+92 SET II=II+1
SET @DATA@(II)=TRM_$CHAR(30)
End DoDot:2
IF II'<COUNT
QUIT
End DoDot:1
IF II'<COUNT
QUIT
+93 ;
XTAHEAD ;
+1 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+2 QUIT
+3 ;
MIXC(WORD) ;Convert to mix case
+1 ;
+2 QUIT $EXTRACT(WORD,1)_$$LOW^XLFSTR($EXTRACT(WORD,2,9999))
+3 ;
PREV(WORD) ;Return string right before passed in string
+1 ;
+2 NEW L,A,LST
+3 ;
+4 ;Get last character
+5 SET L=$EXTRACT(WORD,$LENGTH(WORD))
IF L=""
QUIT ""
+6 ;
+7 ;Get ASCII of previous character
+8 SET A=$ASCII(L)
IF A>1
SET A=A-1
+9 ;
+10 ;Define highest ASCII
+11 SET LST=$CHAR(65535)
+12 ;
+13 ;Return word string just before word
+14 SET WORD=$EXTRACT(WORD,1,$LENGTH(WORD)-1)_$CHAR(A)_LST_LST_LST_LST
+15 ;
+16 QUIT WORD
+17 ;
HDR ;
+1 NEW HDR
+2 SET HDR="T00050PRB_DSC^T00250PRB_TRM^T00050PREF_DSC^T00250PREF_TRM^T00050CONCID^T00030DTSID^T00050FSN_DSC^T00250FSN_TRM"
+3 SET HDR=HDR_"^T04096ICD^T00001PROMPT_LATERALITY^T00020DEFAULT_STATUS^T00001REQUIRE_EPISODICITY^T00001PROMPT_AF^T00001SELECTABLE"
+4 SET @DATA@(0)=HDR_$CHAR(30)
+5 QUIT
+6 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
