SDHL7UL ;MS/TG - TMP HL7 Routine;JULY 23, 2018
;;5.3;Scheduling;**704**;May 29, 2018;Build 64
;
Q ;Direct entry not supported
;
LOADMSG(MSGROOT) ; Load HL7 message into temporary global for processing
;
;This subroutine assumes that all VistA HL7 environment variables are
;properly initialized and will produce a fatal error if they aren't.
;
N CNT,SEG
K @MSGROOT
F SEG=1:1 X HLNEXT Q:HLQUIT'>0 D
. S CNT=0
. S @MSGROOT@(SEG,CNT)=HLNODE
. F S CNT=$O(HLNODE(CNT)) Q:'CNT S @MSGROOT@(SEG,CNT)=HLNODE(CNT)
Q
;
LOADXMT(XMT) ;Set HL dependent XMT values
;
; The HL array and variables are expected to be defined. If not,
; message processing will fail. These references should not be
; wrapped in $G, as null values will simply postpone the failure to
; a point that will be harder to diagnose. Except HL("APAT") which
; is not defined on synchronous calls.
;
N SUBPROT,RESPIEN,RESP0
S XMT("MID")=HL("MID") ;Message ID
S XMT("MODE")="A" ;Response mode
I $G(HL("APAT"))="" S XMT("MODE")="S" ;Synchronous mode
S XMT("HLMTIENS")=HLMTIENS ;Message IEN
S XMT("MESSAGE TYPE")=HL("MTN") ;Message type
S XMT("EVENT TYPE")=HL("ETN") ;Event type
S XMT("DELIM")=HL("FS")_HL("ECH") ;HL Delimiters
S XMT("MAX SIZE")=0 ;Default size unlimited
;
; Map response protocol and builder
S SUBPROT=$P(^ORD(101,HL("EIDS"),0),"^")
Q
;
DELIM(PROTOCOL) ;Return string of message delimiters based on Protocol
;
; Integration Agreements:
; 2161 : INIT^HLFNC2
;
N HL
Q:PROTOCOL="" ""
D INIT^HLFNC2(PROTOCOL,.HL)
Q $G(HL("FS"))_$G(HL("ECH"))
;
PARSEMSG(MSGROOT,HL) ; Message Parser
; Does not handle segments that span nodes
; Does not handle extremely long segments (uses a local)
; Does not handle long fields (segment parser doesn't)
;
N SEG,CNT,DATA,MSG
F CNT=1:1 Q:'$D(@MSGROOT@(CNT)) M SEG=@MSGROOT@(CNT) D
. D PARSESEG(SEG(0),.DATA,.HL)
. K @MSGROOT@(CNT)
. I DATA(0)'="" M @MSGROOT@(CNT)=DATA
. Q:'$D(SEG(1))
. ;Add handler for segments that span nodes here.
. Q
Q
;
PARSESEG(SEG,DATA,HL) ;Generic segment parser
;This procedure parses a single HL7 segment and builds an array
;subscripted by the field number containing the data for that field.
; Does not handle segments that span nodes
;
; Input:
; SEG - HL7 segment to parse
; HL - HL7 environment array
;
; Output:
; Function value - field data array [SUB1:field, SUB2:repetition,
; SUB3:component, SUB4:sub-component]
;
N CMP ;component subscript
N CMPVAL ;component value
N FLD ;field subscript
N FLDVAL ;field value
N REP ;repetition subscript
N REPVAL ;repetition value
N SUB ;sub-component subscript
N SUBVAL ;sub-component value
N FS ;field separator
N CS ;component separator
N RS ;repetition separator
N SS ;sub-component separator
;
K DATA
S FS=HL("FS")
S CS=$E(HL("ECH"))
S RS=$E(HL("ECH"),2)
S SS=$E(HL("ECH"),4)
;
S DATA(0)=$P(SEG,FS)
S SEG=$P(SEG,FS,2,9999)
F FLD=1:1:$L(SEG,FS) D
. S FLDVAL=$P(SEG,FS,FLD)
. F REP=1:1:$L(FLDVAL,RS) D
. . S REPVAL=$P(FLDVAL,RS,REP)
. . I REPVAL[CS F CMP=1:1:$L(REPVAL,CS) D
. . . S CMPVAL=$P(REPVAL,CS,CMP)
. . . I CMPVAL[SS F SUB=1:1:$L(CMPVAL,SS) D
. . . . S SUBVAL=$P(CMPVAL,SS,SUB)
. . . . I SUBVAL'="" S DATA(FLD,REP,CMP,SUB)=SUBVAL
. . . I '$D(DATA(FLD,REP,CMP)),CMPVAL'="" S DATA(FLD,REP,CMP)=CMPVAL
. . I '$D(DATA(FLD,REP)),REPVAL'="",FLDVAL[RS S DATA(FLD,REP)=REPVAL
. I '$D(DATA(FLD)),FLDVAL'="" S DATA(FLD)=FLDVAL
Q
;
BLDSEG(DATA,HL) ;generic segment builder
;
; Input:
; DATA - field data array [SUB1:field, SUB2:repetition,
; SUB3:component, SUB4:sub-component]
; HL - HL7 environment array
;
; Output:
; Function Value - Formatted HL7 segment on success, "" on failure
;
N CMP ;component subscript
N CMPVAL ;component value
N FLD ;field subscript
N FLDVAL ;field value
N REP ;repetition subscript
N REPVAL ;repetition value
N SUB ;sub-component subscript
N SUBVAL ;sub-component value
N FS ;field separator
N CS ;component separator
N RS ;repetition separator
N ES ;escape character
N SS ;sub-component separator
N SEG,SEP
;
S FS=HL("FS")
S CS=$E(HL("ECH"))
S RS=$E(HL("ECH"),2)
S ES=$E(HL("ECH"),3)
S SS=$E(HL("ECH"),4)
;
S SEG=$G(DATA(0))
F FLD=1:1:$O(DATA(""),-1) D
. S FLDVAL=$G(DATA(FLD)),SEP=FS
. S SEG=SEG_SEP_FLDVAL
. F REP=1:1:$O(DATA(FLD,""),-1) D
. . S REPVAL=$G(DATA(FLD,REP))
. . S SEP=$S(REP=1:"",1:RS)
. . S SEG=SEG_SEP_REPVAL
. . F CMP=1:1:$O(DATA(FLD,REP,""),-1) D
. . . S CMPVAL=$G(DATA(FLD,REP,CMP))
. . . S SEP=$S(CMP=1:"",1:CS)
. . . S SEG=SEG_SEP_CMPVAL
. . . F SUB=1:1:$O(DATA(FLD,REP,CMP,""),-1) D
. . . . S SUBVAL=$G(DATA(FLD,REP,CMP,SUB))
. . . . S SEP=$S(SUB=1:"",1:SS)
. . . . S SEG=SEG_SEP_SUBVAL
Q SEG
;
RESET ; Initialize or clear session pointer into log
K ^TMP("SDHL7LOG",$J)
Q
LOGPRG(RESULT,DTM) ;Purge SDHL7 application log
;
; Input:
; DTM - Purge Date/Time - optional
; Fileman date/time
; Default to older than a week
;
; Output:
; RESULT - success flag ^ purge date/time
;
N %DT,X,Y
S X=$G(DTM),%DT="TX" D ^%DT S DTM=Y
I DTM<0 S DTM=$$HTFM^XLFDT($H-7,1)
S RESULT=DTM
S DTM=-DTM
F S DTM=$O(^XTMP("SDHL7LOG",2,DTM)) Q:DTM="" K ^XTMP("SDHL7LOG",2,DTM)
S RESULT="1^"_RESULT
Q
;
AUTOPRG ;
Q:'$G(^XTMP("SDHL7LOG",1,"AUTOPURGE"))
N DT,DAYS,RESULT
; Purge only once per day
S DT=$$DT^XLFDT
Q:$G(^XTMP("SDHL7LOG",1,"AUTOPURGE","PURGE DATE"))=DT
;
S DAYS=$G(^XTMP("SDHL7LOG",1,"AUTOPURGE","DAYS"))
I DAYS<1 S DAYS=7
;
D LOGPRG(.RESULT,$$HTFM^XLFDT($H-DAYS,1))
S ^XTMP("SDHL7LOG",1,"AUTOPURGE","PURGE DATE")=DT
Q
;
LOG(NAME,DATA,TYPE,LEVEL) ;Log to SDHL7 application log
;
; Input:
; NAME - Name to identify log entry
; DATA - Value,Tree, or Name of structure to put in log
; TYPE - Type of log entry
; S:Set Single Value
; M:Merge Tree
; I:Indirect Merge @
; LEVEL - Level of log entry - ERROR,TRACE,NAMED,DEBUG
;
; Output:
; Adds entry to log
;
; ^XTMP("SDHL7LOG",0) - Head of log file
; ^XTMP("SDHL7LOG",1) - if set indicates that logging is on
; ^XTMP("SDHL7LOG",1,"LEVEL") - logging level
; ^XTMP("SDHL7LOG",1,"LEVEL",LEVEL) = rank
; ^XTMP("SDHL7LOG",1,"NAMES",) - names to log caret delimited string
; ^XTMP("SDHL7LOG",1,"NAMES",NAME) - name to log
; ^XTMP("SDHL7LOG",2) - contains the log
; ^XTMP("SDHL7LOG",2,negated FM timestamp,$J,counter,NAME) - log entry
;
; ^TMP("SDHL7LOG",$J) - Session current log entry (DTM)
;
;Quit if logging is not turned on
Q:'$G(^XTMP("SDHL7LOG",1))
N DTM,CNT,LOGLEVEL
;
Q:'$D(DATA)
Q:$G(TYPE)=""
Q:$G(NAME)=""
S NAME=$TR(NAME,"^","-")
;
;If LEVEL is null or unknown default to DEBUG
I $G(LEVEL)="" S LEVEL="DEBUG"
I '$D(^XTMP("SDHL7LOG",1,"LEVEL",LEVEL)) S LEVEL="DEBUG"
;
;Log entries at or lower than the current logging level set
;Levels are ranked as follows:
; ^XTMP("SDHL7LOG",1,"LEVEL","ERROR")=1
; ^XTMP("SDHL7LOG",1,"LEVEL","TRACE")=2
; ^XTMP("SDHL7LOG",1,"LEVEL","NAMED")=3
; ^XTMP("SDHL7LOG",1,"LEVEL","DEBUG")=4
;Named is like a filtered version of debug.
;Additional levels may be added, and ranks changed without affecting
;the LOG api. Inserting a level between Named and Debug will require
;a change to the conditional below.
S LOGLEVEL=$G(^XTMP("SDHL7LOG",1,"LEVEL"))
I LOGLEVEL="" S LOGLEVEL="TRACE"
I $G(^XTMP("SDHL7LOG",1,"LEVEL",LEVEL))>$G(^XTMP("SDHL7LOG",1,"LEVEL",LOGLEVEL)) Q:LOGLEVEL'="NAMED" Q:'$D(^XTMP("SDHL7LOG",1,"NAMES",NAME))
;
; Check ^TMP("SDHL7LOG",$J) If no current log node start a new node
I '$G(^TMP("SDHL7LOG",$J)) D
. S DTM=-$$NOW^XLFDT()
. K ^XTMP("SDHL7LOG",2,DTM,$J)
. S ^TMP("SDHL7LOG",$J)=DTM
. S CNT=1
. S ^XTMP("SDHL7LOG",2,DTM,$J)=CNT
. D AUTOPRG
. Q
E D
. S DTM=^TMP("SDHL7LOG",$J)
. S CNT=$G(^XTMP("SDHL7LOG",2,DTM,$J))+1
. S ^XTMP("SDHL7LOG",2,DTM,$J)=CNT
. Q
;
I TYPE="S" S ^XTMP("SDHL7LOG",2,DTM,$J,CNT,NAME)=DATA Q
I TYPE="M" M ^XTMP("SDHL7LOG",2,DTM,$J,CNT,NAME)=DATA Q
I TYPE="I" M ^XTMP("SDHL7LOG",2,DTM,$J,CNT,NAME)=@DATA Q
;
Q
ESCAPE(VAL,HL) ;Escape any special characters
; *** Does not handle long strings of special characters ***
;
; Input:
; VAL - value to escape
; HL - HL7 environment array
;
; Output:
; VAL - passed by reference
;
N FS ;field separator
N CS ;component separator
N RS ;repetition separator
N ES ;escape character
N SS ;sub-component separator
N L,STR,I
;
S FS=HL("FS")
S CS=$E(HL("ECH"))
S RS=$E(HL("ECH"),2)
S ES=$E(HL("ECH"),3)
S SS=$E(HL("ECH"),4)
;
I VAL[ES D
. S L=$L(VAL,ES),STR=""
. F I=1:1:L S $P(STR,ES_"E"_ES,I)=$P(VAL,ES,I)
. S VAL=STR
I VAL[FS D
. S L=$L(VAL,FS),STR=""
. F I=1:1:L S $P(STR,ES_"F"_ES,I)=$P(VAL,FS,I)
. S VAL=STR
I VAL[RS D
. S L=$L(VAL,RS),STR=""
. F I=1:1:L S $P(STR,ES_"R"_ES,I)=$P(VAL,RS,I)
. S VAL=STR
I VAL[CS D
. S L=$L(VAL,CS),STR=""
. F I=1:1:L S $P(STR,ES_"S"_ES,I)=$P(VAL,CS,I)
. S VAL=STR
I VAL[SS D
. S L=$L(VAL,SS),STR=""
. F I=1:1:L S $P(STR,ES_"T"_ES,I)=$P(VAL,SS,I)
. S VAL=STR
Q VAL
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDHL7UL 9617 printed Sep 23, 2025@20:34:54 Page 2
SDHL7UL ;MS/TG - TMP HL7 Routine;JULY 23, 2018
+1 ;;5.3;Scheduling;**704**;May 29, 2018;Build 64
+2 ;
+3 ;Direct entry not supported
QUIT
+4 ;
LOADMSG(MSGROOT) ; Load HL7 message into temporary global for processing
+1 ;
+2 ;This subroutine assumes that all VistA HL7 environment variables are
+3 ;properly initialized and will produce a fatal error if they aren't.
+4 ;
+5 NEW CNT,SEG
+6 KILL @MSGROOT
+7 FOR SEG=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+8 SET CNT=0
+9 SET @MSGROOT@(SEG,CNT)=HLNODE
+10 FOR
SET CNT=$ORDER(HLNODE(CNT))
if 'CNT
QUIT
SET @MSGROOT@(SEG,CNT)=HLNODE(CNT)
End DoDot:1
+11 QUIT
+12 ;
LOADXMT(XMT) ;Set HL dependent XMT values
+1 ;
+2 ; The HL array and variables are expected to be defined. If not,
+3 ; message processing will fail. These references should not be
+4 ; wrapped in $G, as null values will simply postpone the failure to
+5 ; a point that will be harder to diagnose. Except HL("APAT") which
+6 ; is not defined on synchronous calls.
+7 ;
+8 NEW SUBPROT,RESPIEN,RESP0
+9 ;Message ID
SET XMT("MID")=HL("MID")
+10 ;Response mode
SET XMT("MODE")="A"
+11 ;Synchronous mode
IF $GET(HL("APAT"))=""
SET XMT("MODE")="S"
+12 ;Message IEN
SET XMT("HLMTIENS")=HLMTIENS
+13 ;Message type
SET XMT("MESSAGE TYPE")=HL("MTN")
+14 ;Event type
SET XMT("EVENT TYPE")=HL("ETN")
+15 ;HL Delimiters
SET XMT("DELIM")=HL("FS")_HL("ECH")
+16 ;Default size unlimited
SET XMT("MAX SIZE")=0
+17 ;
+18 ; Map response protocol and builder
+19 SET SUBPROT=$PIECE(^ORD(101,HL("EIDS"),0),"^")
+20 QUIT
+21 ;
DELIM(PROTOCOL) ;Return string of message delimiters based on Protocol
+1 ;
+2 ; Integration Agreements:
+3 ; 2161 : INIT^HLFNC2
+4 ;
+5 NEW HL
+6 if PROTOCOL=""
QUIT ""
+7 DO INIT^HLFNC2(PROTOCOL,.HL)
+8 QUIT $GET(HL("FS"))_$GET(HL("ECH"))
+9 ;
PARSEMSG(MSGROOT,HL) ; Message Parser
+1 ; Does not handle segments that span nodes
+2 ; Does not handle extremely long segments (uses a local)
+3 ; Does not handle long fields (segment parser doesn't)
+4 ;
+5 NEW SEG,CNT,DATA,MSG
+6 FOR CNT=1:1
if '$DATA(@MSGROOT@(CNT))
QUIT
MERGE SEG=@MSGROOT@(CNT)
Begin DoDot:1
+7 DO PARSESEG(SEG(0),.DATA,.HL)
+8 KILL @MSGROOT@(CNT)
+9 IF DATA(0)'=""
MERGE @MSGROOT@(CNT)=DATA
+10 if '$DATA(SEG(1))
QUIT
+11 ;Add handler for segments that span nodes here.
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
PARSESEG(SEG,DATA,HL) ;Generic segment parser
+1 ;This procedure parses a single HL7 segment and builds an array
+2 ;subscripted by the field number containing the data for that field.
+3 ; Does not handle segments that span nodes
+4 ;
+5 ; Input:
+6 ; SEG - HL7 segment to parse
+7 ; HL - HL7 environment array
+8 ;
+9 ; Output:
+10 ; Function value - field data array [SUB1:field, SUB2:repetition,
+11 ; SUB3:component, SUB4:sub-component]
+12 ;
+13 ;component subscript
NEW CMP
+14 ;component value
NEW CMPVAL
+15 ;field subscript
NEW FLD
+16 ;field value
NEW FLDVAL
+17 ;repetition subscript
NEW REP
+18 ;repetition value
NEW REPVAL
+19 ;sub-component subscript
NEW SUB
+20 ;sub-component value
NEW SUBVAL
+21 ;field separator
NEW FS
+22 ;component separator
NEW CS
+23 ;repetition separator
NEW RS
+24 ;sub-component separator
NEW SS
+25 ;
+26 KILL DATA
+27 SET FS=HL("FS")
+28 SET CS=$EXTRACT(HL("ECH"))
+29 SET RS=$EXTRACT(HL("ECH"),2)
+30 SET SS=$EXTRACT(HL("ECH"),4)
+31 ;
+32 SET DATA(0)=$PIECE(SEG,FS)
+33 SET SEG=$PIECE(SEG,FS,2,9999)
+34 FOR FLD=1:1:$LENGTH(SEG,FS)
Begin DoDot:1
+35 SET FLDVAL=$PIECE(SEG,FS,FLD)
+36 FOR REP=1:1:$LENGTH(FLDVAL,RS)
Begin DoDot:2
+37 SET REPVAL=$PIECE(FLDVAL,RS,REP)
+38 IF REPVAL[CS
FOR CMP=1:1:$LENGTH(REPVAL,CS)
Begin DoDot:3
+39 SET CMPVAL=$PIECE(REPVAL,CS,CMP)
+40 IF CMPVAL[SS
FOR SUB=1:1:$LENGTH(CMPVAL,SS)
Begin DoDot:4
+41 SET SUBVAL=$PIECE(CMPVAL,SS,SUB)
+42 IF SUBVAL'=""
SET DATA(FLD,REP,CMP,SUB)=SUBVAL
End DoDot:4
+43 IF '$DATA(DATA(FLD,REP,CMP))
IF CMPVAL'=""
SET DATA(FLD,REP,CMP)=CMPVAL
End DoDot:3
+44 IF '$DATA(DATA(FLD,REP))
IF REPVAL'=""
IF FLDVAL[RS
SET DATA(FLD,REP)=REPVAL
End DoDot:2
+45 IF '$DATA(DATA(FLD))
IF FLDVAL'=""
SET DATA(FLD)=FLDVAL
End DoDot:1
+46 QUIT
+47 ;
BLDSEG(DATA,HL) ;generic segment builder
+1 ;
+2 ; Input:
+3 ; DATA - field data array [SUB1:field, SUB2:repetition,
+4 ; SUB3:component, SUB4:sub-component]
+5 ; HL - HL7 environment array
+6 ;
+7 ; Output:
+8 ; Function Value - Formatted HL7 segment on success, "" on failure
+9 ;
+10 ;component subscript
NEW CMP
+11 ;component value
NEW CMPVAL
+12 ;field subscript
NEW FLD
+13 ;field value
NEW FLDVAL
+14 ;repetition subscript
NEW REP
+15 ;repetition value
NEW REPVAL
+16 ;sub-component subscript
NEW SUB
+17 ;sub-component value
NEW SUBVAL
+18 ;field separator
NEW FS
+19 ;component separator
NEW CS
+20 ;repetition separator
NEW RS
+21 ;escape character
NEW ES
+22 ;sub-component separator
NEW SS
+23 NEW SEG,SEP
+24 ;
+25 SET FS=HL("FS")
+26 SET CS=$EXTRACT(HL("ECH"))
+27 SET RS=$EXTRACT(HL("ECH"),2)
+28 SET ES=$EXTRACT(HL("ECH"),3)
+29 SET SS=$EXTRACT(HL("ECH"),4)
+30 ;
+31 SET SEG=$GET(DATA(0))
+32 FOR FLD=1:1:$ORDER(DATA(""),-1)
Begin DoDot:1
+33 SET FLDVAL=$GET(DATA(FLD))
SET SEP=FS
+34 SET SEG=SEG_SEP_FLDVAL
+35 FOR REP=1:1:$ORDER(DATA(FLD,""),-1)
Begin DoDot:2
+36 SET REPVAL=$GET(DATA(FLD,REP))
+37 SET SEP=$SELECT(REP=1:"",1:RS)
+38 SET SEG=SEG_SEP_REPVAL
+39 FOR CMP=1:1:$ORDER(DATA(FLD,REP,""),-1)
Begin DoDot:3
+40 SET CMPVAL=$GET(DATA(FLD,REP,CMP))
+41 SET SEP=$SELECT(CMP=1:"",1:CS)
+42 SET SEG=SEG_SEP_CMPVAL
+43 FOR SUB=1:1:$ORDER(DATA(FLD,REP,CMP,""),-1)
Begin DoDot:4
+44 SET SUBVAL=$GET(DATA(FLD,REP,CMP,SUB))
+45 SET SEP=$SELECT(SUB=1:"",1:SS)
+46 SET SEG=SEG_SEP_SUBVAL
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+47 QUIT SEG
+48 ;
RESET ; Initialize or clear session pointer into log
+1 KILL ^TMP("SDHL7LOG",$JOB)
+2 QUIT
LOGPRG(RESULT,DTM) ;Purge SDHL7 application log
+1 ;
+2 ; Input:
+3 ; DTM - Purge Date/Time - optional
+4 ; Fileman date/time
+5 ; Default to older than a week
+6 ;
+7 ; Output:
+8 ; RESULT - success flag ^ purge date/time
+9 ;
+10 NEW %DT,X,Y
+11 SET X=$GET(DTM)
SET %DT="TX"
DO ^%DT
SET DTM=Y
+12 IF DTM<0
SET DTM=$$HTFM^XLFDT($HOROLOG-7,1)
+13 SET RESULT=DTM
+14 SET DTM=-DTM
+15 FOR
SET DTM=$ORDER(^XTMP("SDHL7LOG",2,DTM))
if DTM=""
QUIT
KILL ^XTMP("SDHL7LOG",2,DTM)
+16 SET RESULT="1^"_RESULT
+17 QUIT
+18 ;
AUTOPRG ;
+1 if '$GET(^XTMP("SDHL7LOG",1,"AUTOPURGE"))
QUIT
+2 NEW DT,DAYS,RESULT
+3 ; Purge only once per day
+4 SET DT=$$DT^XLFDT
+5 if $GET(^XTMP("SDHL7LOG",1,"AUTOPURGE","PURGE DATE"))=DT
QUIT
+6 ;
+7 SET DAYS=$GET(^XTMP("SDHL7LOG",1,"AUTOPURGE","DAYS"))
+8 IF DAYS<1
SET DAYS=7
+9 ;
+10 DO LOGPRG(.RESULT,$$HTFM^XLFDT($HOROLOG-DAYS,1))
+11 SET ^XTMP("SDHL7LOG",1,"AUTOPURGE","PURGE DATE")=DT
+12 QUIT
+13 ;
LOG(NAME,DATA,TYPE,LEVEL) ;Log to SDHL7 application log
+1 ;
+2 ; Input:
+3 ; NAME - Name to identify log entry
+4 ; DATA - Value,Tree, or Name of structure to put in log
+5 ; TYPE - Type of log entry
+6 ; S:Set Single Value
+7 ; M:Merge Tree
+8 ; I:Indirect Merge @
+9 ; LEVEL - Level of log entry - ERROR,TRACE,NAMED,DEBUG
+10 ;
+11 ; Output:
+12 ; Adds entry to log
+13 ;
+14 ; ^XTMP("SDHL7LOG",0) - Head of log file
+15 ; ^XTMP("SDHL7LOG",1) - if set indicates that logging is on
+16 ; ^XTMP("SDHL7LOG",1,"LEVEL") - logging level
+17 ; ^XTMP("SDHL7LOG",1,"LEVEL",LEVEL) = rank
+18 ; ^XTMP("SDHL7LOG",1,"NAMES",) - names to log caret delimited string
+19 ; ^XTMP("SDHL7LOG",1,"NAMES",NAME) - name to log
+20 ; ^XTMP("SDHL7LOG",2) - contains the log
+21 ; ^XTMP("SDHL7LOG",2,negated FM timestamp,$J,counter,NAME) - log entry
+22 ;
+23 ; ^TMP("SDHL7LOG",$J) - Session current log entry (DTM)
+24 ;
+25 ;Quit if logging is not turned on
+26 if '$GET(^XTMP("SDHL7LOG",1))
QUIT
+27 NEW DTM,CNT,LOGLEVEL
+28 ;
+29 if '$DATA(DATA)
QUIT
+30 if $GET(TYPE)=""
QUIT
+31 if $GET(NAME)=""
QUIT
+32 SET NAME=$TRANSLATE(NAME,"^","-")
+33 ;
+34 ;If LEVEL is null or unknown default to DEBUG
+35 IF $GET(LEVEL)=""
SET LEVEL="DEBUG"
+36 IF '$DATA(^XTMP("SDHL7LOG",1,"LEVEL",LEVEL))
SET LEVEL="DEBUG"
+37 ;
+38 ;Log entries at or lower than the current logging level set
+39 ;Levels are ranked as follows:
+40 ; ^XTMP("SDHL7LOG",1,"LEVEL","ERROR")=1
+41 ; ^XTMP("SDHL7LOG",1,"LEVEL","TRACE")=2
+42 ; ^XTMP("SDHL7LOG",1,"LEVEL","NAMED")=3
+43 ; ^XTMP("SDHL7LOG",1,"LEVEL","DEBUG")=4
+44 ;Named is like a filtered version of debug.
+45 ;Additional levels may be added, and ranks changed without affecting
+46 ;the LOG api. Inserting a level between Named and Debug will require
+47 ;a change to the conditional below.
+48 SET LOGLEVEL=$GET(^XTMP("SDHL7LOG",1,"LEVEL"))
+49 IF LOGLEVEL=""
SET LOGLEVEL="TRACE"
+50 IF $GET(^XTMP("SDHL7LOG",1,"LEVEL",LEVEL))>$GET(^XTMP("SDHL7LOG",1,"LEVEL",LOGLEVEL))
if LOGLEVEL'="NAMED"
QUIT
if '$DATA(^XTMP("SDHL7LOG",1,"NAMES",NAME))
QUIT
+51 ;
+52 ; Check ^TMP("SDHL7LOG",$J) If no current log node start a new node
+53 IF '$GET(^TMP("SDHL7LOG",$JOB))
Begin DoDot:1
+54 SET DTM=-$$NOW^XLFDT()
+55 KILL ^XTMP("SDHL7LOG",2,DTM,$JOB)
+56 SET ^TMP("SDHL7LOG",$JOB)=DTM
+57 SET CNT=1
+58 SET ^XTMP("SDHL7LOG",2,DTM,$JOB)=CNT
+59 DO AUTOPRG
+60 QUIT
End DoDot:1
+61 IF '$TEST
Begin DoDot:1
+62 SET DTM=^TMP("SDHL7LOG",$JOB)
+63 SET CNT=$GET(^XTMP("SDHL7LOG",2,DTM,$JOB))+1
+64 SET ^XTMP("SDHL7LOG",2,DTM,$JOB)=CNT
+65 QUIT
End DoDot:1
+66 ;
+67 IF TYPE="S"
SET ^XTMP("SDHL7LOG",2,DTM,$JOB,CNT,NAME)=DATA
QUIT
+68 IF TYPE="M"
MERGE ^XTMP("SDHL7LOG",2,DTM,$JOB,CNT,NAME)=DATA
QUIT
+69 IF TYPE="I"
MERGE ^XTMP("SDHL7LOG",2,DTM,$JOB,CNT,NAME)=@DATA
QUIT
+70 ;
+71 QUIT
ESCAPE(VAL,HL) ;Escape any special characters
+1 ; *** Does not handle long strings of special characters ***
+2 ;
+3 ; Input:
+4 ; VAL - value to escape
+5 ; HL - HL7 environment array
+6 ;
+7 ; Output:
+8 ; VAL - passed by reference
+9 ;
+10 ;field separator
NEW FS
+11 ;component separator
NEW CS
+12 ;repetition separator
NEW RS
+13 ;escape character
NEW ES
+14 ;sub-component separator
NEW SS
+15 NEW L,STR,I
+16 ;
+17 SET FS=HL("FS")
+18 SET CS=$EXTRACT(HL("ECH"))
+19 SET RS=$EXTRACT(HL("ECH"),2)
+20 SET ES=$EXTRACT(HL("ECH"),3)
+21 SET SS=$EXTRACT(HL("ECH"),4)
+22 ;
+23 IF VAL[ES
Begin DoDot:1
+24 SET L=$LENGTH(VAL,ES)
SET STR=""
+25 FOR I=1:1:L
SET $PIECE(STR,ES_"E"_ES,I)=$PIECE(VAL,ES,I)
+26 SET VAL=STR
End DoDot:1
+27 IF VAL[FS
Begin DoDot:1
+28 SET L=$LENGTH(VAL,FS)
SET STR=""
+29 FOR I=1:1:L
SET $PIECE(STR,ES_"F"_ES,I)=$PIECE(VAL,FS,I)
+30 SET VAL=STR
End DoDot:1
+31 IF VAL[RS
Begin DoDot:1
+32 SET L=$LENGTH(VAL,RS)
SET STR=""
+33 FOR I=1:1:L
SET $PIECE(STR,ES_"R"_ES,I)=$PIECE(VAL,RS,I)
+34 SET VAL=STR
End DoDot:1
+35 IF VAL[CS
Begin DoDot:1
+36 SET L=$LENGTH(VAL,CS)
SET STR=""
+37 FOR I=1:1:L
SET $PIECE(STR,ES_"S"_ES,I)=$PIECE(VAL,CS,I)
+38 SET VAL=STR
End DoDot:1
+39 IF VAL[SS
Begin DoDot:1
+40 SET L=$LENGTH(VAL,SS)
SET STR=""
+41 FOR I=1:1:L
SET $PIECE(STR,ES_"T"_ES,I)=$PIECE(VAL,SS,I)
+42 SET VAL=STR
End DoDot:1
+43 QUIT VAL
+44 ;
