Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPFHLUT

DGPFHLUT.m

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