GMRCIUTL ;SLC/JFR - UTILITIES FOR INTER-FACILITY CONSULTS ; Jun 18, 2024@15:00:56
;;3.0;CONSULT/REQUEST TRACKING;**22,58,184,185,189**;DEC 27, 1997;Build 54
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; #2051 DIC, #2053 DIE, #3015 VAFCPID, #10112 VASITE, #10103 XLFDT, #3065 XLFNAME, #2171 XUAF4, #2541 XUPARAM, #4648 VAFCTFU2
; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
;
Q ;don't start at the top
;
DIV(LOC) ; get the division from a hospital location
; Input -- LOC HOSPITAL LOCATION file (#44) IEN
; Output -- INSTITUTION file (#4) IEN^INSTITUTION file (#4) NAME
;
N GMRCHL,GMRCSTN,GMRCDIV
S GMRCHL=$P($G(^SC(+LOC,0)),U,15)
I +GMRCHL D
. S GMRCSTN=$$SITE^VASITE(,GMRCHL)
. I $P(GMRCSTN,U)>0,($P(GMRCSTN,U,2)]"") D
. . S GMRCDIV=$P(GMRCSTN,U)_U_$P(GMRCSTN,U,2)
I '$G(GMRCDIV) D
. S GMRCDIV=+$G(DUZ(2))_U_$P($$NS^XUAF4(+$G(DUZ(2))),U)
Q GMRCDIV
;
HLNAME(GMRCWHO) ;HL7 format a name from a pointer to 200
Q:'$D(^VA(200,+GMRCWHO,0)) ""
N GMRC
S GMRC("FILE")=200
S GMRC("IENS")=GMRCWHO
S GMRC("FIELD")=.01
Q $$HLNAME^XLFNAME(.GMRC,"S")
;
UNHLNAME(GMRCNM,GMRCNMC,STD,DEL) ;return regular name from HL7 name
;Input:
; GMRCNM = HL7 formatted name from a message
; GMRCNMC = array to retun name components in (by reference)
; STD = 1 or 0; 1 = return name given middle family suffix
; DEL = delimiting character separating name components
;
;Output:
; GMRCNMC=DREW,NANCY M III MD or NANCY M DREW III MD
; GMRCNMC("FAMILY")=DREW
; GMRCNMC("GIVEN")=NANCY
; GMRCNMC("MIDDLE")=M
; GMRCNM("SUFFIX")=III MD
;
I '$D(DEL) S DEL=U
S GMRCNMC=GMRCNM
S GMRCNMC=$$FMNAME^XLFNAME(.GMRCNMC,"CS")
I $G(STD) S GMRCNMC=$$NAMEFMT^XLFNAME(.GMRCNMC,"G","Dc")
Q
;
TRIMWP(ARRAY,PIECE) ;trim OBX or NTE segments so that only comment remains
; Input:
; ARRAY = the array in which the segments are contained
; ex. ^TMP("GMRCIF",541083753,"OBX",3,3)=3|TX|^COMMENTS^|3|text "
; PIECE = the piece in the array where the text lives
;
; Output:
; trimmed array
; ex. ^TMP("GMRCIF",541083753,"OBX",3,3)="text"
;
N I S I=0
F S I=$O(@(ARRAY)@(I)) Q:'I D
. S @(ARRAY)@(I)=$P(@(ARRAY)@(I),"|",PIECE)
Q
;
VALMSG(GMRCPID,GMRCORC) ; determine if message is valid
;Input:
; GMRCPID = PID segment from an IFC HL7 message
; GMRCORC = ORC segment from an IFC HL7 message
;
;Output:
; 1 = message passes screening on patient, institution and ien
; 0^msg = message failed screening
; possible msg values:
;
;
;
N GMRCDA,GMRCINST
Q
;
URG(GMRCO) ;return urgency code to send in HL7 msg
; Input:
; GMRCO = consult ien from file 123
;
; Output:
; S = stat
; R = routine
; ZT = today
; Z24 = within 24 hours
; Z48 = within 48 hours
; Z72 = within 72 hours
; ZW = within 1 week
; ZM = within 1 month
; ZNA = next available
; ZE = emergency
;
N URG,PROT,ORURG
S PROT=$P(^GMR(123,GMRCO,0),U,9)
S URG=$P($G(^ORD(101,+PROT,0)),U),URG=$P(URG," - ",2)
I '$L(URG) Q ""
S ORURG=$S(URG="EMERGENCY":"STAT",URG="NOW":"STAT",URG="OUTPATIENT":"ROUTINE",1:URG)
S ORURG=$O(^ORD(101.42,"B",ORURG,0))
I '+ORURG Q ""
Q $P(^ORD(101.42,ORURG,0),"^",2)
GETSERV(GMRCSRV) ;return local service from IFC service in HL7 msg
;Input:
; GMRCSRV = OBR-4 (e.g. 4^CARDIOLOGY^578VA1235)
;
;Output:
; ien of local service
N SERV,SENDER,ERROR
S SERV=$$FIND1^DIC(123.5,"","X",$P(GMRCSRV,U,2))
I 'SERV S ERROR="-1^ERROR IN SERVICE NAME^701"
I '$D(ERROR) D
. S SENDER=$P(GMRCSRV,U,3)
. S SENDER=+$$IEN^XUAF4($P(SENDER,"VA1235"))
I '$D(ERROR) D
. I $O(^GMR(123.5,SERV,"IFCS","B",SENDER,0)) Q
. S ERROR="-1^IMPROPER SENDING FACILITY^301"
I '$D(ERROR) D
. I $P($G(^GMR(123.5,SERV,0)),U,2)'=9 Q
. S ERROR="-1^SERVICE IS DISABLED^702"
Q $S($D(ERROR):ERROR,1:SERV)
;
GETPROC(GMRCSID) ;return procedure and sercvice ordered by IFC
;Input:
; GMRCSID =OBR-4 from IFC msg (e.g. "31^EKG^578VA1233" )
;
;Output:
; string in format local_proc_ien^service_ien_to perform
;
N GMRCSS,GMRCPR,SENDER,ERROR
S GMRCPR=$$FIND1^DIC(123.3,"","X",$P(GMRCSID,U,2))
I 'GMRCPR S ERROR="-1^ERROR IN PROCEDURE NAME^501"
I '$D(ERROR) D
. S SENDER=$P(GMRCSID,U,3)
. S SENDER=+$$IEN^XUAF4($P(SENDER,"VA1233"))
I '$D(ERROR) D
. I $O(^GMR(123.3,GMRCPR,"IFCS","B",SENDER,0)) Q
. S ERROR="-1^IMPROPER SENDING FACILITY^401"
I '$D(ERROR) D
. D GETSVC^GMRCPR0(.GMRCSS,GMRCPR)
. I GMRCSS>1 S ERROR="-1^MULTIPLE SERVICES DEFINED^601" Q
. S GMRCSS=+GMRCSS(1)
I '$D(ERROR) D
. I $P($G(^GMR(123.3,GMRCPR,0)),U,2)'=1 Q
. S ERROR="-1^PROCEDURE IS INACTIVE^703"
Q $S($D(ERROR):ERROR,1:GMRCPR_U_GMRCSS)
CODEOI(GMRCDA) ; look at ordered procedure or service and code it for IFC msg
;Input:
; GMRCDA = ien from file 123 of consult or procedure to send as IFC
;
;Output:
; consult: svc_ien^remote_service_name^station#_VA1235
; proc: proc_ien^remote_proc_name^station#_VA1233
;
N GMRCPR,GMRCSS,GMRCSIT,GMRCOI
S GMRCSIT=$$STA^XUAF4($$KSP^XUPARAM("INST"))
I +$P(^GMR(123,GMRCDA,0),U,8) D ; it's a procedure
. S GMRCPR=+$P(^GMR(123,GMRCDA,0),U,8)
. S GMRCOI=GMRCPR_U_$P($G(^GMR(123.3,GMRCPR,"IFC")),U,2)_U_GMRCSIT_"VA1233" ; P184
I '$D(GMRCOI) D ; it's a consult
. S GMRCSS=$P(^GMR(123,GMRCDA,0),U,5)
. S GMRCOI=GMRCSS_U_$P($G(^GMR(123.5,GMRCSS,"IFC")),U,2)_U_GMRCSIT_"VA1235" ; P184
Q GMRCOI
;
RESP(GMRCAC,GMRCMID,GMRCOC,GMRCDA,GMRCERR) ;build and send appl ACK/NAK
; Input:
; GMRCAC = acknowledgement code (AA or AR)
; GMRCMID = message id from original msg
; GMRCOC = order control from original msg ORC
; GMRCDA = ien of consult being worked on
; GMRCERR = only defined if an error is found
;
S HLA("HLA",1)=$$MSA^GMRCISEG(GMRCAC,GMRCMID,$G(GMRCERR))
;
; Generate PID segment for Cerner orders. Insert EDIPI and patient account number. p184
;
N DFN,PID,EDIPI,ICN,PTACCTNO,FS,CS,REPTTN,SEGNUM,PTACCTNO ;
S SEGNUM=1 ;
I $G(GMRCDA) D ;
. S DFN=$P(^GMR(123,GMRCDA,0),U,2),PTACCTNO=$P($G(^GMR(123,GMRCDA,"CERNER")),U,3) ;
. I PTACCTNO'="" D ;
.. S HLECH=HL("ECH"),PID=$$EN^VAFCPID(DFN,"1,2,3,7,8,19"),PID=$$ADD2PID(PID,DFN,PTACCTNO) ;
.. S SEGNUM=SEGNUM+1,HLA("HLA",SEGNUM)=PID ;
;
I $D(GMRCOC) D
. I GMRCOC="NW" S SEGNUM=SEGNUM+1,HLA("HLA",SEGNUM)=$$ORCRESP^GMRCISG1(GMRCDA,"OK","IP")
;
; Generate OBR segment for Cerner orders. p184
;
I $G(GMRCDA),PTACCTNO'="" S SEGNUM=SEGNUM+1,HLA("HLA",SEGNUM)=$$OBR^GMRCISG1(GMRCDA),HLA("HLA",SEGNUM)=$$ADD2OBR(HLA("HLA",SEGNUM),GMRCDA) ;
Q
;
LOGMSG(GMRCO,GMRCACT,GMRCMSG,GMRCER) ;create or update IFC MESSAGE LOG entry
;Input:
; GMRCO = ien from file 123
; GMRCACT = ien in 40 multiple from file 123
; GMRCMSG = HL7 message ID of message being sent
; GMRCER = error number if can't transmit immediately
;
N GMRCLG,GMRCERR,FDA
S GMRCLG=$O(^GMR(123.6,"AC",GMRCO,GMRCACT,1,0))
I +GMRCLG D Q ; update existing incomplete record.
. S FDA(1,123.6,GMRCLG_",",.01)=$$NOW^XLFDT
. S FDA(1,123.6,GMRCLG_",",.03)=$G(GMRCMSG)
. S FDA(1,123.6,GMRCLG_",",.07)=$P(^GMR(123.6,GMRCLG,0),U,7)+1
. I $G(GMRCER) S FDA(1,123.6,GMRCLG_",",.08)=GMRCER
. D UPDATE^DIE("","FDA(1)",,"GMRCERR")
;
; create new record
S FDA(1,123.6,"+1,",.01)=$$NOW^XLFDT
S FDA(1,123.6,"+1,",.02)=$P(^GMR(123,GMRCO,0),U,23)
S FDA(1,123.6,"+1,",.03)=$G(GMRCMSG)
S FDA(1,123.6,"+1,",.04)=GMRCO
S FDA(1,123.6,"+1,",.05)=GMRCACT
S FDA(1,123.6,"+1,",.06)=1
S FDA(1,123.6,"+1,",.07)=1
I $G(GMRCER) S FDA(1,123.6,"+1,",.08)=GMRCER
D UPDATE^DIE("","FDA(1)","GMRCLG","GMRCERR")
;
; Save Cerner-bound HL7 message in file #1609. - P189
;
I $$CNVTD^GMRCIEVT(GMRCO)=1,$D(^TMP("HLS",$J)) D SAVEHL7X^EHMHL7("HLS","IFC","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"CERNER-"_$$STA^XUAF4($P(^GMR(123,GMRCO,0),U,23)),"|","^","~") ;
;
Q
;
EDIPI(DFN) ; p184
;
; Return patient's EDIPI
;
N SITE,TFLIST,I ;
;
S SITE=$P($$SITE^VASITE(),U,3) D TFL^VAFCTFU2(.TFLIST,DFN_U_"PI"_U_"USVHA"_U_SITE) ; icr #4648
;
S EDIPI="" F I=1:1 Q:'$D(TFLIST(I)) I $P(TFLIST(I),U,2)="NI",$P(TFLIST(I),U,3)="USDOD",$P(TFLIST(I),U,4)="200DOD",$P(TFLIST(I),U,5)="A" S EDIPI=$P(TFLIST(I),U,1) Q ;
;
Q EDIPI ;
;
ADD2PID(PIDSGMNT,DFN,ACCTNO) ; P184
;
; Reformats PID segment and adds fields to it to make it Cerner-compliant.
;
; PIDSGMNT = PID segment to be added to
; DFN = Patient (pointer to #2)
; ACCTNO = Patient account number [OPTIONAL]
;
; Note HL array must be defined or default values will be used.
;
N FS,CS,REPTTN,EDIPI,ICN ;
S FS=$G(HL("FS"),"|"),CS=$E($G(HL("ECH"),"^~\&"),1),REPTTN=$E($G(HL("ECH"),"^~\&"),2) ;
;
; Get EDIPI for patient.
;
S EDIPI=$$EDIPI^GMRCIUTL(DFN),ICN=$P(PIDSGMNT,FS,3) ;
;
; Clear PID-2 and PID-4
;
S $P(PIDSGMNT,FS,3)="",$P(PIDSGMNT,FS,5)="" ;
;
; Re-format PID-3 field.
;
S $P(PIDSGMNT,FS,4)=ICN_CS_CS_CS_"ICN"_CS_"VETID"_REPTTN_EDIPI_CS_CS_CS_"EDIPI"_CS_"EDIPI" ;
;
; Add patient account number to PID-18
;
I $G(ACCTNO)'="" S $P(PIDSGMNT,FS,19)=ACCTNO ;
;
Q PIDSGMNT ;
;
ADD2OBR(OBRSGMNT,CONSULT) ; P184
;
; Enhances OBR-2, OBR-4 and populates OBR-16, OBR-19 to make it Cerner-compliant.
;
; OBRSGMNT = OBR Segment to be enhanced
; CONSULT = Consult (pointer to #123)
;
N FS,CS,STN,ORDERNUM,OBR16,ORDPRVDR,NAME,NPI,FILE,ID,CODING,OBR19,FIELD,OBR20,OBR27 ;
S FS=$G(HL("FS"),"|"),CS=$E($G(HL("ECH"),"^~\&"),1) ;
;
; Populate OBR-2 with Cerner order number and station.
; Populate OBR-4.2 with procedure/service name.
; Populate OBR-16 with saved provider data if IFC role is filler.
; Populate OBR-19 with saved placer field 1 data if IFC role is filler.
; Populate OBR-20 and OBR-27.4 with saved data.
;
I $$GET1^DIQ(123,CONSULT,.125,"I")="F" D ;
. ;
. S STN=$P($G(^GMR(123,CONSULT,0)),U,23),ORDERNUM=$P($G(^GMR(123,CONSULT,0)),U,22) ;
. S STN=$$GET1^DIQ(4,STN,99,"E"),$P(OBRSGMNT,FS,3)=ORDERNUM_CS_STN_CS_"GMRCIFR" ;
. ;
. S ID=$P($P(OBRSGMNT,FS,5),CS,1),CODING=$P($P(OBRSGMNT,FS,5),CS,3),FILE=$P(CODING,"VA",2)/10,NAME="" ; WTC 10.24.22
. I FILE S NAME=$$GET1^DIQ(FILE,ID,.01,"E") ;
. S $P(OBRSGMNT,FS,5)=ID_CS_NAME_CS_CODING ;
. ;
. S OBR16=$G(^GMR(123,CONSULT,"CERNER1")),$P(OBRSGMNT,FS,17)=OBR16 ;
. S OBR19=$G(^GMR(123,CONSULT,"CERNER2")),$P(OBRSGMNT,FS,20)=OBR19 ; V10 WTC 6/28/22
. S OBR20=$P($G(^GMR(123,CONSULT,"CERNER")),U,11),$P(OBRSGMNT,FS,21)=OBR20 ; 185V2 WTC 4/24/23
. S OBR27=$P($G(^GMR(123,CONSULT,"CERNER")),U,12),$P(OBRSGMNT,FS,28)=CS_CS_CS_OBR27 ;
;
; Populate OBR-2 with consult number and VistA instance station number.
; Populate OBR-4.2 with procedure/service name.
; Populate OBR-16 with ordering provider if IFC role is placer.
;
I $$GET1^DIQ(123,CONSULT,.125,"I")="P" D ;
. ;
. S STN=$$STA^XUAF4($$KSP^XUPARAM("INST")),$P(OBRSGMNT,FS,3)=CONSULT_CS_STN_CS_"GMRCIFR" ; 185v2 4/24/23
. ;
. S ID=$P($P(OBRSGMNT,FS,5),CS,1),CODING=$P($P(OBRSGMNT,FS,5),CS,3),FILE=$P(CODING,"VA",2)/10,NAME="" ; WTC 10.24.22
. I FILE S FIELD=$S(FILE=123.5:133,FILE=123.3:127,1:.01),NAME=$$GET1^DIQ(FILE,ID,FIELD,"E") I $G(NAME)="" S NAME=$$GET1^DIQ(FILE,ID,.01,"E") ;
. S $P(OBRSGMNT,FS,5)=ID_CS_NAME_CS_CODING ;
. ;
. S ORDPRVDR=$P(^GMR(123,CONSULT,0),U,14) ;
. I ORDPRVDR S NAME=$$GET1^DIQ(200,ORDPRVDR,.01,"E"),NPI=$P($$NPI^XUSNPI("Individual_ID",ORDPRVDR),U,1),$P(OBRSGMNT,FS,17)=$S(NPI>0:NPI,1:"")_CS_$P(NAME,",",1)_CS_$P($P(NAME,",",2)," ",1)_CS_$P($P(NAME,",",2)," ",2) ;
;
Q OBRSGMNT ;
;
INCERNER(DFN) ;
;
; Determine if patient is in Cerner patient database. Return "YES" or "NO". wtc 8/17/23 p189
;
I $G(DFN)="" Q "NO" ;
;
N SITE,TFLIST,FOUND,I ;
;
S SITE=$P($$SITE^VASITE(),U,3) D TFL^VAFCTFU2(.TFLIST,DFN_U_"PI"_U_"USVHA"_U_SITE) ;
S FOUND="NO" F I=1:1 Q:'$D(TFLIST(I)) I $P(TFLIST(I),U,4)="200CRNR",$P(TFLIST(I),U,5)="A" S FOUND="YES" Q ;
;
Q FOUND ;
;
NOSND() ;Do not respond to the sent comment.
N GMRCL,GMRCZ,GMRCARRAY
S GMRCDQ=0
S GMRCL="",GMRCL=$O(^GMR(123,IEN,40,"B",GMRCL),-1) Q:GMRCL="" GMRCDQ
S GMRCZ="",GMRCZ=$O(^GMR(123,IEN,40,"B",GMRCL,""))
D GETS^DIQ(123.02,GMRCZ_","_IEN_",",.32,"I","GMRCARRAY")
S GMRCDQ=$G(GMRCARRAY(123.02,GMRCZ_","_IEN_",",.32,"I"),0)
Q GMRCDQ
;
ERR101 ;Unknown Consult/Procedure request
ERR201 ;Unknown Patient
ERR202 ;Local or unknown MPI identifiers
ERR203 ;Patient not in Cerner
ERR205 ;Waiting for treating facility list to be updated
ERR301 ;Service not matched to receiving facility
ERR401 ;Procedure not matched to receiving facility
ERR501 ;Error in procedure name
ERR601 ;Multiple services matched to procedure
ERR701 ;Error in Service name
ERR702 ;Service is Disabled
ERR703 ;Procedure is Inactive
ERR801 ;Inappropriate action for specified request
ERR802 ;Duplicate, activity not filed
ERR901 ;Unable to update record successfully
ERR902 ;Earlier pending transactions
ERR903 ;HL Logical Link not found
ERR904 ;VistA HL7 unable to send transaction
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIUTL 13154 printed Dec 13, 2024@01:46:13 Page 2
GMRCIUTL ;SLC/JFR - UTILITIES FOR INTER-FACILITY CONSULTS ; Jun 18, 2024@15:00:56
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,58,184,185,189**;DEC 27, 1997;Build 54
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; #2051 DIC, #2053 DIE, #3015 VAFCPID, #10112 VASITE, #10103 XLFDT, #3065 XLFNAME, #2171 XUAF4, #2541 XUPARAM, #4648 VAFCTFU2
+5 ; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
+6 ;
+7 ;don't start at the top
QUIT
+8 ;
DIV(LOC) ; get the division from a hospital location
+1 ; Input -- LOC HOSPITAL LOCATION file (#44) IEN
+2 ; Output -- INSTITUTION file (#4) IEN^INSTITUTION file (#4) NAME
+3 ;
+4 NEW GMRCHL,GMRCSTN,GMRCDIV
+5 SET GMRCHL=$PIECE($GET(^SC(+LOC,0)),U,15)
+6 IF +GMRCHL
Begin DoDot:1
+7 SET GMRCSTN=$$SITE^VASITE(,GMRCHL)
+8 IF $PIECE(GMRCSTN,U)>0
IF ($PIECE(GMRCSTN,U,2)]"")
Begin DoDot:2
+9 SET GMRCDIV=$PIECE(GMRCSTN,U)_U_$PIECE(GMRCSTN,U,2)
End DoDot:2
End DoDot:1
+10 IF '$GET(GMRCDIV)
Begin DoDot:1
+11 SET GMRCDIV=+$GET(DUZ(2))_U_$PIECE($$NS^XUAF4(+$GET(DUZ(2))),U)
End DoDot:1
+12 QUIT GMRCDIV
+13 ;
HLNAME(GMRCWHO) ;HL7 format a name from a pointer to 200
+1 if '$DATA(^VA(200,+GMRCWHO,0))
QUIT ""
+2 NEW GMRC
+3 SET GMRC("FILE")=200
+4 SET GMRC("IENS")=GMRCWHO
+5 SET GMRC("FIELD")=.01
+6 QUIT $$HLNAME^XLFNAME(.GMRC,"S")
+7 ;
UNHLNAME(GMRCNM,GMRCNMC,STD,DEL) ;return regular name from HL7 name
+1 ;Input:
+2 ; GMRCNM = HL7 formatted name from a message
+3 ; GMRCNMC = array to retun name components in (by reference)
+4 ; STD = 1 or 0; 1 = return name given middle family suffix
+5 ; DEL = delimiting character separating name components
+6 ;
+7 ;Output:
+8 ; GMRCNMC=DREW,NANCY M III MD or NANCY M DREW III MD
+9 ; GMRCNMC("FAMILY")=DREW
+10 ; GMRCNMC("GIVEN")=NANCY
+11 ; GMRCNMC("MIDDLE")=M
+12 ; GMRCNM("SUFFIX")=III MD
+13 ;
+14 IF '$DATA(DEL)
SET DEL=U
+15 SET GMRCNMC=GMRCNM
+16 SET GMRCNMC=$$FMNAME^XLFNAME(.GMRCNMC,"CS")
+17 IF $GET(STD)
SET GMRCNMC=$$NAMEFMT^XLFNAME(.GMRCNMC,"G","Dc")
+18 QUIT
+19 ;
TRIMWP(ARRAY,PIECE) ;trim OBX or NTE segments so that only comment remains
+1 ; Input:
+2 ; ARRAY = the array in which the segments are contained
+3 ; ex. ^TMP("GMRCIF",541083753,"OBX",3,3)=3|TX|^COMMENTS^|3|text "
+4 ; PIECE = the piece in the array where the text lives
+5 ;
+6 ; Output:
+7 ; trimmed array
+8 ; ex. ^TMP("GMRCIF",541083753,"OBX",3,3)="text"
+9 ;
+10 NEW I
SET I=0
+11 FOR
SET I=$ORDER(@(ARRAY)@(I))
if 'I
QUIT
Begin DoDot:1
+12 SET @(ARRAY)@(I)=$PIECE(@(ARRAY)@(I),"|",PIECE)
End DoDot:1
+13 QUIT
+14 ;
VALMSG(GMRCPID,GMRCORC) ; determine if message is valid
+1 ;Input:
+2 ; GMRCPID = PID segment from an IFC HL7 message
+3 ; GMRCORC = ORC segment from an IFC HL7 message
+4 ;
+5 ;Output:
+6 ; 1 = message passes screening on patient, institution and ien
+7 ; 0^msg = message failed screening
+8 ; possible msg values:
+9 ;
+10 ;
+11 ;
+12 NEW GMRCDA,GMRCINST
+13 QUIT
+14 ;
URG(GMRCO) ;return urgency code to send in HL7 msg
+1 ; Input:
+2 ; GMRCO = consult ien from file 123
+3 ;
+4 ; Output:
+5 ; S = stat
+6 ; R = routine
+7 ; ZT = today
+8 ; Z24 = within 24 hours
+9 ; Z48 = within 48 hours
+10 ; Z72 = within 72 hours
+11 ; ZW = within 1 week
+12 ; ZM = within 1 month
+13 ; ZNA = next available
+14 ; ZE = emergency
+15 ;
+16 NEW URG,PROT,ORURG
+17 SET PROT=$PIECE(^GMR(123,GMRCO,0),U,9)
+18 SET URG=$PIECE($GET(^ORD(101,+PROT,0)),U)
SET URG=$PIECE(URG," - ",2)
+19 IF '$LENGTH(URG)
QUIT ""
+20 SET ORURG=$SELECT(URG="EMERGENCY":"STAT",URG="NOW":"STAT",URG="OUTPATIENT":"ROUTINE",1:URG)
+21 SET ORURG=$ORDER(^ORD(101.42,"B",ORURG,0))
+22 IF '+ORURG
QUIT ""
+23 QUIT $PIECE(^ORD(101.42,ORURG,0),"^",2)
GETSERV(GMRCSRV) ;return local service from IFC service in HL7 msg
+1 ;Input:
+2 ; GMRCSRV = OBR-4 (e.g. 4^CARDIOLOGY^578VA1235)
+3 ;
+4 ;Output:
+5 ; ien of local service
+6 NEW SERV,SENDER,ERROR
+7 SET SERV=$$FIND1^DIC(123.5,"","X",$PIECE(GMRCSRV,U,2))
+8 IF 'SERV
SET ERROR="-1^ERROR IN SERVICE NAME^701"
+9 IF '$DATA(ERROR)
Begin DoDot:1
+10 SET SENDER=$PIECE(GMRCSRV,U,3)
+11 SET SENDER=+$$IEN^XUAF4($PIECE(SENDER,"VA1235"))
End DoDot:1
+12 IF '$DATA(ERROR)
Begin DoDot:1
+13 IF $ORDER(^GMR(123.5,SERV,"IFCS","B",SENDER,0))
QUIT
+14 SET ERROR="-1^IMPROPER SENDING FACILITY^301"
End DoDot:1
+15 IF '$DATA(ERROR)
Begin DoDot:1
+16 IF $PIECE($GET(^GMR(123.5,SERV,0)),U,2)'=9
QUIT
+17 SET ERROR="-1^SERVICE IS DISABLED^702"
End DoDot:1
+18 QUIT $SELECT($DATA(ERROR):ERROR,1:SERV)
+19 ;
GETPROC(GMRCSID) ;return procedure and sercvice ordered by IFC
+1 ;Input:
+2 ; GMRCSID =OBR-4 from IFC msg (e.g. "31^EKG^578VA1233" )
+3 ;
+4 ;Output:
+5 ; string in format local_proc_ien^service_ien_to perform
+6 ;
+7 NEW GMRCSS,GMRCPR,SENDER,ERROR
+8 SET GMRCPR=$$FIND1^DIC(123.3,"","X",$PIECE(GMRCSID,U,2))
+9 IF 'GMRCPR
SET ERROR="-1^ERROR IN PROCEDURE NAME^501"
+10 IF '$DATA(ERROR)
Begin DoDot:1
+11 SET SENDER=$PIECE(GMRCSID,U,3)
+12 SET SENDER=+$$IEN^XUAF4($PIECE(SENDER,"VA1233"))
End DoDot:1
+13 IF '$DATA(ERROR)
Begin DoDot:1
+14 IF $ORDER(^GMR(123.3,GMRCPR,"IFCS","B",SENDER,0))
QUIT
+15 SET ERROR="-1^IMPROPER SENDING FACILITY^401"
End DoDot:1
+16 IF '$DATA(ERROR)
Begin DoDot:1
+17 DO GETSVC^GMRCPR0(.GMRCSS,GMRCPR)
+18 IF GMRCSS>1
SET ERROR="-1^MULTIPLE SERVICES DEFINED^601"
QUIT
+19 SET GMRCSS=+GMRCSS(1)
End DoDot:1
+20 IF '$DATA(ERROR)
Begin DoDot:1
+21 IF $PIECE($GET(^GMR(123.3,GMRCPR,0)),U,2)'=1
QUIT
+22 SET ERROR="-1^PROCEDURE IS INACTIVE^703"
End DoDot:1
+23 QUIT $SELECT($DATA(ERROR):ERROR,1:GMRCPR_U_GMRCSS)
CODEOI(GMRCDA) ; look at ordered procedure or service and code it for IFC msg
+1 ;Input:
+2 ; GMRCDA = ien from file 123 of consult or procedure to send as IFC
+3 ;
+4 ;Output:
+5 ; consult: svc_ien^remote_service_name^station#_VA1235
+6 ; proc: proc_ien^remote_proc_name^station#_VA1233
+7 ;
+8 NEW GMRCPR,GMRCSS,GMRCSIT,GMRCOI
+9 SET GMRCSIT=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+10 ; it's a procedure
IF +$PIECE(^GMR(123,GMRCDA,0),U,8)
Begin DoDot:1
+11 SET GMRCPR=+$PIECE(^GMR(123,GMRCDA,0),U,8)
+12 ; P184
SET GMRCOI=GMRCPR_U_$PIECE($GET(^GMR(123.3,GMRCPR,"IFC")),U,2)_U_GMRCSIT_"VA1233"
End DoDot:1
+13 ; it's a consult
IF '$DATA(GMRCOI)
Begin DoDot:1
+14 SET GMRCSS=$PIECE(^GMR(123,GMRCDA,0),U,5)
+15 ; P184
SET GMRCOI=GMRCSS_U_$PIECE($GET(^GMR(123.5,GMRCSS,"IFC")),U,2)_U_GMRCSIT_"VA1235"
End DoDot:1
+16 QUIT GMRCOI
+17 ;
RESP(GMRCAC,GMRCMID,GMRCOC,GMRCDA,GMRCERR) ;build and send appl ACK/NAK
+1 ; Input:
+2 ; GMRCAC = acknowledgement code (AA or AR)
+3 ; GMRCMID = message id from original msg
+4 ; GMRCOC = order control from original msg ORC
+5 ; GMRCDA = ien of consult being worked on
+6 ; GMRCERR = only defined if an error is found
+7 ;
+8 SET HLA("HLA",1)=$$MSA^GMRCISEG(GMRCAC,GMRCMID,$GET(GMRCERR))
+9 ;
+10 ; Generate PID segment for Cerner orders. Insert EDIPI and patient account number. p184
+11 ;
+12 ;
NEW DFN,PID,EDIPI,ICN,PTACCTNO,FS,CS,REPTTN,SEGNUM,PTACCTNO
+13 ;
SET SEGNUM=1
+14 ;
IF $GET(GMRCDA)
Begin DoDot:1
+15 ;
SET DFN=$PIECE(^GMR(123,GMRCDA,0),U,2)
SET PTACCTNO=$PIECE($GET(^GMR(123,GMRCDA,"CERNER")),U,3)
+16 ;
IF PTACCTNO'=""
Begin DoDot:2
+17 ;
SET HLECH=HL("ECH")
SET PID=$$EN^VAFCPID(DFN,"1,2,3,7,8,19")
SET PID=$$ADD2PID(PID,DFN,PTACCTNO)
+18 ;
SET SEGNUM=SEGNUM+1
SET HLA("HLA",SEGNUM)=PID
End DoDot:2
End DoDot:1
+19 ;
+20 IF $DATA(GMRCOC)
Begin DoDot:1
+21 IF GMRCOC="NW"
SET SEGNUM=SEGNUM+1
SET HLA("HLA",SEGNUM)=$$ORCRESP^GMRCISG1(GMRCDA,"OK","IP")
End DoDot:1
+22 ;
+23 ; Generate OBR segment for Cerner orders. p184
+24 ;
+25 ;
IF $GET(GMRCDA)
IF PTACCTNO'=""
SET SEGNUM=SEGNUM+1
SET HLA("HLA",SEGNUM)=$$OBR^GMRCISG1(GMRCDA)
SET HLA("HLA",SEGNUM)=$$ADD2OBR(HLA("HLA",SEGNUM),GMRCDA)
+26 QUIT
+27 ;
LOGMSG(GMRCO,GMRCACT,GMRCMSG,GMRCER) ;create or update IFC MESSAGE LOG entry
+1 ;Input:
+2 ; GMRCO = ien from file 123
+3 ; GMRCACT = ien in 40 multiple from file 123
+4 ; GMRCMSG = HL7 message ID of message being sent
+5 ; GMRCER = error number if can't transmit immediately
+6 ;
+7 NEW GMRCLG,GMRCERR,FDA
+8 SET GMRCLG=$ORDER(^GMR(123.6,"AC",GMRCO,GMRCACT,1,0))
+9 ; update existing incomplete record.
IF +GMRCLG
Begin DoDot:1
+10 SET FDA(1,123.6,GMRCLG_",",.01)=$$NOW^XLFDT
+11 SET FDA(1,123.6,GMRCLG_",",.03)=$GET(GMRCMSG)
+12 SET FDA(1,123.6,GMRCLG_",",.07)=$PIECE(^GMR(123.6,GMRCLG,0),U,7)+1
+13 IF $GET(GMRCER)
SET FDA(1,123.6,GMRCLG_",",.08)=GMRCER
+14 DO UPDATE^DIE("","FDA(1)",,"GMRCERR")
End DoDot:1
QUIT
+15 ;
+16 ; create new record
+17 SET FDA(1,123.6,"+1,",.01)=$$NOW^XLFDT
+18 SET FDA(1,123.6,"+1,",.02)=$PIECE(^GMR(123,GMRCO,0),U,23)
+19 SET FDA(1,123.6,"+1,",.03)=$GET(GMRCMSG)
+20 SET FDA(1,123.6,"+1,",.04)=GMRCO
+21 SET FDA(1,123.6,"+1,",.05)=GMRCACT
+22 SET FDA(1,123.6,"+1,",.06)=1
+23 SET FDA(1,123.6,"+1,",.07)=1
+24 IF $GET(GMRCER)
SET FDA(1,123.6,"+1,",.08)=GMRCER
+25 DO UPDATE^DIE("","FDA(1)","GMRCLG","GMRCERR")
+26 ;
+27 ; Save Cerner-bound HL7 message in file #1609. - P189
+28 ;
+29 ;
IF $$CNVTD^GMRCIEVT(GMRCO)=1
IF $DATA(^TMP("HLS",$JOB))
DO SAVEHL7X^EHMHL7("HLS","IFC","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"CERNER-"_$$STA^XUAF4($PIECE(^GMR(123,GMRCO,0),U,23)),"|","^","~")
+30 ;
+31 QUIT
+32 ;
EDIPI(DFN) ; p184
+1 ;
+2 ; Return patient's EDIPI
+3 ;
+4 ;
NEW SITE,TFLIST,I
+5 ;
+6 ; icr #4648
SET SITE=$PIECE($$SITE^VASITE(),U,3)
DO TFL^VAFCTFU2(.TFLIST,DFN_U_"PI"_U_"USVHA"_U_SITE)
+7 ;
+8 ;
SET EDIPI=""
FOR I=1:1
if '$DATA(TFLIST(I))
QUIT
IF $PIECE(TFLIST(I),U,2)="NI"
IF $PIECE(TFLIST(I),U,3)="USDOD"
IF $PIECE(TFLIST(I),U,4)="200DOD"
IF $PIECE(TFLIST(I),U,5)="A"
SET EDIPI=$PIECE(TFLIST(I),U,1)
QUIT
+9 ;
+10 ;
QUIT EDIPI
+11 ;
ADD2PID(PIDSGMNT,DFN,ACCTNO) ; P184
+1 ;
+2 ; Reformats PID segment and adds fields to it to make it Cerner-compliant.
+3 ;
+4 ; PIDSGMNT = PID segment to be added to
+5 ; DFN = Patient (pointer to #2)
+6 ; ACCTNO = Patient account number [OPTIONAL]
+7 ;
+8 ; Note HL array must be defined or default values will be used.
+9 ;
+10 ;
NEW FS,CS,REPTTN,EDIPI,ICN
+11 ;
SET FS=$GET(HL("FS"),"|")
SET CS=$EXTRACT($GET(HL("ECH"),"^~\&"),1)
SET REPTTN=$EXTRACT($GET(HL("ECH"),"^~\&"),2)
+12 ;
+13 ; Get EDIPI for patient.
+14 ;
+15 ;
SET EDIPI=$$EDIPI^GMRCIUTL(DFN)
SET ICN=$PIECE(PIDSGMNT,FS,3)
+16 ;
+17 ; Clear PID-2 and PID-4
+18 ;
+19 ;
SET $PIECE(PIDSGMNT,FS,3)=""
SET $PIECE(PIDSGMNT,FS,5)=""
+20 ;
+21 ; Re-format PID-3 field.
+22 ;
+23 ;
SET $PIECE(PIDSGMNT,FS,4)=ICN_CS_CS_CS_"ICN"_CS_"VETID"_REPTTN_EDIPI_CS_CS_CS_"EDIPI"_CS_"EDIPI"
+24 ;
+25 ; Add patient account number to PID-18
+26 ;
+27 ;
IF $GET(ACCTNO)'=""
SET $PIECE(PIDSGMNT,FS,19)=ACCTNO
+28 ;
+29 ;
QUIT PIDSGMNT
+30 ;
ADD2OBR(OBRSGMNT,CONSULT) ; P184
+1 ;
+2 ; Enhances OBR-2, OBR-4 and populates OBR-16, OBR-19 to make it Cerner-compliant.
+3 ;
+4 ; OBRSGMNT = OBR Segment to be enhanced
+5 ; CONSULT = Consult (pointer to #123)
+6 ;
+7 ;
NEW FS,CS,STN,ORDERNUM,OBR16,ORDPRVDR,NAME,NPI,FILE,ID,CODING,OBR19,FIELD,OBR20,OBR27
+8 ;
SET FS=$GET(HL("FS"),"|")
SET CS=$EXTRACT($GET(HL("ECH"),"^~\&"),1)
+9 ;
+10 ; Populate OBR-2 with Cerner order number and station.
+11 ; Populate OBR-4.2 with procedure/service name.
+12 ; Populate OBR-16 with saved provider data if IFC role is filler.
+13 ; Populate OBR-19 with saved placer field 1 data if IFC role is filler.
+14 ; Populate OBR-20 and OBR-27.4 with saved data.
+15 ;
+16 ;
IF $$GET1^DIQ(123,CONSULT,.125,"I")="F"
Begin DoDot:1
+17 ;
+18 ;
SET STN=$PIECE($GET(^GMR(123,CONSULT,0)),U,23)
SET ORDERNUM=$PIECE($GET(^GMR(123,CONSULT,0)),U,22)
+19 ;
SET STN=$$GET1^DIQ(4,STN,99,"E")
SET $PIECE(OBRSGMNT,FS,3)=ORDERNUM_CS_STN_CS_"GMRCIFR"
+20 ;
+21 ; WTC 10.24.22
SET ID=$PIECE($PIECE(OBRSGMNT,FS,5),CS,1)
SET CODING=$PIECE($PIECE(OBRSGMNT,FS,5),CS,3)
SET FILE=$PIECE(CODING,"VA",2)/10
SET NAME=""
+22 ;
IF FILE
SET NAME=$$GET1^DIQ(FILE,ID,.01,"E")
+23 ;
SET $PIECE(OBRSGMNT,FS,5)=ID_CS_NAME_CS_CODING
+24 ;
+25 ;
SET OBR16=$GET(^GMR(123,CONSULT,"CERNER1"))
SET $PIECE(OBRSGMNT,FS,17)=OBR16
+26 ; V10 WTC 6/28/22
SET OBR19=$GET(^GMR(123,CONSULT,"CERNER2"))
SET $PIECE(OBRSGMNT,FS,20)=OBR19
+27 ; 185V2 WTC 4/24/23
SET OBR20=$PIECE($GET(^GMR(123,CONSULT,"CERNER")),U,11)
SET $PIECE(OBRSGMNT,FS,21)=OBR20
+28 ;
SET OBR27=$PIECE($GET(^GMR(123,CONSULT,"CERNER")),U,12)
SET $PIECE(OBRSGMNT,FS,28)=CS_CS_CS_OBR27
End DoDot:1
+29 ;
+30 ; Populate OBR-2 with consult number and VistA instance station number.
+31 ; Populate OBR-4.2 with procedure/service name.
+32 ; Populate OBR-16 with ordering provider if IFC role is placer.
+33 ;
+34 ;
IF $$GET1^DIQ(123,CONSULT,.125,"I")="P"
Begin DoDot:1
+35 ;
+36 ; 185v2 4/24/23
SET STN=$$STA^XUAF4($$KSP^XUPARAM("INST"))
SET $PIECE(OBRSGMNT,FS,3)=CONSULT_CS_STN_CS_"GMRCIFR"
+37 ;
+38 ; WTC 10.24.22
SET ID=$PIECE($PIECE(OBRSGMNT,FS,5),CS,1)
SET CODING=$PIECE($PIECE(OBRSGMNT,FS,5),CS,3)
SET FILE=$PIECE(CODING,"VA",2)/10
SET NAME=""
+39 ;
IF FILE
SET FIELD=$SELECT(FILE=123.5:133,FILE=123.3:127,1:.01)
SET NAME=$$GET1^DIQ(FILE,ID,FIELD,"E")
IF $GET(NAME)=""
SET NAME=$$GET1^DIQ(FILE,ID,.01,"E")
+40 ;
SET $PIECE(OBRSGMNT,FS,5)=ID_CS_NAME_CS_CODING
+41 ;
+42 ;
SET ORDPRVDR=$PIECE(^GMR(123,CONSULT,0),U,14)
+43 ;
IF ORDPRVDR
SET NAME=$$GET1^DIQ(200,ORDPRVDR,.01,"E")
SET NPI=$PIECE($$NPI^XUSNPI("Individual_ID",ORDPRVDR),U,1)
SET $PIECE(OBRSGMNT,FS,17)=$SELECT(NPI>0:NPI,1:"")_CS_$PIECE(NAME,",",1)_CS_$PIECE($PIECE(NAME,",",2)," ",1)_CS_$PIECE($PIECE(NAME,",",2)," ",2)
End DoDot:1
+44 ;
+45 ;
QUIT OBRSGMNT
+46 ;
INCERNER(DFN) ;
+1 ;
+2 ; Determine if patient is in Cerner patient database. Return "YES" or "NO". wtc 8/17/23 p189
+3 ;
+4 ;
IF $GET(DFN)=""
QUIT "NO"
+5 ;
+6 ;
NEW SITE,TFLIST,FOUND,I
+7 ;
+8 ;
SET SITE=$PIECE($$SITE^VASITE(),U,3)
DO TFL^VAFCTFU2(.TFLIST,DFN_U_"PI"_U_"USVHA"_U_SITE)
+9 ;
SET FOUND="NO"
FOR I=1:1
if '$DATA(TFLIST(I))
QUIT
IF $PIECE(TFLIST(I),U,4)="200CRNR"
IF $PIECE(TFLIST(I),U,5)="A"
SET FOUND="YES"
QUIT
+10 ;
+11 ;
QUIT FOUND
+12 ;
NOSND() ;Do not respond to the sent comment.
+1 NEW GMRCL,GMRCZ,GMRCARRAY
+2 SET GMRCDQ=0
+3 SET GMRCL=""
SET GMRCL=$ORDER(^GMR(123,IEN,40,"B",GMRCL),-1)
if GMRCL=""
QUIT GMRCDQ
+4 SET GMRCZ=""
SET GMRCZ=$ORDER(^GMR(123,IEN,40,"B",GMRCL,""))
+5 DO GETS^DIQ(123.02,GMRCZ_","_IEN_",",.32,"I","GMRCARRAY")
+6 SET GMRCDQ=$GET(GMRCARRAY(123.02,GMRCZ_","_IEN_",",.32,"I"),0)
+7 QUIT GMRCDQ
+8 ;
ERR101 ;Unknown Consult/Procedure request
ERR201 ;Unknown Patient
ERR202 ;Local or unknown MPI identifiers
ERR203 ;Patient not in Cerner
ERR205 ;Waiting for treating facility list to be updated
ERR301 ;Service not matched to receiving facility
ERR401 ;Procedure not matched to receiving facility
ERR501 ;Error in procedure name
ERR601 ;Multiple services matched to procedure
ERR701 ;Error in Service name
ERR702 ;Service is Disabled
ERR703 ;Procedure is Inactive
ERR801 ;Inappropriate action for specified request
ERR802 ;Duplicate, activity not filed
ERR901 ;Unable to update record successfully
ERR902 ;Earlier pending transactions
ERR903 ;HL Logical Link not found
ERR904 ;VistA HL7 unable to send transaction
