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

GMRCHL7I.m

Go to the documentation of this file.
  1. GMRCHL7I ;DAL/PHH - PROCESS HL7 RRI^I13 MESSAGES FROM HCPS ;8/7/14
  1. ;;3.0;CONSULT/REQUEST TRACKING;**75**;DEC 27, 1997;Build 22
  1. ;
  1. Q
  1. ; Documented API's and Integration Agreements
  1. ; ----------------------------------------------
  1. ; 2165 GENACK^HLMA1
  1. ; 2701 $$GETDFN^MPIF001
  1. ; 2701 $$GETICN^MPIF001
  1. ; 3535 MAKEADD^TIUSRVP2
  1. ; 10103 $$HL7TFM^XLFDT
  1. ;
  1. EN ; Entry point for routine
  1. N FS,CS,RS,ES,SS,MID,HLQUIT,HLNODE,I13MSG
  1. S FS=$G(HL("FS"),"|")
  1. S CS=$E($G(HL("ECH")),1) S:CS="" CS="^"
  1. S RS=$E($G(HL("ECH")),2) S:RS="" RS="~"
  1. S ES=$E($G(HL("ECH")),3) S:ES="" ES="\"
  1. S SS=$E($G(HL("ECH")),4) S:SS="" SS="&"
  1. S MID=$G(HL("MID"))
  1. S (HLQUIT,HLNODE)=0
  1. D COPYMSG(.I13MSG)
  1. Q:$$CHKMSG(.I13MSG)
  1. Q:$$PROCMSG(.I13MSG)
  1. D ACK("AA",MID)
  1. Q
  1. ;
  1. COPYMSG(Y) ; Copy HL7 Message to array Y (by reference)
  1. ; Based on HL*1.6*56 VISTA HL7 Site Manager & Developer Manual
  1. ; Paragraph 9.7, page 9-4
  1. I $L($G(HLNEXT)) ;HL7 context
  1. E Q
  1. N I,J
  1. F I=1:1 X HLNEXT Q:HLQUIT'>0 D
  1. .S Y(I)=HLNODE,J=0
  1. .F S J=$O(HLNODE(J)) Q:'J D
  1. ..S Y(I)=Y(I)_HLNODE(J)
  1. Q
  1. ;
  1. CHKMSG(Y) ; Check Message for all required segments
  1. N QUIT,REQSEG,SEGFND,I,SEGTYP,ICN,DFN
  1. S QUIT=0
  1. F REQSEG="MSH","RF1","PRD","PID","OBR","PV1","NTE" D Q:QUIT
  1. .S (SEGFND,I)=0
  1. .F S I=$O(Y(I)) Q:'I!(SEGFND) D
  1. ..S SEGTYP=$E(Y(I),1,3)
  1. ..I SEGTYP=REQSEG S SEGFND=1
  1. ..;
  1. ..I SEGTYP="MSH",$P(Y(I),FS,10)="" D
  1. ...S QUIT=1
  1. ...D ACK("AE",MID,"MSH","",10,101,"MESSAGE CONTROL ID MISSING")
  1. ..;
  1. .I 'SEGFND D
  1. ..S QUIT=1
  1. ..D ACK("AE",MID,REQSEG,"","",100,REQSEG_" SEGMENT MISSING OR OUT OF ORDER")
  1. Q QUIT
  1. ;
  1. PROCMSG(Y) ; Process message
  1. N QUIT,I,SEGTYP,GMRCRF1,GMRCPID,GMRCOBR,GMRCNTE,GMRCIEN,GMRCICN
  1. N GMRCDFN,GMRCTIU,GMRCTIUS,ADDTXT,GMRCATIU
  1. S (QUIT,I)=0
  1. F S I=$O(Y(I)) Q:'I D
  1. .S SEGTYP=$E(Y(I),1,3)
  1. .I SEGTYP="RF1" D RF1(Y(I),.GMRCRF1)
  1. .I SEGTYP="PID" D PID(Y(I),.GMRCPID)
  1. .I SEGTYP="OBR" D OBR(Y(I),.GMRCOBR)
  1. .I SEGTYP="NTE" D NTE(Y(I),.GMRCNTE)
  1. ;
  1. S GMRCIEN=+GMRCRF1
  1. ;
  1. I 'GMRCIEN!('$D(^GMR(123,+GMRCIEN,0))) D Q QUIT
  1. .S QUIT=1
  1. .D ACK("AE",MID,"RF1","",6,"VA207","INVALID IEN FOR CONSULT",1)
  1. ;
  1. S GMRCICN=GMRCPID
  1. S GMRCDFN=$$GETDFN^MPIF001($P(GMRCICN,"V"))
  1. I GMRCDFN'>0 D Q QUIT
  1. .S QUIT=1
  1. .D ACK("AE",MID,"PID",1,3,"VA207",$P(GMRCDFN,"^",2),1)
  1. I GMRCICN'=$$GETICN^MPIF001(GMRCDFN) D Q QUIT
  1. .S QUIT=1
  1. .D ACK("AE",MID,"PID",1,3,"VA207","ICN CHECKSUM DOES NOT MATCH CHECKSUM IN DATABASE",1)
  1. ;
  1. I $P(^GMR(123,GMRCIEN,0),"^",2)'=GMRCDFN D Q QUIT
  1. .S QUIT=1
  1. .D ACK("AE",MID,"RF1","",6,"VA207","ICN DOES NOT MATCH PATIENT DFN IN CONSULT",1)
  1. ;
  1. ; Reject if Referral Status is not valid
  1. I $P(GMRCRF1,FS,2)'="IP^ADDED COMMENT",$P(GMRCRF1,FS,2)'="CM^ADDENDED",$P(GMRCRF1,FS,2)'="IP^REJECTED" D Q QUIT
  1. .S QUIT=1
  1. .D ACK("AE",MID,"RF1","",1,"VA207","INVALID REFERRAL STATUS",1)
  1. ;
  1. ; Add comment to file #123
  1. I $P(GMRCRF1,FS,2)="IP^ADDED COMMENT"!($P(GMRCRF1,FS,2)="IP^REJECTED") D
  1. .;
  1. .; Quit if IEN being passed by HCP isn't for a Consult
  1. .I +GMRCOBR'=GMRCIEN!($P(GMRCOBR,FS,2)'="GMRC") D Q
  1. ..S QUIT=1
  1. ..D ACK("AE",MID,"OBR",1,3,"VA207","INVALID CONSULT REFERENCE",1)
  1. .;
  1. .I $D(GMRCNTE("WP")) D ADDCMT(GMRCIEN,.GMRCNTE)
  1. .I $P(GMRCRF1,FS,2)="IP^ADDED COMMENT" D SNDALRT(GMRCIEN)
  1. .I $P(GMRCRF1,FS,2)="IP^REJECTED" D SNDALRT(GMRCIEN,1)
  1. ;
  1. ; Add addendum to file #8925
  1. I $P(GMRCRF1,FS,2)="CM^ADDENDED" D
  1. .;
  1. .S GMRCTIU=+GMRCOBR,GMRCTIUS=""
  1. .D GETSTAT^TIUPRF2(.GMRCTIUS,GMRCTIU)
  1. .S GMRCTIUS=$P(GMRCTIUS,"^",2)
  1. .;
  1. .; Quit if IEN being passed by HCP isn't for a Progress Note
  1. .I 'GMRCTIU!($P(GMRCOBR,FS,2)'="TIU")!('$D(^TIU(8925,+GMRCTIU,0)))!(GMRCTIUS="RETRACTED") D Q
  1. ..S QUIT=1
  1. ..D ACK("AE",MID,"OBR",1,3,"VA207","INVALID PROGRESS NOTE REFERENCE",1)
  1. .;
  1. .D TIUTXT(.GMRCNTE,.ADDTXT)
  1. .D MAKEADD^TIUSRVP2(.GMRCATIU,GMRCTIU,.ADDTXT)
  1. .I +GMRCATIU>0 D UPDUSRS(GMRCTIU,GMRCATIU)
  1. .D SNDALRT(GMRCIEN)
  1. ;
  1. Q QUIT
  1. ;
  1. RF1(RF1SEG,RETVAL) ; Process RF1 Segment
  1. N GMRCSTS,GMRCIEN
  1. S GMRCSTS=$P(RF1SEG,FS,2)
  1. S GMRCIEN=$P(RF1SEG,FS,7)
  1. S RETVAL=GMRCIEN_FS_GMRCSTS
  1. Q
  1. ;
  1. PID(PIDSEG,RETVAL) ; Process PID Segment
  1. N GMRCICN
  1. S GMRCICN=$P($P(PIDSEG,FS,4),CS)
  1. S RETVAL=GMRCICN
  1. Q
  1. ;
  1. OBR(OBRSEG,RETVAL) ; Process OBR Segment
  1. N GMRCOIEN,GMRCTYP
  1. S GMRCOIEN=+$P(OBRSEG,FS,4)
  1. S GMRCTYP=$P($P(OBRSEG,FS,4),CS,2)
  1. S RETVAL=GMRCOIEN_FS_GMRCTYP
  1. Q
  1. ;
  1. NTE(NTESEG,RETVAL) ; Process NTE Segment
  1. N I,GMRCTXT
  1. S I=$P(NTESEG,FS,2)
  1. Q:'+I
  1. S GMRCTXT=$$DEESCAPE($P(NTESEG,FS,4))
  1. ; Strip the following only if HCPS is sending separately
  1. I GMRCTXT="Activity Comment" Q
  1. I GMRCTXT="Comment~~" Q
  1. ;
  1. I $E(GMRCTXT,1,8)="Author~~" D
  1. .S $E(GMRCTXT,1,8)="Author: "
  1. ;
  1. I $E(GMRCTXT,1,10)="Datetime~~" D Q
  1. .S RETVAL("Datetime")=$P(GMRCTXT,"Datetime~~",2)
  1. .; Strip any 'spaces'
  1. .S RETVAL("Datetime")=$TR(RETVAL("Datetime")," ","")
  1. ;
  1. I $E(GMRCTXT,1,9)="Comment~~" D
  1. .S $E(GMRCTXT,1,9)="Comment: "
  1. ;
  1. S RETVAL("WP",I)=GMRCTXT
  1. Q
  1. ;
  1. ADDCMT(GMRCIEN,NTEARY) ; Add comment to file #123
  1. N GMRCFDA,GMRCERR,GMRCCMT,GMRCLACT,GMRCPRXY
  1. S GMRCFDA(.01)=$$NOW^XLFDT
  1. S GMRCFDA(1)=$O(^GMR(123.1,"B","ADDED COMMENT",0))
  1. S GMRCFDA(2)=GMRCFDA(.01)
  1. I $G(NTEARY("Datetime"))'="" D
  1. .S GMRCFDA(2)=$$HL7TFM^XLFDT(NTEARY("Datetime"),"L")
  1. S GMRCPRXY=+$O(^VA(200,"B","HCPS,APPLICATION PROXY",0))
  1. I GMRCPRXY D
  1. .S GMRCFDA(3)=GMRCPRXY
  1. .S GMRCFDA(4)=GMRCPRXY
  1. K FDA
  1. M FDA(1,123.02,"+1,"_GMRCIEN_",")=GMRCFDA
  1. D UPDATE^DIE("","FDA(1)",,"GMRCERR")
  1. ;
  1. S GMRCCMT=$NA(NTEARY("WP"))
  1. S GMRCLACT=$O(^GMR(123,GMRCIEN,40," "),-1)
  1. D WP^DIE(123.02,GMRCLACT_","_GMRCIEN_",",5,"K",GMRCCMT)
  1. K FDA
  1. Q
  1. ;
  1. TIUTXT(NTEARY,RETVAL) ; Return TIU-formatted Text
  1. N I
  1. S I=0
  1. F S I=$O(NTEARY("WP",I)) Q:'I D
  1. .S RETVAL("TEXT",I,0)=NTEARY("WP",I)
  1. Q
  1. ;
  1. UPDUSRS(GMRCTIU,GMRCATIU) ; Update Users on Addendums
  1. N GMRC1302,GMRC1202,GMRC1204,DIE,DA,DR,X
  1. S GMRC1302=+$P($G(^TIU(8925,GMRCTIU,13)),"^",2) ; ENTERED BY
  1. S GMRC1202=+$P($G(^TIU(8925,GMRCTIU,12)),"^",2) ; AUTHOR/DICTATOR
  1. S GMRC1204=+$P($G(^TIU(8925,GMRCTIU,12)),"^",4) ; EXPECTED SIGNER
  1. ;
  1. S DIE="^TIU(8925,",DA=GMRCATIU
  1. S DR="1302///^S X=GMRC1302;1202///^S X=GMRC1202;1204///^S X=GMRC1204"
  1. L +^TIU(8925,GMRCATIU):$G(DILOCKTM,3)
  1. I $T D ^DIE L -^TIU(8925,GMRCATIU)
  1. Q
  1. ;
  1. DEESCAPE(TXTSTR) ; De-escape delimiters
  1. ; (assuming "\" is the escape character):
  1. ; - field separator (de-escape from \F\)
  1. ; - component separator (de-escape from \S\)
  1. ; - repetition separator (de-escape from \R\)
  1. ; - escape character (de-escape from \E\)
  1. ; - subcomponent separator (de-escape from \T\)
  1. ; \F\ will be de-escaped only if the length of FS is 1.
  1. ;
  1. N HLDATA,HLENCHR,HLI,HLCHAR,HLCHAR23,HLEN,HLOUT
  1. S HLDATA=$G(TXTSTR)
  1. Q:HLDATA']"" HLDATA
  1. ;
  1. S HLENCHR=$G(HL("ECH"),"^~\&")
  1. Q:$L(HLENCHR)<3 HLDATA
  1. ;
  1. S HLEN=$L(HLDATA)
  1. S HLOUT=""
  1. F HLI=1:1:HLEN D
  1. .S HLCHAR=$E(HLDATA,HLI)
  1. .S HLCHAR23=""
  1. .I HLCHAR=ES D
  1. ..S HLCHAR23=$E(HLDATA,HLI+1,HLI+2)
  1. .I $L($G(FS))=1,(HLCHAR23=("F"_ES)) D Q
  1. ..S HLOUT=HLOUT_FS
  1. ..S HLI=HLI+2
  1. .I HLCHAR23=("S"_ES) D Q
  1. ..S HLOUT=HLOUT_CS
  1. ..S HLI=HLI+2
  1. .I HLCHAR23=("R"_ES) D Q
  1. ..S HLOUT=HLOUT_RS
  1. ..S HLI=HLI+2
  1. .I HLCHAR23=("E"_ES) D Q
  1. ..S HLOUT=HLOUT_ES
  1. ..S HLI=HLI+2
  1. .I $L(HLENCHR)>3,(HLCHAR23=("T"_ES)) D Q
  1. ..S HLOUT=HLOUT_SS
  1. ..S HLI=HLI+2
  1. .S HLOUT=HLOUT_HLCHAR
  1. ;
  1. Q HLOUT
  1. ;
  1. SNDALRT(GMRCIEN,GMRCRJT) ; Send Alert
  1. ; GMRCRJT is optional, and is only set to 1 for a rejection status
  1. N GMRCORTX,GMRCORN,GMRCRP,GMRCADUZ,GMRCDFN
  1. S GMRCORTX="Updates received from HCP "
  1. I +$G(GMRCRJT) S GMRCORTX="Rejected status from HCP "
  1. S GMRCORN=63
  1. S GMRCRP=+$P($G(^GMR(123,+GMRCIEN,0)),"^",14) ; Requesting Provider
  1. S:GMRCRP GMRCADUZ(GMRCRP)=""
  1. I '$D(GMRCADUZ) S GMRCADUZ=""
  1. S GMRCDFN=$P($G(^GMR(123,+GMRCIEN,0)),"^",2)
  1. S GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCIEN)
  1. D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCIEN,GMRCORN,.GMRCADUZ,"")
  1. Q
  1. ;
  1. ACK(STAT,MID,SID,SEG,FLD,CD,TXT,ACKTYP) ; Creates ACKs for HL7 Message
  1. ;STAT = Status (Acknowledgment Code) (REQUIRED)
  1. ;MID = Message ID (REQUIRED)
  1. ;SID = Segment ID (set if ERR occured in segment) (OPTIONAL)
  1. ;SEG = Segment location of error (OPTIONAL)
  1. ;FLD = Field location of error (OPTIONAL)
  1. ;CD = Error Code (OPTIONAL)
  1. ;TXT = Text describing error (OPTIONAL)
  1. ;ACKTYP = Acknowledgment Type (OPTIONAL)
  1. ;
  1. N HLA,EID,EIDS,RES,ERR
  1. ;
  1. ;Make sure the parameters are defined
  1. S STAT=$G(STAT),MID=$G(MID),SID=$G(SID),SEG=$G(SEG)
  1. S FLD=$G(FLD),CD=$G(CD),TXT=$G(TXT)
  1. ;
  1. ;Create MSA Segment
  1. S HLA("HLA",1)="MSA"_FS_STAT_FS_MID
  1. S EID=$G(HL("EID"))
  1. S EIDS=$G(HL("EIDS"))
  1. Q:((EID="")!($G(HLMTIENS)="")!(EIDS=""))
  1. ;
  1. S RES=""
  1. ;If Segment ID (SID) is set, create ERR segment
  1. D:$L(SID)>0
  1. .S HLA("HLA",2)="ERR"
  1. .S $P(HLA("HLA",2),FS,3)=SID_CS_SEG_CS_FLD
  1. .S $P(HLA("HLA",2),FS,5)="E"
  1. .;
  1. .; Commit Error
  1. .I '+$G(ACKTYP) D
  1. ..S $P(HLA("HLA",2),FS,4)=CD_CS_TXT_CS_"0357"
  1. .;
  1. .; Application Error
  1. .I +$G(ACKTYP)=1 D
  1. ..S $P(HLA("HLA",2),FS,6)=CS_CS_CS_CD_CS_TXT
  1. ;
  1. D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES)
  1. Q