- 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 Feb 18, 2025@23:17:44 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 ;