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

GMRCIUTL.m

Go to the documentation of this file. 
  1. GMRCIUTL ;SLC/JFR - UTILITIES FOR INTER-FACILITY CONSULTS ;11/26/01 15:34
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**22,58**;DEC 27, 1997;Build 4
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  Q  ;don't start at the top
  1.  ;
  1. DIV(LOC) ; get the division from a hospital location
  1.  ; Input  -- LOC  HOSPITAL LOCATION file (#44) IEN
  1.  ; Output -- INSTITUTION file (#4) IEN^INSTITUTION file (#4) NAME
  1.  ;
  1.  N GMRCHL,GMRCSTN,GMRCDIV
  1.  S GMRCHL=$P($G(^SC(+LOC,0)),U,15)
  1.  I +GMRCHL D
  1.  . S GMRCSTN=$$SITE^VASITE(,GMRCHL)
  1.  . I $P(GMRCSTN,U)>0,($P(GMRCSTN,U,2)]"") D
  1.  . . S GMRCDIV=$P(GMRCSTN,U)_U_$P(GMRCSTN,U,2)
  1.  I '$G(GMRCDIV) D
  1.  . S GMRCDIV=+$G(DUZ(2))_U_$P($$NS^XUAF4(+$G(DUZ(2))),U)
  1.  Q GMRCDIV
  1.  ;
  1. HLNAME(GMRCWHO)        ;HL7 format a name from a pointer to 200
  1.  Q:'$D(^VA(200,+GMRCWHO,0)) ""
  1.  N GMRC
  1.  S GMRC("FILE")=200
  1.  S GMRC("IENS")=GMRCWHO
  1.  S GMRC("FIELD")=.01
  1.  Q $$HLNAME^XLFNAME(.GMRC,"S")
  1.  ;
  1. UNHLNAME(GMRCNM,GMRCNMC,STD,DEL) ;return regular name from HL7 name
  1.  ;Input:
  1.  ;  GMRCNM  = HL7 formatted name from a message
  1.  ;  GMRCNMC = array to retun name components in (by reference)
  1.  ;  STD     = 1 or 0; 1 = return name given middle family suffix
  1.  ;  DEL     = delimiting character separating name components
  1.  ;
  1.  ;Output:
  1.  ;  GMRCNMC=DREW,NANCY M III MD or NANCY M DREW III MD
  1.  ;  GMRCNMC("FAMILY")=DREW
  1.  ;  GMRCNMC("GIVEN")=NANCY
  1.  ;  GMRCNMC("MIDDLE")=M
  1.  ;  GMRCNM("SUFFIX")=III MD
  1.  ;
  1.  I '$D(DEL) S DEL=U
  1.  S GMRCNMC=GMRCNM
  1.  S GMRCNMC=$$FMNAME^XLFNAME(.GMRCNMC,"CS")
  1.  I $G(STD) S GMRCNMC=$$NAMEFMT^XLFNAME(.GMRCNMC,"G","Dc")
  1.  Q
  1.  ;
  1. TRIMWP(ARRAY,PIECE) ;trim OBX or NTE segments so that only comment remains
  1.  ; Input:
  1.  ;   ARRAY  = the array in which the segments are contained
  1.  ;      ex. ^TMP("GMRCIF",541083753,"OBX",3,3)=3|TX|^COMMENTS^|3|text "
  1.  ;   PIECE  = the piece in the array where the text lives
  1.  ; 
  1.  ; Output:
  1.  ;   trimmed array 
  1.  ;     ex. ^TMP("GMRCIF",541083753,"OBX",3,3)="text"
  1.  ;
  1.  N I S I=0
  1.  F  S I=$O(@(ARRAY)@(I)) Q:'I  D
  1.  . S @(ARRAY)@(I)=$P(@(ARRAY)@(I),"|",PIECE)
  1.  Q
  1.  ;
  1. VALMSG(GMRCPID,GMRCORC) ; determine if message is valid
  1.  ;Input:
  1.  ;  GMRCPID  = PID segment from an IFC HL7 message
  1.  ;  GMRCORC  = ORC segment from an IFC HL7 message
  1.  ;
  1.  ;Output:
  1.  ;  1     = message passes screening on patient, institution and ien
  1.  ;  0^msg = message failed screening
  1.  ;    possible msg values:
  1.  ;        
  1.  ;
  1.  ;
  1.  N GMRCDA,GMRCINST
  1.  Q
  1.  ;
  1. URG(GMRCO) ;return urgency code to send in HL7 msg
  1.  ; Input:
  1.  ;   GMRCO = consult ien from file 123
  1.  ;
  1.  ; Output:
  1.  ;   S   = stat
  1.  ;   R   = routine
  1.  ;   ZT  = today
  1.  ;   Z24 = within 24 hours
  1.  ;   Z48 = within 48 hours
  1.  ;   Z72 = within 72 hours
  1.  ;   ZW  = within 1 week
  1.  ;   ZM  = within 1 month
  1.  ;   ZNA = next available
  1.  ;   ZE  = emergency
  1.  ;
  1.  N URG,PROT,ORURG
  1.  S PROT=$P(^GMR(123,GMRCO,0),U,9)
  1.  S URG=$P($G(^ORD(101,+PROT,0)),U),URG=$P(URG," - ",2)
  1.  I '$L(URG) Q ""
  1.  S ORURG=$S(URG="EMERGENCY":"STAT",URG="NOW":"STAT",URG="OUTPATIENT":"ROUTINE",1:URG)
  1.  S ORURG=$O(^ORD(101.42,"B",ORURG,0))
  1.  I '+ORURG Q ""
  1.  Q $P(^ORD(101.42,ORURG,0),"^",2)
  1. GETSERV(GMRCSRV) ;return local service from IFC service in HL7 msg
  1.  ;Input:
  1.  ;  GMRCSRV = OBR-4 (e.g. 4^CARDIOLOGY^578VA1235)
  1.  ;
  1.  ;Output:
  1.  ;  ien of local service
  1.  N SERV,SENDER,ERROR
  1.  S SERV=$$FIND1^DIC(123.5,"","X",$P(GMRCSRV,U,2))
  1.  I 'SERV S ERROR="-1^ERROR IN SERVICE NAME^701"
  1.  I '$D(ERROR) D
  1.  . S SENDER=$P(GMRCSRV,U,3)
  1.  . S SENDER=+$$IEN^XUAF4($P(SENDER,"VA1235"))
  1.  I '$D(ERROR) D
  1.  . I $O(^GMR(123.5,SERV,"IFCS","B",SENDER,0)) Q
  1.  . S ERROR="-1^IMPROPER SENDING FACILITY^301"
  1.  I '$D(ERROR) D
  1.  . I $P($G(^GMR(123.5,SERV,0)),U,2)'=9 Q
  1.  . S ERROR="-1^SERVICE IS DISABLED^702"
  1.  Q $S($D(ERROR):ERROR,1:SERV)
  1.  ;
  1. GETPROC(GMRCSID) ;return procedure and sercvice ordered by IFC
  1.  ;Input:
  1.  ;  GMRCSID  =OBR-4 from IFC msg  (e.g. "31^EKG^578VA1233" )
  1.  ;
  1.  ;Output:
  1.  ;  string in format  local_proc_ien^service_ien_to perform
  1.  ;
  1.  N GMRCSS,GMRCPR,SENDER,ERROR
  1.  S GMRCPR=$$FIND1^DIC(123.3,"","X",$P(GMRCSID,U,2))
  1.  I 'GMRCPR S ERROR="-1^ERROR IN PROCEDURE NAME^501"
  1.  I '$D(ERROR) D
  1.  . S SENDER=$P(GMRCSID,U,3)
  1.  . S SENDER=+$$IEN^XUAF4($P(SENDER,"VA1233"))
  1.  I '$D(ERROR) D
  1.  . I $O(^GMR(123.3,GMRCPR,"IFCS","B",SENDER,0)) Q
  1.  . S ERROR="-1^IMPROPER SENDING FACILITY^401"
  1.  I '$D(ERROR) D
  1.  . D GETSVC^GMRCPR0(.GMRCSS,GMRCPR)
  1.  . I GMRCSS>1 S ERROR="-1^MULTIPLE SERVICES DEFINED^601" Q
  1.  . S GMRCSS=+GMRCSS(1)
  1.  I '$D(ERROR) D
  1.  . I $P($G(^GMR(123.3,GMRCPR,0)),U,2)'=1 Q
  1.  . S ERROR="-1^PROCEDURE IS INACTIVE^703"
  1.  Q $S($D(ERROR):ERROR,1:GMRCPR_U_GMRCSS)
  1. CODEOI(GMRCDA) ; look at ordered procedure or service and code it for IFC msg
  1.  ;Input:
  1.  ;  GMRCDA = ien from file 123 of consult or procedure to send as IFC
  1.  ;
  1.  ;Output:
  1.  ;  consult:  svc_ien^remote_service_name^station#_VA1235
  1.  ;  proc:     proc_ien^remote_proc_name^station#_VA1233
  1.  ;
  1.  N GMRCPR,GMRCSS,GMRCSIT,GMRCOI
  1.  S GMRCSIT=$$STA^XUAF4($$KSP^XUPARAM("INST"))
  1.  I +$P(^GMR(123,GMRCDA,0),U,8) D  ; it's a procedure
  1.  . S GMRCPR=+$P(^GMR(123,GMRCDA,0),U,8)
  1.  . S GMRCOI=GMRCPR_U_$P(^GMR(123.3,GMRCPR,"IFC"),U,2)_U_GMRCSIT_"VA1233"
  1.  I '$D(GMRCOI) D  ; it's a consult
  1.  . S GMRCSS=$P(^GMR(123,GMRCDA,0),U,5)
  1.  . S GMRCOI=GMRCSS_U_$P(^GMR(123.5,GMRCSS,"IFC"),U,2)_U_GMRCSIT_"VA1235"
  1.  Q GMRCOI
  1.  ;
  1. RESP(GMRCAC,GMRCMID,GMRCOC,GMRCDA,GMRCERR) ;build and send appl ACK/NAK 
  1.  ; Input:
  1.  ;   GMRCAC  = acknowledgement code (AA or AR)
  1.  ;   GMRCMID = message id from original msg
  1.  ;   GMRCOC  = order control from original msg ORC
  1.  ;   GMRCDA  = ien of consult being worked on
  1.  ;   GMRCERR = only defined if an error is found
  1.  ;
  1.  S HLA("HLA",1)=$$MSA^GMRCISEG(GMRCAC,GMRCMID,$G(GMRCERR))
  1.  I $D(GMRCOC) D
  1.  . I GMRCOC="NW" S HLA("HLA",2)=$$ORCRESP^GMRCISG1(GMRCDA,"OK","IP")
  1.  Q
  1.  ;
  1. LOGMSG(GMRCO,GMRCACT,GMRCMSG,GMRCER) ;create or update IFC MESSAGE LOG entry
  1.  ;Input:
  1.  ; GMRC0   = ien from file 123
  1.  ; GMRCACT = ien in 40 multiple from file 123
  1.  ; GMRCMSG = HL7 message ID of message being sent 
  1.  ; GMRCER  = error number if can't transmit immediately
  1.  ;
  1.  N GMRCLG,GMRCERR,FDA
  1.  S GMRCLG=$O(^GMR(123.6,"AC",GMRCO,GMRCACT,1,0))
  1.  I +GMRCLG D  Q  ; update existing incomplete record.
  1.  . S FDA(1,123.6,GMRCLG_",",.01)=$$NOW^XLFDT
  1.  . S FDA(1,123.6,GMRCLG_",",.03)=$G(GMRCMSG)
  1.  . S FDA(1,123.6,GMRCLG_",",.07)=$P(^GMR(123.6,GMRCLG,0),U,7)+1
  1.  . I $G(GMRCER) S FDA(1,123.6,GMRCLG_",",.08)=GMRCER
  1.  . D UPDATE^DIE("","FDA(1)",,"GMRCERR")
  1.  ;
  1.  ; create new record
  1.  S FDA(1,123.6,"+1,",.01)=$$NOW^XLFDT
  1.  S FDA(1,123.6,"+1,",.02)=$P(^GMR(123,GMRCO,0),U,23)
  1.  S FDA(1,123.6,"+1,",.03)=$G(GMRCMSG)
  1.  S FDA(1,123.6,"+1,",.04)=GMRCO
  1.  S FDA(1,123.6,"+1,",.05)=GMRCACT
  1.  S FDA(1,123.6,"+1,",.06)=1
  1.  S FDA(1,123.6,"+1,",.07)=1
  1.  I $G(GMRCER) S FDA(1,123.6,"+1,",.08)=GMRCER
  1.  D UPDATE^DIE("","FDA(1)","GMRCLG","GMRCERR")
  1.  Q
  1.  ;
  1. ERR101 ;Unknown Consult/Procedure request
  1. ERR201 ;Unknown Patient
  1. ERR202 ;Local or unknown MPI identifiers
  1. ERR301 ;Service not matched to receiving facility
  1. ERR401 ;Procedure not matched to receiving facility
  1. ERR501 ;Error in procedure name
  1. ERR601 ;Multiple services matched to procedure
  1. ERR701 ;Error in Service name
  1. ERR702 ;Service is Disabled
  1. ERR703 ;Procedure is Inactive
  1. ERR801 ;Inappropriate action for specified request
  1. ERR802 ;Duplicate, activity not filed
  1. ERR901 ;Unable to update record successfully
  1. ERR902 ;Earlier pending transactions
  1. ERR903 ;HL Logical Link not found
  1. ERR904 ;VistA HL7 unable to send transaction