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

HLCSHDR.m

Go to the documentation of this file. 
  1. HLCSHDR ;  ALB/MFK,JRP - Make HL7 header from a #772 IEN ;05/31/2000  08:59
  1.  ;;1.6;HEALTH LEVEL SEVEN;**37,19,57,59,65,80**;Oct 13, 1995
  1.  ;
  1.  ;Input  : IEN - Pointer to entry in Message Text file (#772) that
  1.  ;               HL7 MSH segment is being built for
  1.  ;         HLERROR - Variable to return possible error text in
  1.  ;                   (pass by reference - only used when needed)
  1.  ;
  1.  ;Output : HLHDR(1) - HL7 MSH segment
  1.  ;         HLHDR(2) - Continuation of HL7 MSH segment (if needed)
  1.  ;         HLHDR(3) - Continuation of HL7 MSH segment (if needed)
  1.  ;
  1.  ;Notes  : HLERROR will only be defined [on output] if an error occurs
  1.  ;       : HLHDR() will not be defined [on output] if an error occurs
  1.  ;       : HLHDR(2) & HLHDR(3) are continuation [or roll-over] nodes
  1.  ;         and will only be used/defined when needed
  1.  ;
  1.  ;Check input
  1.  S IEN=+$G(IEN)
  1.  I ('$D(^HL(772,IEN,0))) S HLERROR="Valid pointer to Message Text file (#772) not passed" Q
  1.  ;Declare variables
  1.  N PROTOCOL,PARENTP,PARENT,SERVERP,CLIENTP,FS,PROT,MSGTYPE,APPPRM
  1.  N HLDTID,HLID,HLDATE,SECURITY,ID,SERAPP,SERFAC,EC,ACCACK,APPACK
  1.  N CHILD,CLNTAPP,CLNTFAC,ACKTO,CNTRY,HLPROT,HLPROTS,HLPARAM
  1.  ;Get Site Parameters
  1.  S HLPARAM=$$PARAM^HLCS2
  1.  ;Get parent message (NOTE: Original message is it's own parent)
  1.  S CHILD=$G(^HL(772,IEN,0))
  1.  I CHILD="" S HLERROR="Valid pointer to Message Text file (#772) not passed" Q
  1.  S PARENTP=+$P(CHILD,"^",8)
  1.  I ('PARENTP) S HLERROR="Could not determine parent message" Q
  1.  S PARENT=$G(^HL(772,PARENTP,0))
  1.  ;Get server [sending] & client [receiving] applications
  1.  S SERVERP=+$P(PARENT,"^",2)
  1.  I ('SERVERP) S HLERROR="Could not determine sending application" Q
  1.  S CLIENTP=+$P(CHILD,"^",3)
  1.  I ('CLIENTP) S HLERROR="Could not determine receiving application" Q
  1.  ;Get info for sending & receiving applications
  1.  D APPPRM^HLUTIL2(CLIENTP)
  1.  D APPPRM^HLUTIL2(SERVERP)
  1.  ;Get name of sending application and facility
  1.  S SERAPP=$P(APPPRM(SERVERP,0),"^",1)
  1.  S SERFAC=$P(APPPRM(SERVERP,0),"^",2)
  1.  ;Get name of receiving application and facility
  1.  S CLNTAPP=$P(APPPRM(CLIENTP,0),"^",1)
  1.  S CLNTFAC=$P(APPPRM(CLIENTP,0),"^",2)
  1.  ;Get country
  1.  S CNTRY=$P(APPPRM(SERVERP,0),"^",3)
  1.  ;Get field seperator & encoding characters
  1.  S FS=APPPRM(SERVERP,"FS")
  1.  S EC=APPPRM(SERVERP,"EC")
  1.  S:(EC="") EC="~|\&"
  1.  S:(FS="") FS="^"
  1.  ;
  1.  ;Determine if it's a response/ACK to another message
  1.  ;
  1.  S ACKTO=+$P(PARENT,"^",7)
  1.  ;
  1.  ;Get message type
  1.  ;Message type/Event Type of Initiator found on Event Driver
  1.  ;Message type/Event Type of Responder found on Subscriber
  1.  ;
  1.  S PROT=+$P(PARENT,"^",10),HLPROT=PROT
  1.  ;commented the next line to get ack message to have the correct header
  1.  ;S:ACKTO&($G(HLOGLINK)) PROT=+$P(CHILD,"^",10)
  1.  S PROTOCOL=$$TYPE^HLUTIL2(PROT)
  1.  ;if initiating a new transaction, get MsgType from Event Driver, field 770.3
  1.  ;if generating a response, get MsgType from subscriber, field 770.11
  1.  S MSGTYPE=$S(ACKTO:$P(PROTOCOL,"^",10),1:$P(PROTOCOL,"^",2))
  1.  ;Append event type
  1.  I MSGTYPE']"" S HLERROR="Message Type Undefined for protocol "_$P(PROTOCOL,"^",1) Q
  1.  I $P(PROTOCOL,"^",3)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_$P(PROTOCOL,"^",3)
  1.  ;Append mesaage structure component
  1.  I $P(PROTOCOL,"^",3)]"",$P(PROTOCOL,"^",4)]"" S MSGTYPE=MSGTYPE_$E(EC,1)_$P(PROTOCOL,"^",4)
  1.  ;Get accept ack & application ack type (based on server protocol)
  1.  ;  Originating messages have it listed in the parent message
  1.  ;  Responses/ACKs have it listed in the child message
  1.  S PROT=+$P(PARENT,"^",10),HLPROT=PROT
  1.  S:(ACKTO) PROT=+$P(CHILD,"^",10)
  1.  S HLPROTS=+$P(CHILD,"^",10)
  1.  S PROTOCOL=$$TYPE^HLUTIL2(PROT)
  1.  S ACCACK=$P(PROTOCOL,"^",7)
  1.  S APPACK=$P(PROTOCOL,"^",8)
  1.  ;Get date/time & message ID
  1.  S HLDATE=+PARENT
  1.  S HLDATE=$$FMTHL7^XLFDT(HLDATE)
  1. MID ;Message ID
  1.  S HLID=$P(PARENT,"^",6)
  1. PID ;Processing ID
  1.  ;If event driver set to 'debug' get from protocol
  1.  ;'production' or 'training' comes from site params
  1.  S HLPID=$P(PROTOCOL,"^",5)
  1.  I $G(HLPID)'="D" S HLPID=$P(HLPARAM,U,3)
  1.  I $G(HLPID)="" S HLERROR="Missing Processing ID Site Parameter."
  1.  ;Get security info
  1.  S SECURITY=$P(PARENT,"^",12)
  1.  D HDR23
  1.  ;Build MSH array
  1.  S HLHDR(1)="MSH"_FS_EC_FS_SERAPP_FS_SERFAC_FS_CLNTAPP_FS_CLNTFAC_FS
  1.  S HLHDR(1)=HLHDR(1)_HLDATE_FS_SECURITY_FS_MSGTYPE_FS_HLID_FS
  1.  S HLHDR(1)=HLHDR(1)_HLPID_FS_$P(PROTOCOL,"^",9)_FS_FS
  1.  S HLHDR(2)=$G(^HL(772,PARENT,1))_FS
  1.  S HLHDR(3)=ACCACK_FS_APPACK_FS_CNTRY
  1.  ;Combine line 1 & 2 (if possible)
  1.  I (($L(HLHDR(1))+$L(HLHDR(2)))'>245) D
  1.  .S HLHDR(1)=HLHDR(1)_HLHDR(2)
  1.  .S HLHDR(2)=HLHDR(3)
  1.  .S HLHDR(3)=""
  1.  .;Add original line 3 (if possible)
  1.  .I (($L(HLHDR(1))+$L(HLHDR(2)))'>245) D
  1.  ..S HLHDR(1)=HLHDR(1)_HLHDR(2)
  1.  ..S HLHDR(2)=""
  1.  ;Combine line 2 & 3 (if possible)
  1.  I (($L(HLHDR(2))+$L(HLHDR(3)))'>245) D
  1.  .S HLHDR(2)=HLHDR(2)_HLHDR(3)
  1.  .S HLHDR(3)=""
  1.  ;Delete unused lines
  1.  K:(HLHDR(2)="") HLHDR(2)
  1.  K:(HLHDR(3)="") HLHDR(3)
  1.  Q
  1. BHSHDR(IEN) ; Create Batch Header Segment
  1.  ; The BHS has 12 segments, of which 4 are blank.
  1.  ; INPUT: IEN - IEN of entry in file #772
  1.  ; OUTPUT: HLHDR(1) and HLHDR(2) - the two lines with the 12 segs.
  1.  ;   ready for adding to a message directly.
  1.  N ACKMID,ACKTO,APPPRM,BC,BCD,BCI,BEC,BFS,BN,BRA,BRF,BS,BSA,BSF ;HL*1.6*80
  1.  N BSTATUS,BTACK,CHILD,CLIENTP,HLDATE,HLDTID,HLPID,ID,PARENT,PARENTP ;HL*1.6*80
  1.  N RBCI,SERVERP ;HL*1.6*80
  1.  S CHILD=$G(^HL(772,IEN,0))
  1.  S PARENTP=$P(CHILD,"^",8)
  1.  I (PARENTP="") S HLHDR(1)="-1^No parent" Q
  1.  S PARENT=$G(^HL(772,PARENTP,0))
  1.  S SERVERP=$P(PARENT,"^",2)
  1.  I (SERVERP="") S HLHDR(1)="-1^No server for this node" Q
  1.  S CLIENTP=$P(CHILD,"^",3)
  1.  I (CLIENTP="") S HLHDR(1)="-1^No client for this node" Q
  1.  ;--  get server and application parameters
  1.  D APPPRM^HLUTIL2(SERVERP)
  1.  D APPPRM^HLUTIL2(CLIENTP)
  1.  S BFS=APPPRM(SERVERP,"FS")
  1.  S BEC=APPPRM(SERVERP,"EC")
  1.  ;-- sending application
  1.  S BSA=$P(APPPRM(SERVERP,0),"^",1)
  1.  ;-- sending facility
  1.  S BSF=$P(APPPRM(SERVERP,0),"^",2)
  1.  ;-- receiving application
  1.  S BRA=$P(APPPRM(CLIENTP,0),"^",1)
  1.  ;-- receiving facility
  1.  S BRF=$P(APPPRM(CLIENTP,0),"^",2)
  1.  S HLDATE=+PARENT
  1.  S HLID=$P(PARENT,"^",6)
  1.  S BCD=$$HLDATE^HLFNC(HLDATE,"TS")
  1.  ;-- batch security
  1.  S BS=$P(PARENT,"^",12)
  1.  ;-- build batch field #9  NULL~Process ID~Message Type|Event Type~version
  1.  S ACKTO=$P(PARENT,"^",7)
  1.  S PROT=$S((ACKTO&$G(HLOGLINK)):$P(CHILD,"^",10),1:$P(PARENT,"^",10))
  1.  ;S X=$$TYPE^HLUTIL2($P(CHILD,U,10))
  1.  ; for batch ACK message, client protocol pointer is stored in parent message
  1.  ;I ACKTO S X=$$TYPE^HLUTIL2($P(PARENT,U,10))
  1.  S X=$$TYPE^HLUTIL2(PROT)
  1.  S MSGTYPE=$S(ACKTO:$P(X,"^",10),1:$P(X,"^",2))
  1.  I MSGTYPE']"" S HLERROR="MType undefined for protocol "_$P(X,U) Q
  1.  I $P(X,U,3)]"" S MSGTYPE=MSGTYPE_$E(BEC,2)_$P(X,U,3)
  1.  ;S BN=$E(BEC,1)_$P(X,U,5)_$E(BEC,1)_$S('$P(CHILD,"^",11)&('ACKTO):$P(X,U,2),1:$P(X,U,10))_$E(BEC,2)_$P(X,U,3)_$E(BEC,1)_$P(X,U,9)
  1.  S HLPID=$$PIDCK($P($G(^HL(772,+PROT,0)),U,10)) QUIT:$G(HLERROR)]""  ;HL*1.6*80
  1.  S BN=$E(BEC,1)_HLPID_$E(BEC,1)_MSGTYPE_$E(BEC,1)_$P(X,U,9) ;HL*1.6*80
  1.  ;
  1.  ; for batch ACK message
  1.  S ACKMID="",BTACK=""
  1.  I ACKTO D
  1.  . S ACKMID=$P($G(^HL(772,ACKTO,0)),"^",6)
  1.  . S BSTATUS=$P($G(^HL(772,ACKTO,"P")),"^")
  1.  . S BTACK="AR"
  1.  . I ACKMID]"" D
  1.  .. S BTACK="AA"
  1.  .. I (BSTATUS>3)&(BSTATUS<8) S BTACK="AE"_$E(BEC,1)_$P($G(^HL(772,ACKTO,"P")),"^",3)
  1.  ;
  1.  S HLHDR(1)="BHS"_BFS_BEC_BFS_BSA_BFS_BSF_BFS_BRA_BFS_BRF_BFS_BCD_BFS_BS_BFS_BN_BFS_BTACK_BFS_HLID_BFS_ACKMID
  1.  Q
  1. HDR23 ;generate extended facility field info based on 'facility required'
  1.  ;default format is INSTITUTION_HLCS_DOMAIN_HLCS_'DNS'
  1.  ;application parameter entry overrides default
  1.  N HLEP773,HLS773
  1.  S SERFAC=$G(SERFAC),CLNTFAC=$G(CLNTFAC)
  1.  S HLEP773=+$G(^ORD(101,HLPROTS,773))
  1.  S HLS773=+$P($G(^ORD(101,HLPROTS,773)),U,2)
  1.  Q:'HLEP773&('HLS773)
  1.  D GEN^HLCSHDR2
  1.  I ACKTO D  Q
  1.  .;Find original message
  1.  .S X=$G(^HL(772,ACKTO,"IN",1,0))
  1.  .I X["MSH" D
  1.  ..S HLFS=$E(X,4)
  1.  ..S SENDFAC=$P(X,HLFS,4),RECFAC=$P(X,HLFS,6) ;from original msg
  1.  ..S CLNTFAC=SENDFAC,SERFAC=RECFAC ;reverse facility info
  1.  I HLEP773,SERFAC="" D EP^HLCSHDR2
  1.  I HLS773,CLNTFAC="" D S^HLCSHDR2
  1.  Q
  1.  ;
  1. PIDCK(IEN101) ; This subroutine added by HL*1.6*80
  1.  ; Given 101's IEN, return the PROCESSING ID.  (See PID^HLCSHDR
  1.  ; and PID^HLCSHDR1 for other locations where HLPID is set.)
  1.  ; HLPARAM -- req
  1.  S HLPID=$P($G(^ORD(101,+IEN101,0)),U,6)
  1.  I HLPID'="D" D
  1.  .  I $G(HLPARAM)']"" N HLPARAM S HLPARAM=$$PARAM^HLCS2
  1.  .  S HLPID=$P($G(HLPARAM),U,3)
  1.  I HLPID="" S HLERROR="Missing Processing ID Site Parameter."
  1.  QUIT HLPID