EHMHL7 ;ALB/WTC - EHRM HL7 MESSAGES ; Oct 24, 2023@15:01:46
;;1.0;ELECTRONIC HEALTH MODERNIZATION;**10**;Apr 19, 2021;Build 30
;
; Use of $$CRNRSITE^VAFCCRNR supported by ICR #7346.
;
Q ;
;
SAVEHL7(TYPE,SENDER,RECEIVER,FS,CS,RS) ;
;
; Save HL7 message in EHRM HL7 Message file (#1609)
;
; TYPE = Type of HL7 message (IFC or PRF) [REQUIRED]
; SENDER = Message sender. Suggested values are CERNER-stn or VISTA-stn (e.g., CERNER-668, VISTA-541) [OPTIONAL]
; RECEIVER = Message receiver. [OPTIONAL]
; FS = Field separator. Default="|". [OPTIONAL]
; CS = Component separator. Default="^". [OPTIONAL]
; RS = Repetition separator. Default="~". [OPTIONAL]
;
; Returns pointer to file #1609 if successful or 0^error message if not.
;
I $G(TYPE)'="IFC",$G(TYPE)'="PRF" Q "0^TYPE parameter error" ;
;
N HL7MSG,RTNCODE ;
;
I $G(FS)="" S FS="|" ;
I $G(CS)="" S CS="^" ;
I $G(RS)="" S RS="~" ;
;
; Load HL7 message into HL7MSG array.
;
D GETHL7(.HL7MSG) ;
;
; Store HL7 message.
;
S RTNCODE=$$FILE(.HL7MSG,TYPE,$G(SENDER),$G(RECEIVER),FS,CS,RS) I 'RTNCODE D APPERROR^%ZTER("Error saving HL7 message in file #1609. Error message="_$P(RTNCODE,U,2)) ;
;
Q RTNCODE ;
;
SAVEHL7X(NODE,TYPE,SENDER,RECEIVER,FS,CS,RS) ;
;
; Save HL7 message in EHRM Message file (#1609). Message is in ^TMP(NODE,$J).
;
I $G(NODE)="" Q "0^NODE parameter error" ;
I $G(TYPE)'="IFC",$G(TYPE)'="PRF" Q "0^TYPE parameter error" ;
;
N HL7MSG,RTNCODE ;
;
I $G(FS)="" S FS="|" ;
I $G(CS)="" S CS="^" ;
I $G(RS)="" S RS="~" ;
;
M HL7MSG=^TMP(NODE,$J) ;
;
; Store HL7 message.
;
S RTNCODE=$$FILE(.HL7MSG,TYPE,$G(SENDER),$G(RECEIVER),FS,CS,RS) I 'RTNCODE D APPERROR^%ZTER("Error saving HL7 message in file #1609. Error message="_$P(RTNCODE,U,2)) ;
;
Q RTNCODE ;
;
GETHL7(HL7MSG) ;
;
; Load HL7 message into HL7MSG array.
;
N I,J,HLNODE ;
;
F I=1:1 X HLNEXT Q:HLQUIT'>0 D ;
. S HL7MSG(I)=HLNODE,J=0 ;get first segment node
. ;
. ; Get continuation nodes for long segments, if any. Append all pieces of segment together. They were split apart by HL7 processing code.
. ;
. F S J=$O(HLNODE(J)) Q:'J S HL7MSG(I)=HL7MSG(I)_HLNODE(J) ;
Q ;
;
FILE(HL7MSG,TYPE,SENDER,RECEIVER,FS,CS,RS) ;
;
; Post HL7 message to file #1609.
;
N DIC,X,Y,DA,ERRMSG,MSGID,CONSULT,CERNER,PATIENT,ICN,I,Z,SITE,PLACER,FILLER ;
;
S DIC=1609,X=$$NOW^XLFDT(),DIC(0)="L",DIC("DR")="1///"_TYPE ;
S MSGID=$E($$PARSE(.HL7MSG,"MSH",10),1,50),DIC("DR")=DIC("DR")_";2///"_MSGID ;
I $G(SENDER)="" S SENDER=$$PARSE(.HL7MSG,"MSH",4),SENDER=$P(SENDER,CS,1) S:SENDER="" SENDER="CERNER" ;
S DIC("DR")=DIC("DR")_";7///"_SENDER ;
I $G(RECEIVER)="" S RECEIVER=$$PARSE(.HL7MSG,"MSH",6),RECEIVER=$P(RECEIVER,CS,1) S:RECEIVER="" RECEIVER="CERNER" ;
S DIC("DR")=DIC("DR")_";8///"_RECEIVER ;
;
; Extract fields specific to IFC HL7 messages.
;
I TYPE="IFC" D ;
. ;
. S PLACER=$$PARSE(.HL7MSG,"ORC",3),FILLER=$$PARSE(.HL7MSG,"ORC",4) ;
. S SITE=$P(PLACER,CS,2),(CERNER,CONSULT)="" ;
. I $$CRNRSITE^VAFCCRNR(SITE)=1 S CERNER=$P(PLACER,CS,1),CONSULT=$P(FILLER,CS,1) ; icr #7346
. E S CERNER=$P(FILLER,CS,1),CONSULT=$P(PLACER,CS,1) ;
. I CONSULT'="" S DIC("DR")=DIC("DR")_";3///"_CONSULT ;
. I CERNER'="" S DIC("DR")=DIC("DR")_";4///"_CERNER ;
. ;
. S PATIENT=$$PARSE(.HL7MSG,"PID",6) I PATIENT'="" S PATIENT=$P(PATIENT,CS,1)_","_$P(PATIENT,CS,2)_$S($P(PATIENT,CS,3)'="":" "_$P(PATIENT,U,3),1:""),DIC("DR")=DIC("DR")_";5///"_PATIENT ;
;
; Extract fields specific to PRF HL7 messages.
;
I TYPE="PRF" D ;
. ;
. S ICN=$$PARSE(.HL7MSG,"PID",4) I ICN'="" S Y=ICN,ICN="" D ;
.. F I=1:1 S Z=$P(Y,RS,I) Q:Z="" I $P(Z,CS,4)="ICN"!($P(Z,CS,4)["USVHA"&($P(Z,CS,5)="NI")) S ICN=$P(Z,CS,1),DIC("DR")=DIC("DR")_";6///"_ICN Q ;
. S PATIENT=$$PARSE(.HL7MSG,"PID",6) I PATIENT'="" S PATIENT=$P(PATIENT,CS,1)_","_$P(PATIENT,CS,2)_$S($P(PATIENT,CS,3)'="":" "_$P(PATIENT,U,3),1:""),DIC("DR")=DIC("DR")_";5///"_PATIENT ;
;
D FILE^DICN I Y<0 Q "0^Error creating entry in file #1609" ;
;
S DA=+Y ;
;
D WP^DIE(1609,DA_",",10,,"HL7MSG","ERRMSG") ;
I $D(ERRMSG) Q "0^Error filing HL7 message in entry #"_DA_" in file #1609" ;
;
Q DA ;
;
PARSE(HL7MSG,SEGID,FIELDNO) ;
;
; Return requested field from HL7 segment
;
N X,I,RTNVALUE ;
;
S RTNVALUE="" F I=1:1 Q:'$D(HL7MSG(I)) S X=$S($D(HL7MSG(I))#10:HL7MSG(I),1:HL7MSG(I,0)) D Q:RTNVALUE'="" ; WTC 8/17/23
. ;
. I $P(X,FS,1)=SEGID S RTNVALUE=$P(X,FS,FIELDNO) ;
;
Q RTNVALUE ;
;
PURGE ; [EHMHL7 PURGE]
;
; Purge records from the EHRM HL7 Message file (#1609).
;
N TYPE,DA,X,RETNTN,CREATED,DIK ;
;
; Get retention period for each HL7 message type from the EHRM HL7 Message Retention file (#1609.1).
;
S DA=0 F S DA=$O(^EHMHL7(1609.1,DA)) Q:'DA S X=$G(^(DA,0)) I X'="" S TYPE=$P(X,U,1),RETNTN(TYPE)=$P(X,U,2) ;
;
; Scan EHRM HL7 Message file (#1609). Delete records older than the retention period for the message type.
;
S DA=0 F S DA=$O(^EHMHL7(1609,DA)) Q:'DA S X=$G(^(DA,0)) I X'="" S CREATED=$P(X,U,1),TYPE=$P(X,U,2) I $$FMDIFF^XLFDT(DT,CREATED)>RETNTN(TYPE) D ;
. ;
. ; Delete record from EHRM HL7 Message file (#1609)
. ;
. K DIK S DIK=^DIC(1609,0,"GL") D ^DIK ;
;
Q ;
;
INQUIRE ; [EHMHL7 INQUIRE]
;
; Inquire into EHRM HL7 Message file (#1609).
;
N DIR,X,Y,DIC,D,INQUIRE,DIRUT ;
;
S DIR(0)="SO^M:Message ID;V:VistA Consult Number;C:Cerner Order Number;P:Patent's Name;I:ICN;D:Date",DIR("A")="Inquire by" D ^DIR Q:$D(DIRUT) S INQUIRE=Y Q:INQUIRE="" ;
;
W !,$S(INQUIRE="M":"Message ID",INQUIRE="V":"VistA Consult Number",INQUIRE="C":"Cerner Order Number",INQUIRE="P":"Patient's Name",INQUIRE="I":"ICN",INQUIRE="D":"Date",1:""),": " R X:DTIME Q:'$T Q:X="" ;
;
K DIC,D S DIC=1609,DIC(0)="E",D=$S(INQUIRE="M":"MSGID",INQUIRE="V":"CONSULT",INQUIRE="C":"CERNER",INQUIRE="P":"PATIENT",INQUIRE="I":"ICN",1:"B") D IX^DIC I Y<0 W "... Nothing found/selected" Q ;
;
W !!,"--------------------------------------------------------------------------------",! ;
K DIC,D S DIC=^DIC(1609,0,"GL"),DA=+Y D EN^DIQ ;
;
Q ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEHMHL7 6226 printed Sep 23, 2025@19:27:24 Page 2
EHMHL7 ;ALB/WTC - EHRM HL7 MESSAGES ; Oct 24, 2023@15:01:46
+1 ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**10**;Apr 19, 2021;Build 30
+2 ;
+3 ; Use of $$CRNRSITE^VAFCCRNR supported by ICR #7346.
+4 ;
+5 ;
QUIT
+6 ;
SAVEHL7(TYPE,SENDER,RECEIVER,FS,CS,RS) ;
+1 ;
+2 ; Save HL7 message in EHRM HL7 Message file (#1609)
+3 ;
+4 ; TYPE = Type of HL7 message (IFC or PRF) [REQUIRED]
+5 ; SENDER = Message sender. Suggested values are CERNER-stn or VISTA-stn (e.g., CERNER-668, VISTA-541) [OPTIONAL]
+6 ; RECEIVER = Message receiver. [OPTIONAL]
+7 ; FS = Field separator. Default="|". [OPTIONAL]
+8 ; CS = Component separator. Default="^". [OPTIONAL]
+9 ; RS = Repetition separator. Default="~". [OPTIONAL]
+10 ;
+11 ; Returns pointer to file #1609 if successful or 0^error message if not.
+12 ;
+13 ;
IF $GET(TYPE)'="IFC"
IF $GET(TYPE)'="PRF"
QUIT "0^TYPE parameter error"
+14 ;
+15 ;
NEW HL7MSG,RTNCODE
+16 ;
+17 ;
IF $GET(FS)=""
SET FS="|"
+18 ;
IF $GET(CS)=""
SET CS="^"
+19 ;
IF $GET(RS)=""
SET RS="~"
+20 ;
+21 ; Load HL7 message into HL7MSG array.
+22 ;
+23 ;
DO GETHL7(.HL7MSG)
+24 ;
+25 ; Store HL7 message.
+26 ;
+27 ;
SET RTNCODE=$$FILE(.HL7MSG,TYPE,$GET(SENDER),$GET(RECEIVER),FS,CS,RS)
IF 'RTNCODE
DO APPERROR^%ZTER("Error saving HL7 message in file #1609. Error message="_$PIECE(RTNCODE,U,2))
+28 ;
+29 ;
QUIT RTNCODE
+30 ;
SAVEHL7X(NODE,TYPE,SENDER,RECEIVER,FS,CS,RS) ;
+1 ;
+2 ; Save HL7 message in EHRM Message file (#1609). Message is in ^TMP(NODE,$J).
+3 ;
+4 ;
IF $GET(NODE)=""
QUIT "0^NODE parameter error"
+5 ;
IF $GET(TYPE)'="IFC"
IF $GET(TYPE)'="PRF"
QUIT "0^TYPE parameter error"
+6 ;
+7 ;
NEW HL7MSG,RTNCODE
+8 ;
+9 ;
IF $GET(FS)=""
SET FS="|"
+10 ;
IF $GET(CS)=""
SET CS="^"
+11 ;
IF $GET(RS)=""
SET RS="~"
+12 ;
+13 ;
MERGE HL7MSG=^TMP(NODE,$JOB)
+14 ;
+15 ; Store HL7 message.
+16 ;
+17 ;
SET RTNCODE=$$FILE(.HL7MSG,TYPE,$GET(SENDER),$GET(RECEIVER),FS,CS,RS)
IF 'RTNCODE
DO APPERROR^%ZTER("Error saving HL7 message in file #1609. Error message="_$PIECE(RTNCODE,U,2))
+18 ;
+19 ;
QUIT RTNCODE
+20 ;
GETHL7(HL7MSG) ;
+1 ;
+2 ; Load HL7 message into HL7MSG array.
+3 ;
+4 ;
NEW I,J,HLNODE
+5 ;
+6 ;
FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+7 ;get first segment node
SET HL7MSG(I)=HLNODE
SET J=0
+8 ;
+9 ; Get continuation nodes for long segments, if any. Append all pieces of segment together. They were split apart by HL7 processing code.
+10 ;
+11 ;
FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET HL7MSG(I)=HL7MSG(I)_HLNODE(J)
End DoDot:1
+12 ;
QUIT
+13 ;
FILE(HL7MSG,TYPE,SENDER,RECEIVER,FS,CS,RS) ;
+1 ;
+2 ; Post HL7 message to file #1609.
+3 ;
+4 ;
NEW DIC,X,Y,DA,ERRMSG,MSGID,CONSULT,CERNER,PATIENT,ICN,I,Z,SITE,PLACER,FILLER
+5 ;
+6 ;
SET DIC=1609
SET X=$$NOW^XLFDT()
SET DIC(0)="L"
SET DIC("DR")="1///"_TYPE
+7 ;
SET MSGID=$EXTRACT($$PARSE(.HL7MSG,"MSH",10),1,50)
SET DIC("DR")=DIC("DR")_";2///"_MSGID
+8 ;
IF $GET(SENDER)=""
SET SENDER=$$PARSE(.HL7MSG,"MSH",4)
SET SENDER=$PIECE(SENDER,CS,1)
if SENDER=""
SET SENDER="CERNER"
+9 ;
SET DIC("DR")=DIC("DR")_";7///"_SENDER
+10 ;
IF $GET(RECEIVER)=""
SET RECEIVER=$$PARSE(.HL7MSG,"MSH",6)
SET RECEIVER=$PIECE(RECEIVER,CS,1)
if RECEIVER=""
SET RECEIVER="CERNER"
+11 ;
SET DIC("DR")=DIC("DR")_";8///"_RECEIVER
+12 ;
+13 ; Extract fields specific to IFC HL7 messages.
+14 ;
+15 ;
IF TYPE="IFC"
Begin DoDot:1
+16 ;
+17 ;
SET PLACER=$$PARSE(.HL7MSG,"ORC",3)
SET FILLER=$$PARSE(.HL7MSG,"ORC",4)
+18 ;
SET SITE=$PIECE(PLACER,CS,2)
SET (CERNER,CONSULT)=""
+19 ; icr #7346
IF $$CRNRSITE^VAFCCRNR(SITE)=1
SET CERNER=$PIECE(PLACER,CS,1)
SET CONSULT=$PIECE(FILLER,CS,1)
+20 ;
IF '$TEST
SET CERNER=$PIECE(FILLER,CS,1)
SET CONSULT=$PIECE(PLACER,CS,1)
+21 ;
IF CONSULT'=""
SET DIC("DR")=DIC("DR")_";3///"_CONSULT
+22 ;
IF CERNER'=""
SET DIC("DR")=DIC("DR")_";4///"_CERNER
+23 ;
+24 ;
SET PATIENT=$$PARSE(.HL7MSG,"PID",6)
IF PATIENT'=""
SET PATIENT=$PIECE(PATIENT,CS,1)_","_$PIECE(PATIENT,CS,2)_$SELECT($PIECE(PATIENT,CS,3)'="":" "_$PIECE(PATIENT,U,3),1:"")
SET DIC("DR")=DIC("DR")_";5///"_PATIENT
End DoDot:1
+25 ;
+26 ; Extract fields specific to PRF HL7 messages.
+27 ;
+28 ;
IF TYPE="PRF"
Begin DoDot:1
+29 ;
+30 ;
SET ICN=$$PARSE(.HL7MSG,"PID",4)
IF ICN'=""
SET Y=ICN
SET ICN=""
Begin DoDot:2
+31 ;
FOR I=1:1
SET Z=$PIECE(Y,RS,I)
if Z=""
QUIT
IF $PIECE(Z,CS,4)="ICN"!($PIECE(Z,CS,4)["USVHA"&($PIECE(Z,CS,5)="NI"))
SET ICN=$PIECE(Z,CS,1)
SET DIC("DR")=DIC("DR")_";6///"_ICN
QUIT
End DoDot:2
+32 ;
SET PATIENT=$$PARSE(.HL7MSG,"PID",6)
IF PATIENT'=""
SET PATIENT=$PIECE(PATIENT,CS,1)_","_$PIECE(PATIENT,CS,2)_$SELECT($PIECE(PATIENT,CS,3)'="":" "_$PIECE(PATIENT,U,3),1:"")
SET DIC("DR")=DIC("DR")_";5///"_PATIENT
End DoDot:1
+33 ;
+34 ;
DO FILE^DICN
IF Y<0
QUIT "0^Error creating entry in file #1609"
+35 ;
+36 ;
SET DA=+Y
+37 ;
+38 ;
DO WP^DIE(1609,DA_",",10,,"HL7MSG","ERRMSG")
+39 ;
IF $DATA(ERRMSG)
QUIT "0^Error filing HL7 message in entry #"_DA_" in file #1609"
+40 ;
+41 ;
QUIT DA
+42 ;
PARSE(HL7MSG,SEGID,FIELDNO) ;
+1 ;
+2 ; Return requested field from HL7 segment
+3 ;
+4 ;
NEW X,I,RTNVALUE
+5 ;
+6 ; WTC 8/17/23
SET RTNVALUE=""
FOR I=1:1
if '$DATA(HL7MSG(I))
QUIT
SET X=$SELECT($DATA(HL7MSG(I))#10:HL7MSG(I),1:HL7MSG(I,0))
Begin DoDot:1
+7 ;
+8 ;
IF $PIECE(X,FS,1)=SEGID
SET RTNVALUE=$PIECE(X,FS,FIELDNO)
End DoDot:1
if RTNVALUE'=""
QUIT
+9 ;
+10 ;
QUIT RTNVALUE
+11 ;
PURGE ; [EHMHL7 PURGE]
+1 ;
+2 ; Purge records from the EHRM HL7 Message file (#1609).
+3 ;
+4 ;
NEW TYPE,DA,X,RETNTN,CREATED,DIK
+5 ;
+6 ; Get retention period for each HL7 message type from the EHRM HL7 Message Retention file (#1609.1).
+7 ;
+8 ;
SET DA=0
FOR
SET DA=$ORDER(^EHMHL7(1609.1,DA))
if 'DA
QUIT
SET X=$GET(^(DA,0))
IF X'=""
SET TYPE=$PIECE(X,U,1)
SET RETNTN(TYPE)=$PIECE(X,U,2)
+9 ;
+10 ; Scan EHRM HL7 Message file (#1609). Delete records older than the retention period for the message type.
+11 ;
+12 ;
SET DA=0
FOR
SET DA=$ORDER(^EHMHL7(1609,DA))
if 'DA
QUIT
SET X=$GET(^(DA,0))
IF X'=""
SET CREATED=$PIECE(X,U,1)
SET TYPE=$PIECE(X,U,2)
IF $$FMDIFF^XLFDT(DT,CREATED)>RETNTN(TYPE)
Begin DoDot:1
+13 ;
+14 ; Delete record from EHRM HL7 Message file (#1609)
+15 ;
+16 ;
KILL DIK
SET DIK=^DIC(1609,0,"GL")
DO ^DIK
End DoDot:1
+17 ;
+18 ;
QUIT
+19 ;
INQUIRE ; [EHMHL7 INQUIRE]
+1 ;
+2 ; Inquire into EHRM HL7 Message file (#1609).
+3 ;
+4 ;
NEW DIR,X,Y,DIC,D,INQUIRE,DIRUT
+5 ;
+6 ;
SET DIR(0)="SO^M:Message ID;V:VistA Consult Number;C:Cerner Order Number;P:Patent's Name;I:ICN;D:Date"
SET DIR("A")="Inquire by"
DO ^DIR
if $DATA(DIRUT)
QUIT
SET INQUIRE=Y
if INQUIRE=""
QUIT
+7 ;
+8 ;
WRITE !,$SELECT(INQUIRE="M":"Message ID",INQUIRE="V":"VistA Consult Number",INQUIRE="C":"Cerner Order Number",INQUIRE="P":"Patient's Name",INQUIRE="I":"ICN",INQUIRE="D":"Date",1:""),": "
READ X:DTIME
if '$TEST
QUIT
if X=""
QUIT
+9 ;
+10 ;
KILL DIC,D
SET DIC=1609
SET DIC(0)="E"
SET D=$SELECT(INQUIRE="M":"MSGID",INQUIRE="V":"CONSULT",INQUIRE="C":"CERNER",INQUIRE="P":"PATIENT",INQUIRE="I":"ICN",1:"B")
DO IX^DIC
IF Y<0
WRITE "... Nothing found/selected"
QUIT
+11 ;
+12 ;
WRITE !!,"--------------------------------------------------------------------------------",!
+13 ;
KILL DIC,D
SET DIC=^DIC(1609,0,"GL")
SET DA=+Y
DO EN^DIQ
+14 ;
+15 ;
QUIT
+16 ;
