- 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 Jan 18, 2025@03:48:41 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