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

EHMHL7.m

Go to the documentation of this file.
  1. EHMHL7 ;ALB/WTC - EHRM HL7 MESSAGES ; Oct 24, 2023@15:01:46
  1. ;;1.0;ELECTRONIC HEALTH MODERNIZATION;**10**;Apr 19, 2021;Build 30
  1. ;
  1. ; Use of $$CRNRSITE^VAFCCRNR supported by ICR #7346.
  1. ;
  1. Q ;
  1. ;
  1. SAVEHL7(TYPE,SENDER,RECEIVER,FS,CS,RS) ;
  1. ;
  1. ; Save HL7 message in EHRM HL7 Message file (#1609)
  1. ;
  1. ; TYPE = Type of HL7 message (IFC or PRF) [REQUIRED]
  1. ; SENDER = Message sender. Suggested values are CERNER-stn or VISTA-stn (e.g., CERNER-668, VISTA-541) [OPTIONAL]
  1. ; RECEIVER = Message receiver. [OPTIONAL]
  1. ; FS = Field separator. Default="|". [OPTIONAL]
  1. ; CS = Component separator. Default="^". [OPTIONAL]
  1. ; RS = Repetition separator. Default="~". [OPTIONAL]
  1. ;
  1. ; Returns pointer to file #1609 if successful or 0^error message if not.
  1. ;
  1. I $G(TYPE)'="IFC",$G(TYPE)'="PRF" Q "0^TYPE parameter error" ;
  1. ;
  1. N HL7MSG,RTNCODE ;
  1. ;
  1. I $G(FS)="" S FS="|" ;
  1. I $G(CS)="" S CS="^" ;
  1. I $G(RS)="" S RS="~" ;
  1. ;
  1. ; Load HL7 message into HL7MSG array.
  1. ;
  1. D GETHL7(.HL7MSG) ;
  1. ;
  1. ; Store HL7 message.
  1. ;
  1. 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)) ;
  1. ;
  1. Q RTNCODE ;
  1. ;
  1. SAVEHL7X(NODE,TYPE,SENDER,RECEIVER,FS,CS,RS) ;
  1. ;
  1. ; Save HL7 message in EHRM Message file (#1609). Message is in ^TMP(NODE,$J).
  1. ;
  1. I $G(NODE)="" Q "0^NODE parameter error" ;
  1. I $G(TYPE)'="IFC",$G(TYPE)'="PRF" Q "0^TYPE parameter error" ;
  1. ;
  1. N HL7MSG,RTNCODE ;
  1. ;
  1. I $G(FS)="" S FS="|" ;
  1. I $G(CS)="" S CS="^" ;
  1. I $G(RS)="" S RS="~" ;
  1. ;
  1. M HL7MSG=^TMP(NODE,$J) ;
  1. ;
  1. ; Store HL7 message.
  1. ;
  1. 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)) ;
  1. ;
  1. Q RTNCODE ;
  1. ;
  1. GETHL7(HL7MSG) ;
  1. ;
  1. ; Load HL7 message into HL7MSG array.
  1. ;
  1. N I,J,HLNODE ;
  1. ;
  1. F I=1:1 X HLNEXT Q:HLQUIT'>0 D ;
  1. . S HL7MSG(I)=HLNODE,J=0 ;get first segment node
  1. . ;
  1. . ; Get continuation nodes for long segments, if any. Append all pieces of segment together. They were split apart by HL7 processing code.
  1. . ;
  1. . F S J=$O(HLNODE(J)) Q:'J S HL7MSG(I)=HL7MSG(I)_HLNODE(J) ;
  1. Q ;
  1. ;
  1. FILE(HL7MSG,TYPE,SENDER,RECEIVER,FS,CS,RS) ;
  1. ;
  1. ; Post HL7 message to file #1609.
  1. ;
  1. N DIC,X,Y,DA,ERRMSG,MSGID,CONSULT,CERNER,PATIENT,ICN,I,Z,SITE,PLACER,FILLER ;
  1. ;
  1. S DIC=1609,X=$$NOW^XLFDT(),DIC(0)="L",DIC("DR")="1///"_TYPE ;
  1. S MSGID=$E($$PARSE(.HL7MSG,"MSH",10),1,50),DIC("DR")=DIC("DR")_";2///"_MSGID ;
  1. I $G(SENDER)="" S SENDER=$$PARSE(.HL7MSG,"MSH",4),SENDER=$P(SENDER,CS,1) S:SENDER="" SENDER="CERNER" ;
  1. S DIC("DR")=DIC("DR")_";7///"_SENDER ;
  1. I $G(RECEIVER)="" S RECEIVER=$$PARSE(.HL7MSG,"MSH",6),RECEIVER=$P(RECEIVER,CS,1) S:RECEIVER="" RECEIVER="CERNER" ;
  1. S DIC("DR")=DIC("DR")_";8///"_RECEIVER ;
  1. ;
  1. ; Extract fields specific to IFC HL7 messages.
  1. ;
  1. I TYPE="IFC" D ;
  1. . ;
  1. . S PLACER=$$PARSE(.HL7MSG,"ORC",3),FILLER=$$PARSE(.HL7MSG,"ORC",4) ;
  1. . S SITE=$P(PLACER,CS,2),(CERNER,CONSULT)="" ;
  1. . I $$CRNRSITE^VAFCCRNR(SITE)=1 S CERNER=$P(PLACER,CS,1),CONSULT=$P(FILLER,CS,1) ; icr #7346
  1. . E S CERNER=$P(FILLER,CS,1),CONSULT=$P(PLACER,CS,1) ;
  1. . I CONSULT'="" S DIC("DR")=DIC("DR")_";3///"_CONSULT ;
  1. . I CERNER'="" S DIC("DR")=DIC("DR")_";4///"_CERNER ;
  1. . ;
  1. . 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 ;
  1. ;
  1. ; Extract fields specific to PRF HL7 messages.
  1. ;
  1. I TYPE="PRF" D ;
  1. . ;
  1. . S ICN=$$PARSE(.HL7MSG,"PID",4) I ICN'="" S Y=ICN,ICN="" D ;
  1. .. 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 ;
  1. . 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 ;
  1. ;
  1. D FILE^DICN I Y<0 Q "0^Error creating entry in file #1609" ;
  1. ;
  1. S DA=+Y ;
  1. ;
  1. D WP^DIE(1609,DA_",",10,,"HL7MSG","ERRMSG") ;
  1. I $D(ERRMSG) Q "0^Error filing HL7 message in entry #"_DA_" in file #1609" ;
  1. ;
  1. Q DA ;
  1. ;
  1. PARSE(HL7MSG,SEGID,FIELDNO) ;
  1. ;
  1. ; Return requested field from HL7 segment
  1. ;
  1. N X,I,RTNVALUE ;
  1. ;
  1. 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
  1. . ;
  1. . I $P(X,FS,1)=SEGID S RTNVALUE=$P(X,FS,FIELDNO) ;
  1. ;
  1. Q RTNVALUE ;
  1. ;
  1. PURGE ; [EHMHL7 PURGE]
  1. ;
  1. ; Purge records from the EHRM HL7 Message file (#1609).
  1. ;
  1. N TYPE,DA,X,RETNTN,CREATED,DIK ;
  1. ;
  1. ; Get retention period for each HL7 message type from the EHRM HL7 Message Retention file (#1609.1).
  1. ;
  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) ;
  1. ;
  1. ; Scan EHRM HL7 Message file (#1609). Delete records older than the retention period for the message type.
  1. ;
  1. 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 ;
  1. . ;
  1. . ; Delete record from EHRM HL7 Message file (#1609)
  1. . ;
  1. . K DIK S DIK=^DIC(1609,0,"GL") D ^DIK ;
  1. ;
  1. Q ;
  1. ;
  1. INQUIRE ; [EHMHL7 INQUIRE]
  1. ;
  1. ; Inquire into EHRM HL7 Message file (#1609).
  1. ;
  1. N DIR,X,Y,DIC,D,INQUIRE,DIRUT ;
  1. ;
  1. 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="" ;
  1. ;
  1. 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="" ;
  1. ;
  1. 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 ;
  1. ;
  1. W !!,"--------------------------------------------------------------------------------",! ;
  1. K DIC,D S DIC=^DIC(1609,0,"GL"),DA=+Y D EN^DIQ ;
  1. ;
  1. Q ;
  1. ;