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

MDCUTL.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;1.0;Create HL7 A04 Message;;Mar 10, 2005 ; Patch IB*2.0*286
  1. ;
  1. ; This routine uses the following Integration Agreements (IAs):
  1. ; # 2050 - $$EZBLD^DIALOG() FILEMAN (supported)
  1. ;
  1. Q
  1. ;
  1. MOREDLMS ;; maintain HL7 delimiters based on prev. HL7 INIT for the protocol
  1. S HLMAXLEN=245
  1. S HLFS=$G(HL("FS")) I HLFS="" S HLFS="^"
  1. S HLCM=$E(HL("ECH"),1),HLRP=$E(HL("ECH"),2)
  1. S HLES=$E(HL("ECH"),3),HLSC=$E(HL("ECH"),4)
  1. S HL7RC=HLES_HLFS_HLCM_HLRP_HLSC,HLECH=HL("ECH"),HLQ=HL("Q")
  1. Q
  1. ;
  1. EMPTY(SEG,ERR,HLQFLAG,STFIELD,ENDFIELD) ;
  1. ;
  1. ;This function will check an HL7 segment delimited by the HL7 field
  1. ;separator for a specified field range and determine if the segment
  1. ;within the specified field range contains data or is empty. If
  1. ;no specified starting field range, then starting field defaults to the
  1. ;first field in the segment. If no specified ending field range, then
  1. ;ending field defaults to the last field in the segment as determined
  1. ;by $L(SEG,HLFS).
  1. ;
  1. ;
  1. ;INPUT:
  1. ; SEG -- (Required) HL7 segment to be evaluated.
  1. ; ERR -- (Required) Passed by reference and is only defined
  1. ; within this function if an error occurs.
  1. ; HLQFLAG -- (Optional) Flag to indicate if HL7 Null Variable
  1. ; HLQ is considered for evaluation.
  1. ; If sent, then '1' indicates consideration and '0'
  1. ; indicates no consideration.
  1. ; If not sent, then default is not to consider HLQ
  1. ; for evaluation.
  1. ; STFIELD -- (Optional) Segment field to start evaluation from
  1. ; as determined by field separator HLFS.
  1. ; If not sent, then default equals '1'.
  1. ; ENDFIELD -- (Optional) Segment field to end evaluation to as
  1. ; determined by field separator HLFS.
  1. ; If not sent, then default equals '$L(SEG,HLFS)'.
  1. ;
  1. ;OUTPUT:
  1. ; 1 -- Segment field range contains data or
  1. ; 0 -- Segment field range doesn't contain data or
  1. ; "" -- Error has occurred. In this case, error returned
  1. ; in variable ERR.
  1. ; ERR -- Error message text. Is only defined if and error
  1. ; has occurred within this function.
  1. ;
  1. Q:$G(SEG)="" 0
  1. N COMP
  1. S HLQFLAG=$S($G(HLQFLAG)'="":HLQFLAG,1:0)
  1. I (HLQFLAG'=1),(HLQFLAG'=0) D EMPTYERR("HLQFLAG") Q ""
  1. S STFIELD=$S($G(STFIELD)'="":STFIELD,1:1)
  1. I (STFIELD'?1N.N)!(STFIELD<1)!(STFIELD>$L(SEG,HLFS)) D EMPTYERR("STFIELD") Q ""
  1. S ENDFIELD=$S($G(ENDFIELD)'="":ENDFIELD,1:$L(SEG,HLFS))
  1. I (ENDFIELD'?1N.N)!(ENDFIELD<1)!(ENDFIELD>$L(SEG,HLFS)) D EMPTYERR("ENDFIELD") Q ""
  1. S COMP=$P(SEG,HLFS,STFIELD,ENDFIELD)
  1. Q:COMP="" 0
  1. I HLQFLAG,$TR(COMP,HLQ_HL7RC)="" Q 0
  1. I 'HLQFLAG,$TR(COMP,HL7RC)="" Q 0
  1. Q 1
  1. ;
  1. EMPTYERR(NAME) ;Error message module
  1. ;
  1. N MDCPARM
  1. ;
  1. ;Setup error message parameter for call to Dialog File
  1. ;for dialog 3750007.
  1. ;Dialog 3750007 => Message could not be built. Error occurred in |1|.
  1. ;
  1. S MDCPARM(1)="$$EMPTY^IBBVUTL - unacceptable "_NAME_" parameter value of "_@NAME
  1. ;
  1. ;Return error message text in variable ERR.
  1. ;
  1. S ERR=$$EZBLD^DIALOG(3750007,.MDCPARM)
  1. Q
  1. ESC(FIELD) ;
  1. ;
  1. NEW DEL,HLES,IDEL,REP
  1. ;
  1. S HLES=$E(HL("ECH"),3)
  1. S DEL(1)=HLES,REP(1)="E" ; escape character must be first in list
  1. S DEL(2)=$E(HL("ECH"),2),REP(2)="R"
  1. S DEL(3)=$E(HL("ECH")),REP(3)="S"
  1. S DEL(4)=$E(HL("FS")),REP(4)="F"
  1. S DEL(5)=$E(HL("ECH"),4),REP(5)="T"
  1. ;
  1. F IDEL=1:1:5 D
  1. . Q:FIELD'[DEL(IDEL)
  1. . S FIELD=$$REP(FIELD,DEL(IDEL),HLES_REP(IDEL)_HLES)
  1. . Q
  1. Q FIELD
  1. ;
  1. REP(STR,REM,REP) ; remove all occurrences of REM from STR and replace with REP
  1. ;
  1. Q:STR'[REM STR
  1. Q $P(STR,REM,1)_REP_$$REP($P(STR,REM,2,$L(STR,REM)),REM,REP)
  1. ;
  1. ;
  1. REMQQ(STR) ; removes two double quotes surrounded by HL7 delimiters from STR
  1. ;
  1. NEW POS,DELIMS,BEFORE,AFTER
  1. S DELIMS=HL("ECH")_HL("FS")
  1. ;
  1. S POS=$F(STR,HLQ)
  1. Q:POS=0 STR
  1. S BEFORE=$E(STR,POS-3)
  1. S AFTER=$E(STR,POS)
  1. ;
  1. Q:DELIMS'[BEFORE!(DELIMS'[AFTER) $E(STR,1,POS-1)_$$REMQQ($E(STR,POS,$L(STR)))
  1. ;
  1. Q $E(STR,1,POS-3)_$$REMQQ($E(STR,POS,$L(STR)))
  1. ;
  1. ;
  1. MAKESEG(RAWARAY,SEGARAY,SEGNUM,SEGID) ;Make segment using obtained fields
  1. ;
  1. ; - This subroutine takes a one dimensional array of fields and turns it into an
  1. ; an HL7 segment (segment string). The subscript of each element in the field array
  1. ; corresponds to the number of a field in a HL7 specification, such as might be found
  1. ; in the Message Work Bench (MWB) tool. Each string within the array is assumed to
  1. ; be already formatted in regard to such matters as components and sub-components.
  1. ; If the length of the HL7 string exceeds 245 characters, it must be broken up into
  1. ; chunks, none of which may exceed 245 characters. The chunks are returned in an array.
  1. ; Fields are not split across chunks.
  1. ;
  1. ;Input:
  1. ; RAWARAY = 1 dimensional array of fields, each subscript corresponding to an HL7
  1. ; specification field number (!pass by reference!)
  1. ; SEGARAY = array of chunks where the constructed segment goes (!pass by reference!)
  1. ; SEGNUM = if greater than zero, number denoting Xth repetition of the SEGID segment.
  1. ; if less than 1, the first (or only) chunk has no subscript
  1. ; SEGID = Segment ID string (defaults to "")
  1. ; HLMAXLEN = Maximum length of each segment chunk (defaults to 245) (assumed variable)
  1. ; HL7 encoding characters (HLFS, HLENC, HLQ)
  1. ;
  1. ;Output: SEGARAY(SEGNUM) = SEGID segment (first SMAXL characters)
  1. ; SEGARAY(SEGNUM,x) = Remaining portion(S) of SEGID segment in
  1. ; SMAXL character chunks (if needed)
  1. ; beginning with a field separator
  1. ;
  1. ;Notes: SEGARAY(SEGNUM) is initialized (KILLed) on input
  1. ; : Fields will not be split across chunks in SEGARAY()
  1. ;
  1. N SEQ,SPILL,SPILLON,SPOT,LASTSEQ,SPTR,SMAXL,PTSS
  1. ; - first assume segment array number not present (less than 1)
  1. S SPTR="SEGARAY",PTSS="SEGARAY(SPILL)"
  1. ; - if array number present, arrange to use it as subscript
  1. I +$G(SEGNUM)>0 S SPTR="SEGARAY(SEGNUM)",PTSS="SEGARAY(SEGNUM,SPILL)" ;SEGNUM=$TR(SEGNUM,"_",",")
  1. ; - initialize segment (output) array
  1. K @SPTR
  1. S @SPTR=$G(SEGID)
  1. ; - if not some value, make max the system max
  1. S SMAXL=+$G(HLMAXLEN) S:'SMAXL SMAXL=245
  1. ; - initialize some "pointers"
  1. S (SPILL,SPILLON)=0
  1. S LASTSEQ=+$O(RAWARAY(""),-1)
  1. ; - scan through field array, creating segment array as we go
  1. F SEQ=1:1:LASTSEQ D
  1. .; - Make sure maximum length won't be exceeded
  1. .I ($L(@SPTR)+$L($G(RAWARAY(SEQ)))+1)>SMAXL D
  1. ..; - Max length exceeded - start putting data on next node
  1. ..S SPILL=SPILL+1
  1. ..S SPILLON=SEQ-1
  1. ..S SPTR=PTSS
  1. .; - Add to string
  1. .S SPOT=(SEQ+1)-SPILLON
  1. .S $P(@SPTR,HLFS,SPOT)=$G(RAWARAY(SEQ))
  1. ; - Done
  1. Q
  1. ;
  1. RETRANS ; Retransmit ADT from file 704.005
  1. ; Get the entry from file 704.005
  1. N STYPE,RETRN,DYNAMIC,EVNTDRVR,REQIEN,DYNAMIC,DIC
  1. S DIC=704.005,DIC(0)="AEQM" D ^DIC Q:+Y<1 S MDIENS=+Y_","
  1. S MDCPEVNT=$$GET1^DIQ(704.005,MDIENS,.07,"E")
  1. S MDCPMSG=$$GET1^DIQ(704.005,MDIENS,.06,"E")
  1. 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:"")
  1. S MDCPPAIR="SUBTYPE="_STYPE_"^IEN="_+MDIENS
  1. K MDCFDA
  1. F X="MDCPMSG","MDCPEVNT","MDCPPAIR" D
  1. .W !,X,"=",$G(@X,"<NIL>")
  1. S MDCFDA(704.005,MDIENS,.09)=$$QUE^MDCPMESQ(MDIENS,MDCPEVNT,.RETRN)
  1. S:MDCFDA(704.005,MDIENS,.09)=0 MDCFDA(704.005,MDIENS,.1)=$G(RETRN,"No return message.")
  1. D UPDATE^DIE("","MDCFDA")
  1. Q
  1. ;