- MDCUTL ;HINES OIFO/DP/BJ/TJ - HL7 Message Utilities;07 June 2007
- ;;1.0;CLINICAL PROCEDURES;**16,12,23**;Apr 01, 2004;Build 281
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;1.0;Create HL7 A04 Message;;Mar 10, 2005 ; Patch IB*2.0*286
- ;
- ; This routine uses the following Integration Agreements (IAs):
- ; # 2050 - $$EZBLD^DIALOG() FILEMAN (supported)
- ;
- Q
- ;
- MOREDLMS ;; maintain HL7 delimiters based on prev. HL7 INIT for the protocol
- S HLMAXLEN=245
- S HLFS=$G(HL("FS")) I HLFS="" S HLFS="^"
- S HLCM=$E(HL("ECH"),1),HLRP=$E(HL("ECH"),2)
- S HLES=$E(HL("ECH"),3),HLSC=$E(HL("ECH"),4)
- S HL7RC=HLES_HLFS_HLCM_HLRP_HLSC,HLECH=HL("ECH"),HLQ=HL("Q")
- Q
- ;
- EMPTY(SEG,ERR,HLQFLAG,STFIELD,ENDFIELD) ;
- ;
- ;This function will check an HL7 segment delimited by the HL7 field
- ;separator for a specified field range and determine if the segment
- ;within the specified field range contains data or is empty. If
- ;no specified starting field range, then starting field defaults to the
- ;first field in the segment. If no specified ending field range, then
- ;ending field defaults to the last field in the segment as determined
- ;by $L(SEG,HLFS).
- ;
- ;
- ;INPUT:
- ; SEG -- (Required) HL7 segment to be evaluated.
- ; ERR -- (Required) Passed by reference and is only defined
- ; within this function if an error occurs.
- ; HLQFLAG -- (Optional) Flag to indicate if HL7 Null Variable
- ; HLQ is considered for evaluation.
- ; If sent, then '1' indicates consideration and '0'
- ; indicates no consideration.
- ; If not sent, then default is not to consider HLQ
- ; for evaluation.
- ; STFIELD -- (Optional) Segment field to start evaluation from
- ; as determined by field separator HLFS.
- ; If not sent, then default equals '1'.
- ; ENDFIELD -- (Optional) Segment field to end evaluation to as
- ; determined by field separator HLFS.
- ; If not sent, then default equals '$L(SEG,HLFS)'.
- ;
- ;OUTPUT:
- ; 1 -- Segment field range contains data or
- ; 0 -- Segment field range doesn't contain data or
- ; "" -- Error has occurred. In this case, error returned
- ; in variable ERR.
- ; ERR -- Error message text. Is only defined if and error
- ; has occurred within this function.
- ;
- Q:$G(SEG)="" 0
- N COMP
- S HLQFLAG=$S($G(HLQFLAG)'="":HLQFLAG,1:0)
- I (HLQFLAG'=1),(HLQFLAG'=0) D EMPTYERR("HLQFLAG") Q ""
- S STFIELD=$S($G(STFIELD)'="":STFIELD,1:1)
- I (STFIELD'?1N.N)!(STFIELD<1)!(STFIELD>$L(SEG,HLFS)) D EMPTYERR("STFIELD") Q ""
- S ENDFIELD=$S($G(ENDFIELD)'="":ENDFIELD,1:$L(SEG,HLFS))
- I (ENDFIELD'?1N.N)!(ENDFIELD<1)!(ENDFIELD>$L(SEG,HLFS)) D EMPTYERR("ENDFIELD") Q ""
- S COMP=$P(SEG,HLFS,STFIELD,ENDFIELD)
- Q:COMP="" 0
- I HLQFLAG,$TR(COMP,HLQ_HL7RC)="" Q 0
- I 'HLQFLAG,$TR(COMP,HL7RC)="" Q 0
- Q 1
- ;
- EMPTYERR(NAME) ;Error message module
- ;
- N MDCPARM
- ;
- ;Setup error message parameter for call to Dialog File
- ;for dialog 3750007.
- ;Dialog 3750007 => Message could not be built. Error occurred in |1|.
- ;
- S MDCPARM(1)="$$EMPTY^IBBVUTL - unacceptable "_NAME_" parameter value of "_@NAME
- ;
- ;Return error message text in variable ERR.
- ;
- S ERR=$$EZBLD^DIALOG(3750007,.MDCPARM)
- Q
- ESC(FIELD) ;
- ;
- NEW DEL,HLES,IDEL,REP
- ;
- S HLES=$E(HL("ECH"),3)
- S DEL(1)=HLES,REP(1)="E" ; escape character must be first in list
- S DEL(2)=$E(HL("ECH"),2),REP(2)="R"
- S DEL(3)=$E(HL("ECH")),REP(3)="S"
- S DEL(4)=$E(HL("FS")),REP(4)="F"
- S DEL(5)=$E(HL("ECH"),4),REP(5)="T"
- ;
- F IDEL=1:1:5 D
- . Q:FIELD'[DEL(IDEL)
- . S FIELD=$$REP(FIELD,DEL(IDEL),HLES_REP(IDEL)_HLES)
- . Q
- Q FIELD
- ;
- REP(STR,REM,REP) ; remove all occurrences of REM from STR and replace with REP
- ;
- Q:STR'[REM STR
- Q $P(STR,REM,1)_REP_$$REP($P(STR,REM,2,$L(STR,REM)),REM,REP)
- ;
- ;
- REMQQ(STR) ; removes two double quotes surrounded by HL7 delimiters from STR
- ;
- NEW POS,DELIMS,BEFORE,AFTER
- S DELIMS=HL("ECH")_HL("FS")
- ;
- S POS=$F(STR,HLQ)
- Q:POS=0 STR
- S BEFORE=$E(STR,POS-3)
- S AFTER=$E(STR,POS)
- ;
- Q:DELIMS'[BEFORE!(DELIMS'[AFTER) $E(STR,1,POS-1)_$$REMQQ($E(STR,POS,$L(STR)))
- ;
- Q $E(STR,1,POS-3)_$$REMQQ($E(STR,POS,$L(STR)))
- ;
- ;
- MAKESEG(RAWARAY,SEGARAY,SEGNUM,SEGID) ;Make segment using obtained fields
- ;
- ; - This subroutine takes a one dimensional array of fields and turns it into an
- ; an HL7 segment (segment string). The subscript of each element in the field array
- ; corresponds to the number of a field in a HL7 specification, such as might be found
- ; in the Message Work Bench (MWB) tool. Each string within the array is assumed to
- ; be already formatted in regard to such matters as components and sub-components.
- ; If the length of the HL7 string exceeds 245 characters, it must be broken up into
- ; chunks, none of which may exceed 245 characters. The chunks are returned in an array.
- ; Fields are not split across chunks.
- ;
- ;Input:
- ; RAWARAY = 1 dimensional array of fields, each subscript corresponding to an HL7
- ; specification field number (!pass by reference!)
- ; SEGARAY = array of chunks where the constructed segment goes (!pass by reference!)
- ; SEGNUM = if greater than zero, number denoting Xth repetition of the SEGID segment.
- ; if less than 1, the first (or only) chunk has no subscript
- ; SEGID = Segment ID string (defaults to "")
- ; HLMAXLEN = Maximum length of each segment chunk (defaults to 245) (assumed variable)
- ; HL7 encoding characters (HLFS, HLENC, HLQ)
- ;
- ;Output: SEGARAY(SEGNUM) = SEGID segment (first SMAXL characters)
- ; SEGARAY(SEGNUM,x) = Remaining portion(S) of SEGID segment in
- ; SMAXL character chunks (if needed)
- ; beginning with a field separator
- ;
- ;Notes: SEGARAY(SEGNUM) is initialized (KILLed) on input
- ; : Fields will not be split across chunks in SEGARAY()
- ;
- N SEQ,SPILL,SPILLON,SPOT,LASTSEQ,SPTR,SMAXL,PTSS
- ; - first assume segment array number not present (less than 1)
- S SPTR="SEGARAY",PTSS="SEGARAY(SPILL)"
- ; - if array number present, arrange to use it as subscript
- I +$G(SEGNUM)>0 S SPTR="SEGARAY(SEGNUM)",PTSS="SEGARAY(SEGNUM,SPILL)" ;SEGNUM=$TR(SEGNUM,"_",",")
- ; - initialize segment (output) array
- K @SPTR
- S @SPTR=$G(SEGID)
- ; - if not some value, make max the system max
- S SMAXL=+$G(HLMAXLEN) S:'SMAXL SMAXL=245
- ; - initialize some "pointers"
- S (SPILL,SPILLON)=0
- S LASTSEQ=+$O(RAWARAY(""),-1)
- ; - scan through field array, creating segment array as we go
- F SEQ=1:1:LASTSEQ D
- .; - Make sure maximum length won't be exceeded
- .I ($L(@SPTR)+$L($G(RAWARAY(SEQ)))+1)>SMAXL D
- ..; - Max length exceeded - start putting data on next node
- ..S SPILL=SPILL+1
- ..S SPILLON=SEQ-1
- ..S SPTR=PTSS
- .; - Add to string
- .S SPOT=(SEQ+1)-SPILLON
- .S $P(@SPTR,HLFS,SPOT)=$G(RAWARAY(SEQ))
- ; - Done
- Q
- ;
- RETRANS ; Retransmit ADT from file 704.005
- ; Get the entry from file 704.005
- N STYPE,RETRN,DYNAMIC,EVNTDRVR,REQIEN,DYNAMIC,DIC
- S DIC=704.005,DIC(0)="AEQM" D ^DIC Q:+Y<1 S MDIENS=+Y_","
- S MDCPEVNT=$$GET1^DIQ(704.005,MDIENS,.07,"E")
- S MDCPMSG=$$GET1^DIQ(704.005,MDIENS,.06,"E")
- S STYPE=$S(MDCPEVNT="A01":"CPAN",MDCPEVNT="A02":"CPTP",MDCPEVNT="A03":"CPDE",MDCPEVNT="A08":"CPUI",MDCPEVNT="A11":"CPCAN",MDCPEVNT="A12":"CPCT",MDCPEVNT="A13":"CPCDE",1:"")
- S MDCPPAIR="SUBTYPE="_STYPE_"^IEN="_+MDIENS
- K MDCFDA
- F X="MDCPMSG","MDCPEVNT","MDCPPAIR" D
- .W !,X,"=",$G(@X,"<NIL>")
- S MDCFDA(704.005,MDIENS,.09)=$$QUE^MDCPMESQ(MDIENS,MDCPEVNT,.RETRN)
- S:MDCFDA(704.005,MDIENS,.09)=0 MDCFDA(704.005,MDIENS,.1)=$G(RETRN,"No return message.")
- D UPDATE^DIE("","MDCFDA")
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDCUTL 8002 printed Jan 18, 2025@02:43:51 Page 2
- MDCUTL ;HINES OIFO/DP/BJ/TJ - HL7 Message Utilities;07 June 2007
- +1 ;;1.0;CLINICAL PROCEDURES;**16,12,23**;Apr 01, 2004;Build 281
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;1.0;Create HL7 A04 Message;;Mar 10, 2005 ; Patch IB*2.0*286
- +5 ;
- +6 ; This routine uses the following Integration Agreements (IAs):
- +7 ; # 2050 - $$EZBLD^DIALOG() FILEMAN (supported)
- +8 ;
- +9 QUIT
- +10 ;
- MOREDLMS ;; maintain HL7 delimiters based on prev. HL7 INIT for the protocol
- +1 SET HLMAXLEN=245
- +2 SET HLFS=$GET(HL("FS"))
- IF HLFS=""
- SET HLFS="^"
- +3 SET HLCM=$EXTRACT(HL("ECH"),1)
- SET HLRP=$EXTRACT(HL("ECH"),2)
- +4 SET HLES=$EXTRACT(HL("ECH"),3)
- SET HLSC=$EXTRACT(HL("ECH"),4)
- +5 SET HL7RC=HLES_HLFS_HLCM_HLRP_HLSC
- SET HLECH=HL("ECH")
- SET HLQ=HL("Q")
- +6 QUIT
- +7 ;
- EMPTY(SEG,ERR,HLQFLAG,STFIELD,ENDFIELD) ;
- +1 ;
- +2 ;This function will check an HL7 segment delimited by the HL7 field
- +3 ;separator for a specified field range and determine if the segment
- +4 ;within the specified field range contains data or is empty. If
- +5 ;no specified starting field range, then starting field defaults to the
- +6 ;first field in the segment. If no specified ending field range, then
- +7 ;ending field defaults to the last field in the segment as determined
- +8 ;by $L(SEG,HLFS).
- +9 ;
- +10 ;
- +11 ;INPUT:
- +12 ; SEG -- (Required) HL7 segment to be evaluated.
- +13 ; ERR -- (Required) Passed by reference and is only defined
- +14 ; within this function if an error occurs.
- +15 ; HLQFLAG -- (Optional) Flag to indicate if HL7 Null Variable
- +16 ; HLQ is considered for evaluation.
- +17 ; If sent, then '1' indicates consideration and '0'
- +18 ; indicates no consideration.
- +19 ; If not sent, then default is not to consider HLQ
- +20 ; for evaluation.
- +21 ; STFIELD -- (Optional) Segment field to start evaluation from
- +22 ; as determined by field separator HLFS.
- +23 ; If not sent, then default equals '1'.
- +24 ; ENDFIELD -- (Optional) Segment field to end evaluation to as
- +25 ; determined by field separator HLFS.
- +26 ; If not sent, then default equals '$L(SEG,HLFS)'.
- +27 ;
- +28 ;OUTPUT:
- +29 ; 1 -- Segment field range contains data or
- +30 ; 0 -- Segment field range doesn't contain data or
- +31 ; "" -- Error has occurred. In this case, error returned
- +32 ; in variable ERR.
- +33 ; ERR -- Error message text. Is only defined if and error
- +34 ; has occurred within this function.
- +35 ;
- +36 if $GET(SEG)=""
- QUIT 0
- +37 NEW COMP
- +38 SET HLQFLAG=$SELECT($GET(HLQFLAG)'="":HLQFLAG,1:0)
- +39 IF (HLQFLAG'=1)
- IF (HLQFLAG'=0)
- DO EMPTYERR("HLQFLAG")
- QUIT ""
- +40 SET STFIELD=$SELECT($GET(STFIELD)'="":STFIELD,1:1)
- +41 IF (STFIELD'?1N.N)!(STFIELD<1)!(STFIELD>$LENGTH(SEG,HLFS))
- DO EMPTYERR("STFIELD")
- QUIT ""
- +42 SET ENDFIELD=$SELECT($GET(ENDFIELD)'="":ENDFIELD,1:$LENGTH(SEG,HLFS))
- +43 IF (ENDFIELD'?1N.N)!(ENDFIELD<1)!(ENDFIELD>$LENGTH(SEG,HLFS))
- DO EMPTYERR("ENDFIELD")
- QUIT ""
- +44 SET COMP=$PIECE(SEG,HLFS,STFIELD,ENDFIELD)
- +45 if COMP=""
- QUIT 0
- +46 IF HLQFLAG
- IF $TRANSLATE(COMP,HLQ_HL7RC)=""
- QUIT 0
- +47 IF 'HLQFLAG
- IF $TRANSLATE(COMP,HL7RC)=""
- QUIT 0
- +48 QUIT 1
- +49 ;
- EMPTYERR(NAME) ;Error message module
- +1 ;
- +2 NEW MDCPARM
- +3 ;
- +4 ;Setup error message parameter for call to Dialog File
- +5 ;for dialog 3750007.
- +6 ;Dialog 3750007 => Message could not be built. Error occurred in |1|.
- +7 ;
- +8 SET MDCPARM(1)="$$EMPTY^IBBVUTL - unacceptable "_NAME_" parameter value of "_@NAME
- +9 ;
- +10 ;Return error message text in variable ERR.
- +11 ;
- +12 SET ERR=$$EZBLD^DIALOG(3750007,.MDCPARM)
- +13 QUIT
- ESC(FIELD) ;
- +1 ;
- +2 NEW DEL,HLES,IDEL,REP
- +3 ;
- +4 SET HLES=$EXTRACT(HL("ECH"),3)
- +5 ; escape character must be first in list
- SET DEL(1)=HLES
- SET REP(1)="E"
- +6 SET DEL(2)=$EXTRACT(HL("ECH"),2)
- SET REP(2)="R"
- +7 SET DEL(3)=$EXTRACT(HL("ECH"))
- SET REP(3)="S"
- +8 SET DEL(4)=$EXTRACT(HL("FS"))
- SET REP(4)="F"
- +9 SET DEL(5)=$EXTRACT(HL("ECH"),4)
- SET REP(5)="T"
- +10 ;
- +11 FOR IDEL=1:1:5
- Begin DoDot:1
- +12 if FIELD'[DEL(IDEL)
- QUIT
- +13 SET FIELD=$$REP(FIELD,DEL(IDEL),HLES_REP(IDEL)_HLES)
- +14 QUIT
- End DoDot:1
- +15 QUIT FIELD
- +16 ;
- REP(STR,REM,REP) ; remove all occurrences of REM from STR and replace with REP
- +1 ;
- +2 if STR'[REM
- QUIT STR
- +3 QUIT $PIECE(STR,REM,1)_REP_$$REP($PIECE(STR,REM,2,$LENGTH(STR,REM)),REM,REP)
- +4 ;
- +5 ;
- REMQQ(STR) ; removes two double quotes surrounded by HL7 delimiters from STR
- +1 ;
- +2 NEW POS,DELIMS,BEFORE,AFTER
- +3 SET DELIMS=HL("ECH")_HL("FS")
- +4 ;
- +5 SET POS=$FIND(STR,HLQ)
- +6 if POS=0
- QUIT STR
- +7 SET BEFORE=$EXTRACT(STR,POS-3)
- +8 SET AFTER=$EXTRACT(STR,POS)
- +9 ;
- +10 if DELIMS'[BEFORE!(DELIMS'[AFTER)
- QUIT $EXTRACT(STR,1,POS-1)_$$REMQQ($EXTRACT(STR,POS,$LENGTH(STR)))
- +11 ;
- +12 QUIT $EXTRACT(STR,1,POS-3)_$$REMQQ($EXTRACT(STR,POS,$LENGTH(STR)))
- +13 ;
- +14 ;
- MAKESEG(RAWARAY,SEGARAY,SEGNUM,SEGID) ;Make segment using obtained fields
- +1 ;
- +2 ; - This subroutine takes a one dimensional array of fields and turns it into an
- +3 ; an HL7 segment (segment string). The subscript of each element in the field array
- +4 ; corresponds to the number of a field in a HL7 specification, such as might be found
- +5 ; in the Message Work Bench (MWB) tool. Each string within the array is assumed to
- +6 ; be already formatted in regard to such matters as components and sub-components.
- +7 ; If the length of the HL7 string exceeds 245 characters, it must be broken up into
- +8 ; chunks, none of which may exceed 245 characters. The chunks are returned in an array.
- +9 ; Fields are not split across chunks.
- +10 ;
- +11 ;Input:
- +12 ; RAWARAY = 1 dimensional array of fields, each subscript corresponding to an HL7
- +13 ; specification field number (!pass by reference!)
- +14 ; SEGARAY = array of chunks where the constructed segment goes (!pass by reference!)
- +15 ; SEGNUM = if greater than zero, number denoting Xth repetition of the SEGID segment.
- +16 ; if less than 1, the first (or only) chunk has no subscript
- +17 ; SEGID = Segment ID string (defaults to "")
- +18 ; HLMAXLEN = Maximum length of each segment chunk (defaults to 245) (assumed variable)
- +19 ; HL7 encoding characters (HLFS, HLENC, HLQ)
- +20 ;
- +21 ;Output: SEGARAY(SEGNUM) = SEGID segment (first SMAXL characters)
- +22 ; SEGARAY(SEGNUM,x) = Remaining portion(S) of SEGID segment in
- +23 ; SMAXL character chunks (if needed)
- +24 ; beginning with a field separator
- +25 ;
- +26 ;Notes: SEGARAY(SEGNUM) is initialized (KILLed) on input
- +27 ; : Fields will not be split across chunks in SEGARAY()
- +28 ;
- +29 NEW SEQ,SPILL,SPILLON,SPOT,LASTSEQ,SPTR,SMAXL,PTSS
- +30 ; - first assume segment array number not present (less than 1)
- +31 SET SPTR="SEGARAY"
- SET PTSS="SEGARAY(SPILL)"
- +32 ; - if array number present, arrange to use it as subscript
- +33 ;SEGNUM=$TR(SEGNUM,"_",",")
- IF +$GET(SEGNUM)>0
- SET SPTR="SEGARAY(SEGNUM)"
- SET PTSS="SEGARAY(SEGNUM,SPILL)"
- +34 ; - initialize segment (output) array
- +35 KILL @SPTR
- +36 SET @SPTR=$GET(SEGID)
- +37 ; - if not some value, make max the system max
- +38 SET SMAXL=+$GET(HLMAXLEN)
- if 'SMAXL
- SET SMAXL=245
- +39 ; - initialize some "pointers"
- +40 SET (SPILL,SPILLON)=0
- +41 SET LASTSEQ=+$ORDER(RAWARAY(""),-1)
- +42 ; - scan through field array, creating segment array as we go
- +43 FOR SEQ=1:1:LASTSEQ
- Begin DoDot:1
- +44 ; - Make sure maximum length won't be exceeded
- +45 IF ($LENGTH(@SPTR)+$LENGTH($GET(RAWARAY(SEQ)))+1)>SMAXL
- Begin DoDot:2
- +46 ; - Max length exceeded - start putting data on next node
- +47 SET SPILL=SPILL+1
- +48 SET SPILLON=SEQ-1
- +49 SET SPTR=PTSS
- End DoDot:2
- +50 ; - Add to string
- +51 SET SPOT=(SEQ+1)-SPILLON
- +52 SET $PIECE(@SPTR,HLFS,SPOT)=$GET(RAWARAY(SEQ))
- End DoDot:1
- +53 ; - Done
- +54 QUIT
- +55 ;
- RETRANS ; Retransmit ADT from file 704.005
- +1 ; Get the entry from file 704.005
- +2 NEW STYPE,RETRN,DYNAMIC,EVNTDRVR,REQIEN,DYNAMIC,DIC
- +3 SET DIC=704.005
- SET DIC(0)="AEQM"
- DO ^DIC
- if +Y<1
- QUIT
- SET MDIENS=+Y_","
- +4 SET MDCPEVNT=$$GET1^DIQ(704.005,MDIENS,.07,"E")
- +5 SET MDCPMSG=$$GET1^DIQ(704.005,MDIENS,.06,"E")
- +6 SET STYPE=$SELECT(MDCPEVNT="A01":"CPAN",MDCPEVNT="A02":"CPTP",MDCPEVNT="A03":"CPDE",MDCPEVNT="A08":"CPUI",MDCPEVNT="A11":"CPCAN",MDCPEVNT="A12":"CPCT",MDCPEVNT="A13":"CPCDE",1:"")
- +7 SET MDCPPAIR="SUBTYPE="_STYPE_"^IEN="_+MDIENS
- +8 KILL MDCFDA
- +9 FOR X="MDCPMSG","MDCPEVNT","MDCPPAIR"
- Begin DoDot:1
- +10 WRITE !,X,"=",$GET(@X,"<NIL>")
- End DoDot:1
- +11 SET MDCFDA(704.005,MDIENS,.09)=$$QUE^MDCPMESQ(MDIENS,MDCPEVNT,.RETRN)
- +12 if MDCFDA(704.005,MDIENS,.09)=0
- SET MDCFDA(704.005,MDIENS,.1)=$GET(RETRN,"No return message.")
- +13 DO UPDATE^DIE("","MDCFDA")
- +14 QUIT
- +15 ;