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