DGPFHLUT ;ALB/RPM - PRF HL7 UTILITIES ; 2/12/2020
;;5.3;Registration;**425,650,951,1005**;Aug 13, 1993;Build 57
;;Per VA Directive 6402, this routine should not be modified.
;
;This routine contains generic utilities used when building
;or processing received patient record flag HL7 messages.
;
Q ;no supported direct entry
;
INIT(DGPROT,DGHL) ;Kernel HL7 INIT wrapper
;
; Supported DBIA #2161: The supported DBIA is used to access the
; VistA HL7 API to initialize the HL7 environ-
; ment variables.
;
; Input:
; DGPROT - Event protocol name
;
; Output:
; Function value - HLEID on success;0 on failure
; DGHL - HL array from INIT^HLFNC2 Kernel call
;
N DGHLEID
S DGHLEID=0
S DGHLEID=$$HLEID(DGPROT)
I DGHLEID D
. D INIT^HLFNC2(DGHLEID,.DGHL)
. I $O(DGHL(""))="" S DGHLEID=0
Q DGHLEID
;
HLEID(DGPROT) ;return IEN of HL7 protocol
;
; Input:
; DGPROT - Protocol name
;
; Output:
; Function value - IEN of protocol on success, 0 on failure
;
I $G(DGPROT)="" Q 0
Q +$O(^ORD(101,"B",DGPROT,0))
;
GETLINK(DGINST) ;retrieve a single link for a given institution
;
; Supported DBIA #2271: The supported DBIA is used to access the
; VistA HL7 API to retrieve logical links
; given a pointer to the INSTITUTION (#4) file.
;
; Input:
; DGINST - IEN of site in INSTITUTION (#4) file
;
; Output:
; Function Value - HL Logical link on success, 0 on failure
;
N DGLINKS
N DGLNK
N DGRSLT
;
S DGRSLT=0
I $G(DGINST)>0 D
. D LINK^HLUTIL3(DGINST,.DGLINKS)
. S DGLNK=$O(DGLINKS(0))
. S DGRSLT=$S(DGLNK>0:DGLINKS(DGLNK),1:0)
Q DGRSLT
;
BLDTEXT(DGWP,DGHL,DGARR) ;Build HL7 word proc text array
;
; Supported DBIA #10104: The supported DBIA is used to access KERNEL
; string functions.
;
; Input:
; DGWP - Word processing closed root
; DGHL - HL7 environment array
;
; Output:
; Function Value - count of segment array elements on success,
; 0 on failure
; DGARR - array of segment text data
;
N DGLIN ;word processing line iterator
N DGCNT ;text segment counter
N DGTXT ;word processing text
N DGBLK ;blank line counter
N DGREP ;HL7 repetition character
;
S DGLIN=0
S DGCNT=0
S DGBLK=0
S DGREP=$E(DGHL("ECH"),2)
;
F S DGLIN=$O(@DGWP@(DGLIN)) Q:'DGLIN D
. S DGTXT=$G(@DGWP@(DGLIN,0))
. S DGTXT=$$STRIPTS^DGPFHLUT(DGTXT) ;strip trailing spaces
. I DGTXT?1.PC!(DGTXT="") S DGBLK=DGBLK+1 Q
. S DGCNT=DGCNT+1
. I DGBLK D
. . S DGARR(DGCNT)=$$REPEAT^XLFSTR(DGREP,DGBLK)_DGTXT
. . S DGBLK=0
. E S DGARR(DGCNT)=DGTXT
Q DGCNT
;
NXTSEG(DGROOT,DGCURR,DGFS,DGFLD) ;retrieves next sequential segment
; This function retrieves the next segment in the work global, returns
; an array of field values and the segment's work global index. If
; the next segment does not exist, then the function returns a zero.
;
; Input:
; DGROOT - close root name of work global
; DGCURR - index of current segment
; DGFS - HL7 field separator character
;
; Output:
; Function Value - index of the next segment on success, 0 on failure
; DGFLD - array of segment field values
;
N NXTSEG
;
S DGCURR=DGCURR+1
S NXTSEG=$G(@DGROOT@(DGCURR,0))
I NXTSEG]"" D
. D GETFLDS(NXTSEG,DGFS,.DGFLD)
E D
. S DGCURR=0
Q DGCURR
;
GETFLDS(DGSEG,DGFS,DGFLD) ;retrieve HL7 segment fields into an array
;This procedure parses a single HL7 segment and builds an array
;subscripted by the field number that contains the data for that field.
;An additional subscript node, "TYPE" is created containing the segment
;type.
;
; Input:
; DGSEG - HL7 segment to parse
; DGFS - HL7 field separator
;
; Output:
; DGFLD - array of segment field values subscripted by field #
; Example: DGFLD(2)="DOE,JOHN"
;
N DGI
;
S DGFLD("TYPE")=$P(DGSEG,DGFS)
F DGI=2:1:$L(DGSEG,DGFS) D
. S DGFLD($S(DGFLD("TYPE")="MSH":DGI,1:DGI-1))=$P(DGSEG,DGFS,DGI)
Q
;
STRIPTS(DGSTR) ;Strip trailing spaces from a line of text
;
; Input:
; DGSTR - Text string
;
; Output:
; Function Value - Input text string with trailing spaces removed
;
N SPACE
S SPACE=$C(32)
F Q:$E(DGSTR,$L(DGSTR))'=SPACE S DGSTR=$E(DGSTR,1,$L(DGSTR)-1)
Q DGSTR
;
BLDSEG(DGTYP,DGVAL,DGHL) ;generic segment builder
;
; Input:
; DGTYP - segment type
; DGVAL - field data array [SUB1:field, SUB2:repetition,
; SUB3:component, SUB4:sub-component]
; DGHL - HL7 environment array
;
; Output:
; Function Value - Formatted HL7 segment on success, "" on failure
;
N DGCMP ;component subscript
N DGCMPVAL ;component value
N DGFLD ;field subscript
N DGFLDVAL ;field value
N DGREP ;repetition subscript
N DGREPVAL ;repetition value
N DGSUB ;sub-component subscript
N DGSUBVAL ;sub-component value
N DGFS ;field separator
N DGCS ;component separator
N DGRS ;repetition separator
N DGSS ;sub-component separator
N DGSEG
N DGSEP
;
Q:($G(DGTYP)']"") ""
;
S DGSEG=DGTYP
S DGFS=DGHL("FS")
S DGCS=$E(DGHL("ECH"))
S DGRS=$E(DGHL("ECH"),2)
S DGSS=$E(DGHL("ECH"),4)
;
F DGFLD=1:1:$O(DGVAL(""),-1) D
. S DGFLDVAL=$G(DGVAL(DGFLD)),DGSEP=DGFS
. D ADD(DGFLDVAL,DGSEP,.DGSEG)
. F DGREP=1:1:$O(DGVAL(DGFLD,""),-1) D
. . S DGREPVAL=$G(DGVAL(DGFLD,DGREP))
. . S DGSEP=$S(DGREP=1:"",1:DGRS)
. . D ADD(DGREPVAL,DGSEP,.DGSEG)
. . F DGCMP=1:1:$O(DGVAL(DGFLD,DGREP,""),-1) D
. . . S DGCMPVAL=$G(DGVAL(DGFLD,DGREP,DGCMP))
. . . S DGSEP=$S(DGCMP=1:"",1:DGCS)
. . . D ADD(DGCMPVAL,DGSEP,.DGSEG)
. . . F DGSUB=1:1:$O(DGVAL(DGFLD,DGREP,DGCMP,""),-1) D
. . . . S DGSUBVAL=$G(DGVAL(DGFLD,DGREP,DGCMP,DGSUB))
. . . . S DGSEP=$S(DGSUB=1:"",1:DGSS)
. . . . D ADD(DGSUBVAL,DGSEP,.DGSEG)
Q DGSEG
;
ADD(DGVAL,DGSEP,DGSEG) ;append a value onto segment
;
; Input:
; DGVAL - value to append
; DGSEP - HL7 separator
;
; Output:
; DGSEG - segment passed by reference
;
S DGSEP=$G(DGSEP)
S DGVAL=$G(DGVAL)
S DGSEG=DGSEG_DGSEP_DGVAL
Q
;
CKSTR(DGFLDS,DGSTR) ;validate comma-delimited HL7 field string
;
; Input:
; DGFLDS - (required) comma delimited string of required fields
; DGSTR - (optional) comma delimited string of fields to include
; in an HL7 segment.
;
; Output:
; Function Value - validated string of fields
;
N DGI ;generic index
N DGREQ ;required field
;
Q:($G(DGFLDS)']"") ""
S DGSTR=$G(DGSTR)
F DGI=1:1 S DGREQ=$P(DGFLDS,",",DGI) Q:DGREQ="" D
. I ","_DGSTR_","'[(","_DGREQ_",") S DGSTR=DGSTR_$S($L(DGSTR)>0:",",1:"")_DGREQ
Q DGSTR
;
CONVMID(DGID) ;convert #772 msgid to #773 msgid
;This function takes the HL7 message ID from the DIRECT^HLMA API result,
;which is based on the HL7 MESSAGE TEXT (#772) file IEN and converts it
;into a message ID based on the HL7 MESSAGE ADMINISTRATION (#773) file.
;
; Integration Agreements:
; #4564 - allows access to the "C" index of HL7 MESSAGE TEXT (#772)
; #4669 - allows access to the "B" index and MESSAGE ID (#2) field
; of HL7 MESSAGE ADMINISTRATION (#773) file.
; Input:
; DGID - HL7 message id returned from DIRECT^HLMA
;
; Output:
; Function value - returns HL7 message control ID from HL MESSAGE
; ADMINISTRATION (#773) file on success;
; 0 on failure
;
N DG772 ;HL7 MESSAGE TEXT (#772) file IEN
N DG773 ;HL7 MESSAGE ADMINISTRATION (#773) file IEN
N DGERR ;FM error array
N DGMCID ;message ID
;
S DG772=+$O(^HL(772,"C",+$G(DGID),0))
S DG773=+$O(^HLMA("B",DG772,0))
S DGMCID=+$$GET1^DIQ(773,DG773_",",2,"I","","DGERR")
Q $S(DGMCID&('$D(DGERR)):DGMCID,1:0)
;
ENCHL7(STR) ; Encode HL7 escape sequences in a string
;
; Input:
; STR = string possibly containing HL7 encoding chars
;
; HLFS and HLECH are assumed to be already initialized by HL7 (call to INIT^HLFNC2)
;
; Returns string with encoded escape seqs as follows:
; field separator (HLFS) --> \F\
; component separator (HLECH-1) --> \S\
; repetition separator (HLECH-2) --> \R\
; escape character (HLECH-3) --> \E\
; subcomponent separator (HLECH-4) --> \T\
;
N CHR,CHRSTR,CNT,ESC,FLG,NEW,RPLC,Z1,Z2
;
S ESC=$E(HLECH,3) ; escape character
S CHRSTR=HLFS_HLECH,FLG=0 F Z1=1:1:5 S CHR=$E(CHRSTR,Z1),CNT=$L(STR,CHR) I CNT>1 D
.S NEW=$P(STR,CHR)
.S RPLC=$C(26)_$TR(CHR,CHRSTR,"FSRET")_$C(26)
.F Z2=2:1:CNT S NEW=NEW_RPLC_$P(STR,CHR,Z2)
.S STR=NEW
.S FLG=1 ; flag to indicate that at least one escape sequence was encoded
.Q
S:FLG STR=$TR(STR,$C(26),ESC)
Q STR
;
DECHL7(STR) ; Decode HL7 escape sequences in a string
;
; Input:
; STR = string possibly containing HL7 escape sequences for encoding chars
;
; HLFS and HLECH are assumed to be already initialized by HL7 (call to INIT^HLFNC2)
;
; Returns string with decoded escape seqs as follows:
; \F\ --> field separator (HLFS)
; \S\ --> component separator (HLECH-1)
; \R\ --> repetition separator (HLECH-2)
; \E\ --> escape character (HLECH-3)
; \T\ --> subcomponent separator (HLECH-4)
;
; Note: if any of HL7 encoding characters is "^", it gets replaced with a single space
; in order to prevent filing problems.
;
N ECHARS,ECODE,ESC,LEN,PAT,PCE,REPL
;
; Replace ^ with a single space to prevent filing problems
S ECHARS=$TR(HLECH,"^"," ")
S ESC=$E(ECHARS,3) ; escape character
; Check for escape sequences, quit if none found
I STR'[ESC Q STR
; Array of rep. chars
S REPL("F")=$S(HLFS="^":" ",1:HLFS) ;Field delimiter
S REPL("S")=$E(ECHARS) ;Comp. delimiter
S REPL("R")=$E(ECHARS,2) ;Rep. delimiter
; Temp. replace w/ASC 26, until after other ESC are stripped
S REPL("E")=$C(26) ;Esc. char
S REPL("T")=$E(ECHARS,4) ;Subcomp. delimiter
; Translate escape seqs left to right
S LEN=$L(STR,ESC) F PCE=1:1:(LEN-1)\2 D
.; Ignore empty or unrecognized escape sequences
.S ECODE=$P(STR,ESC,2) I ECODE="" S ECODE="XXXX"
.I $D(REPL(ECODE))'>0 S STR=$P(STR,ESC)_$C(26)_$P(STR,ESC,2)_$C(26)_$P(STR,ESC,3,LEN) Q
.; Else, replace escape sequence with encoding character
.S STR=$P(STR,ESC)_$G(REPL(ECODE))_$P(STR,ESC,3,LEN)
;Replace the decoded ESC chars that were actually sent
S STR=$TR(STR,$C(26),ESC)
Q STR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLUT 10672 printed Apr 09, 2024@21:48:12 Page 2
DGPFHLUT ;ALB/RPM - PRF HL7 UTILITIES ; 2/12/2020
+1 ;;5.3;Registration;**425,650,951,1005**;Aug 13, 1993;Build 57
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;This routine contains generic utilities used when building
+5 ;or processing received patient record flag HL7 messages.
+6 ;
+7 ;no supported direct entry
QUIT
+8 ;
INIT(DGPROT,DGHL) ;Kernel HL7 INIT wrapper
+1 ;
+2 ; Supported DBIA #2161: The supported DBIA is used to access the
+3 ; VistA HL7 API to initialize the HL7 environ-
+4 ; ment variables.
+5 ;
+6 ; Input:
+7 ; DGPROT - Event protocol name
+8 ;
+9 ; Output:
+10 ; Function value - HLEID on success;0 on failure
+11 ; DGHL - HL array from INIT^HLFNC2 Kernel call
+12 ;
+13 NEW DGHLEID
+14 SET DGHLEID=0
+15 SET DGHLEID=$$HLEID(DGPROT)
+16 IF DGHLEID
Begin DoDot:1
+17 DO INIT^HLFNC2(DGHLEID,.DGHL)
+18 IF $ORDER(DGHL(""))=""
SET DGHLEID=0
End DoDot:1
+19 QUIT DGHLEID
+20 ;
HLEID(DGPROT) ;return IEN of HL7 protocol
+1 ;
+2 ; Input:
+3 ; DGPROT - Protocol name
+4 ;
+5 ; Output:
+6 ; Function value - IEN of protocol on success, 0 on failure
+7 ;
+8 IF $GET(DGPROT)=""
QUIT 0
+9 QUIT +$ORDER(^ORD(101,"B",DGPROT,0))
+10 ;
GETLINK(DGINST) ;retrieve a single link for a given institution
+1 ;
+2 ; Supported DBIA #2271: The supported DBIA is used to access the
+3 ; VistA HL7 API to retrieve logical links
+4 ; given a pointer to the INSTITUTION (#4) file.
+5 ;
+6 ; Input:
+7 ; DGINST - IEN of site in INSTITUTION (#4) file
+8 ;
+9 ; Output:
+10 ; Function Value - HL Logical link on success, 0 on failure
+11 ;
+12 NEW DGLINKS
+13 NEW DGLNK
+14 NEW DGRSLT
+15 ;
+16 SET DGRSLT=0
+17 IF $GET(DGINST)>0
Begin DoDot:1
+18 DO LINK^HLUTIL3(DGINST,.DGLINKS)
+19 SET DGLNK=$ORDER(DGLINKS(0))
+20 SET DGRSLT=$SELECT(DGLNK>0:DGLINKS(DGLNK),1:0)
End DoDot:1
+21 QUIT DGRSLT
+22 ;
BLDTEXT(DGWP,DGHL,DGARR) ;Build HL7 word proc text array
+1 ;
+2 ; Supported DBIA #10104: The supported DBIA is used to access KERNEL
+3 ; string functions.
+4 ;
+5 ; Input:
+6 ; DGWP - Word processing closed root
+7 ; DGHL - HL7 environment array
+8 ;
+9 ; Output:
+10 ; Function Value - count of segment array elements on success,
+11 ; 0 on failure
+12 ; DGARR - array of segment text data
+13 ;
+14 ;word processing line iterator
NEW DGLIN
+15 ;text segment counter
NEW DGCNT
+16 ;word processing text
NEW DGTXT
+17 ;blank line counter
NEW DGBLK
+18 ;HL7 repetition character
NEW DGREP
+19 ;
+20 SET DGLIN=0
+21 SET DGCNT=0
+22 SET DGBLK=0
+23 SET DGREP=$EXTRACT(DGHL("ECH"),2)
+24 ;
+25 FOR
SET DGLIN=$ORDER(@DGWP@(DGLIN))
if 'DGLIN
QUIT
Begin DoDot:1
+26 SET DGTXT=$GET(@DGWP@(DGLIN,0))
+27 ;strip trailing spaces
SET DGTXT=$$STRIPTS^DGPFHLUT(DGTXT)
+28 IF DGTXT?1.PC!(DGTXT="")
SET DGBLK=DGBLK+1
QUIT
+29 SET DGCNT=DGCNT+1
+30 IF DGBLK
Begin DoDot:2
+31 SET DGARR(DGCNT)=$$REPEAT^XLFSTR(DGREP,DGBLK)_DGTXT
+32 SET DGBLK=0
End DoDot:2
+33 IF '$TEST
SET DGARR(DGCNT)=DGTXT
End DoDot:1
+34 QUIT DGCNT
+35 ;
NXTSEG(DGROOT,DGCURR,DGFS,DGFLD) ;retrieves next sequential segment
+1 ; This function retrieves the next segment in the work global, returns
+2 ; an array of field values and the segment's work global index. If
+3 ; the next segment does not exist, then the function returns a zero.
+4 ;
+5 ; Input:
+6 ; DGROOT - close root name of work global
+7 ; DGCURR - index of current segment
+8 ; DGFS - HL7 field separator character
+9 ;
+10 ; Output:
+11 ; Function Value - index of the next segment on success, 0 on failure
+12 ; DGFLD - array of segment field values
+13 ;
+14 NEW NXTSEG
+15 ;
+16 SET DGCURR=DGCURR+1
+17 SET NXTSEG=$GET(@DGROOT@(DGCURR,0))
+18 IF NXTSEG]""
Begin DoDot:1
+19 DO GETFLDS(NXTSEG,DGFS,.DGFLD)
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 SET DGCURR=0
End DoDot:1
+22 QUIT DGCURR
+23 ;
GETFLDS(DGSEG,DGFS,DGFLD) ;retrieve HL7 segment fields into an array
+1 ;This procedure parses a single HL7 segment and builds an array
+2 ;subscripted by the field number that contains the data for that field.
+3 ;An additional subscript node, "TYPE" is created containing the segment
+4 ;type.
+5 ;
+6 ; Input:
+7 ; DGSEG - HL7 segment to parse
+8 ; DGFS - HL7 field separator
+9 ;
+10 ; Output:
+11 ; DGFLD - array of segment field values subscripted by field #
+12 ; Example: DGFLD(2)="DOE,JOHN"
+13 ;
+14 NEW DGI
+15 ;
+16 SET DGFLD("TYPE")=$PIECE(DGSEG,DGFS)
+17 FOR DGI=2:1:$LENGTH(DGSEG,DGFS)
Begin DoDot:1
+18 SET DGFLD($SELECT(DGFLD("TYPE")="MSH":DGI,1:DGI-1))=$PIECE(DGSEG,DGFS,DGI)
End DoDot:1
+19 QUIT
+20 ;
STRIPTS(DGSTR) ;Strip trailing spaces from a line of text
+1 ;
+2 ; Input:
+3 ; DGSTR - Text string
+4 ;
+5 ; Output:
+6 ; Function Value - Input text string with trailing spaces removed
+7 ;
+8 NEW SPACE
+9 SET SPACE=$CHAR(32)
+10 FOR
if $EXTRACT(DGSTR,$LENGTH(DGSTR))'=SPACE
QUIT
SET DGSTR=$EXTRACT(DGSTR,1,$LENGTH(DGSTR)-1)
+11 QUIT DGSTR
+12 ;
BLDSEG(DGTYP,DGVAL,DGHL) ;generic segment builder
+1 ;
+2 ; Input:
+3 ; DGTYP - segment type
+4 ; DGVAL - field data array [SUB1:field, SUB2:repetition,
+5 ; SUB3:component, SUB4:sub-component]
+6 ; DGHL - HL7 environment array
+7 ;
+8 ; Output:
+9 ; Function Value - Formatted HL7 segment on success, "" on failure
+10 ;
+11 ;component subscript
NEW DGCMP
+12 ;component value
NEW DGCMPVAL
+13 ;field subscript
NEW DGFLD
+14 ;field value
NEW DGFLDVAL
+15 ;repetition subscript
NEW DGREP
+16 ;repetition value
NEW DGREPVAL
+17 ;sub-component subscript
NEW DGSUB
+18 ;sub-component value
NEW DGSUBVAL
+19 ;field separator
NEW DGFS
+20 ;component separator
NEW DGCS
+21 ;repetition separator
NEW DGRS
+22 ;sub-component separator
NEW DGSS
+23 NEW DGSEG
+24 NEW DGSEP
+25 ;
+26 if ($GET(DGTYP)']"")
QUIT ""
+27 ;
+28 SET DGSEG=DGTYP
+29 SET DGFS=DGHL("FS")
+30 SET DGCS=$EXTRACT(DGHL("ECH"))
+31 SET DGRS=$EXTRACT(DGHL("ECH"),2)
+32 SET DGSS=$EXTRACT(DGHL("ECH"),4)
+33 ;
+34 FOR DGFLD=1:1:$ORDER(DGVAL(""),-1)
Begin DoDot:1
+35 SET DGFLDVAL=$GET(DGVAL(DGFLD))
SET DGSEP=DGFS
+36 DO ADD(DGFLDVAL,DGSEP,.DGSEG)
+37 FOR DGREP=1:1:$ORDER(DGVAL(DGFLD,""),-1)
Begin DoDot:2
+38 SET DGREPVAL=$GET(DGVAL(DGFLD,DGREP))
+39 SET DGSEP=$SELECT(DGREP=1:"",1:DGRS)
+40 DO ADD(DGREPVAL,DGSEP,.DGSEG)
+41 FOR DGCMP=1:1:$ORDER(DGVAL(DGFLD,DGREP,""),-1)
Begin DoDot:3
+42 SET DGCMPVAL=$GET(DGVAL(DGFLD,DGREP,DGCMP))
+43 SET DGSEP=$SELECT(DGCMP=1:"",1:DGCS)
+44 DO ADD(DGCMPVAL,DGSEP,.DGSEG)
+45 FOR DGSUB=1:1:$ORDER(DGVAL(DGFLD,DGREP,DGCMP,""),-1)
Begin DoDot:4
+46 SET DGSUBVAL=$GET(DGVAL(DGFLD,DGREP,DGCMP,DGSUB))
+47 SET DGSEP=$SELECT(DGSUB=1:"",1:DGSS)
+48 DO ADD(DGSUBVAL,DGSEP,.DGSEG)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+49 QUIT DGSEG
+50 ;
ADD(DGVAL,DGSEP,DGSEG) ;append a value onto segment
+1 ;
+2 ; Input:
+3 ; DGVAL - value to append
+4 ; DGSEP - HL7 separator
+5 ;
+6 ; Output:
+7 ; DGSEG - segment passed by reference
+8 ;
+9 SET DGSEP=$GET(DGSEP)
+10 SET DGVAL=$GET(DGVAL)
+11 SET DGSEG=DGSEG_DGSEP_DGVAL
+12 QUIT
+13 ;
CKSTR(DGFLDS,DGSTR) ;validate comma-delimited HL7 field string
+1 ;
+2 ; Input:
+3 ; DGFLDS - (required) comma delimited string of required fields
+4 ; DGSTR - (optional) comma delimited string of fields to include
+5 ; in an HL7 segment.
+6 ;
+7 ; Output:
+8 ; Function Value - validated string of fields
+9 ;
+10 ;generic index
NEW DGI
+11 ;required field
NEW DGREQ
+12 ;
+13 if ($GET(DGFLDS)']"")
QUIT ""
+14 SET DGSTR=$GET(DGSTR)
+15 FOR DGI=1:1
SET DGREQ=$PIECE(DGFLDS,",",DGI)
if DGREQ=""
QUIT
Begin DoDot:1
+16 IF ","_DGSTR_","'[(","_DGREQ_",")
SET DGSTR=DGSTR_$SELECT($LENGTH(DGSTR)>0:",",1:"")_DGREQ
End DoDot:1
+17 QUIT DGSTR
+18 ;
CONVMID(DGID) ;convert #772 msgid to #773 msgid
+1 ;This function takes the HL7 message ID from the DIRECT^HLMA API result,
+2 ;which is based on the HL7 MESSAGE TEXT (#772) file IEN and converts it
+3 ;into a message ID based on the HL7 MESSAGE ADMINISTRATION (#773) file.
+4 ;
+5 ; Integration Agreements:
+6 ; #4564 - allows access to the "C" index of HL7 MESSAGE TEXT (#772)
+7 ; #4669 - allows access to the "B" index and MESSAGE ID (#2) field
+8 ; of HL7 MESSAGE ADMINISTRATION (#773) file.
+9 ; Input:
+10 ; DGID - HL7 message id returned from DIRECT^HLMA
+11 ;
+12 ; Output:
+13 ; Function value - returns HL7 message control ID from HL MESSAGE
+14 ; ADMINISTRATION (#773) file on success;
+15 ; 0 on failure
+16 ;
+17 ;HL7 MESSAGE TEXT (#772) file IEN
NEW DG772
+18 ;HL7 MESSAGE ADMINISTRATION (#773) file IEN
NEW DG773
+19 ;FM error array
NEW DGERR
+20 ;message ID
NEW DGMCID
+21 ;
+22 SET DG772=+$ORDER(^HL(772,"C",+$GET(DGID),0))
+23 SET DG773=+$ORDER(^HLMA("B",DG772,0))
+24 SET DGMCID=+$$GET1^DIQ(773,DG773_",",2,"I","","DGERR")
+25 QUIT $SELECT(DGMCID&('$DATA(DGERR)):DGMCID,1:0)
+26 ;
ENCHL7(STR) ; Encode HL7 escape sequences in a string
+1 ;
+2 ; Input:
+3 ; STR = string possibly containing HL7 encoding chars
+4 ;
+5 ; HLFS and HLECH are assumed to be already initialized by HL7 (call to INIT^HLFNC2)
+6 ;
+7 ; Returns string with encoded escape seqs as follows:
+8 ; field separator (HLFS) --> \F\
+9 ; component separator (HLECH-1) --> \S\
+10 ; repetition separator (HLECH-2) --> \R\
+11 ; escape character (HLECH-3) --> \E\
+12 ; subcomponent separator (HLECH-4) --> \T\
+13 ;
+14 NEW CHR,CHRSTR,CNT,ESC,FLG,NEW,RPLC,Z1,Z2
+15 ;
+16 ; escape character
SET ESC=$EXTRACT(HLECH,3)
+17 SET CHRSTR=HLFS_HLECH
SET FLG=0
FOR Z1=1:1:5
SET CHR=$EXTRACT(CHRSTR,Z1)
SET CNT=$LENGTH(STR,CHR)
IF CNT>1
Begin DoDot:1
+18 SET NEW=$PIECE(STR,CHR)
+19 SET RPLC=$CHAR(26)_$TRANSLATE(CHR,CHRSTR,"FSRET")_$CHAR(26)
+20 FOR Z2=2:1:CNT
SET NEW=NEW_RPLC_$PIECE(STR,CHR,Z2)
+21 SET STR=NEW
+22 ; flag to indicate that at least one escape sequence was encoded
SET FLG=1
+23 QUIT
End DoDot:1
+24 if FLG
SET STR=$TRANSLATE(STR,$CHAR(26),ESC)
+25 QUIT STR
+26 ;
DECHL7(STR) ; Decode HL7 escape sequences in a string
+1 ;
+2 ; Input:
+3 ; STR = string possibly containing HL7 escape sequences for encoding chars
+4 ;
+5 ; HLFS and HLECH are assumed to be already initialized by HL7 (call to INIT^HLFNC2)
+6 ;
+7 ; Returns string with decoded escape seqs as follows:
+8 ; \F\ --> field separator (HLFS)
+9 ; \S\ --> component separator (HLECH-1)
+10 ; \R\ --> repetition separator (HLECH-2)
+11 ; \E\ --> escape character (HLECH-3)
+12 ; \T\ --> subcomponent separator (HLECH-4)
+13 ;
+14 ; Note: if any of HL7 encoding characters is "^", it gets replaced with a single space
+15 ; in order to prevent filing problems.
+16 ;
+17 NEW ECHARS,ECODE,ESC,LEN,PAT,PCE,REPL
+18 ;
+19 ; Replace ^ with a single space to prevent filing problems
+20 SET ECHARS=$TRANSLATE(HLECH,"^"," ")
+21 ; escape character
SET ESC=$EXTRACT(ECHARS,3)
+22 ; Check for escape sequences, quit if none found
+23 IF STR'[ESC
QUIT STR
+24 ; Array of rep. chars
+25 ;Field delimiter
SET REPL("F")=$SELECT(HLFS="^":" ",1:HLFS)
+26 ;Comp. delimiter
SET REPL("S")=$EXTRACT(ECHARS)
+27 ;Rep. delimiter
SET REPL("R")=$EXTRACT(ECHARS,2)
+28 ; Temp. replace w/ASC 26, until after other ESC are stripped
+29 ;Esc. char
SET REPL("E")=$CHAR(26)
+30 ;Subcomp. delimiter
SET REPL("T")=$EXTRACT(ECHARS,4)
+31 ; Translate escape seqs left to right
+32 SET LEN=$LENGTH(STR,ESC)
FOR PCE=1:1:(LEN-1)\2
Begin DoDot:1
+33 ; Ignore empty or unrecognized escape sequences
+34 SET ECODE=$PIECE(STR,ESC,2)
IF ECODE=""
SET ECODE="XXXX"
+35 IF $DATA(REPL(ECODE))'>0
SET STR=$PIECE(STR,ESC)_$CHAR(26)_$PIECE(STR,ESC,2)_$CHAR(26)_$PIECE(STR,ESC,3,LEN)
QUIT
+36 ; Else, replace escape sequence with encoding character
+37 SET STR=$PIECE(STR,ESC)_$GET(REPL(ECODE))_$PIECE(STR,ESC,3,LEN)
End DoDot:1
+38 ;Replace the decoded ESC chars that were actually sent
+39 SET STR=$TRANSLATE(STR,$CHAR(26),ESC)
+40 QUIT STR
