GMRCCCRI ;DAL/PHH/MBJ - PROCESS HL7 RRI^I13 MESSAGES FROM HSRM ;8/29/18
;;3.0;CONSULT/REQUEST TRACKING;**123**;FEB 2019;Build 51
;
; Built from pieces of GMRCHL7I and modified for CCRA consult status update
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,ABORT,ERR1,NAKMSG
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("CA",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","PV1" 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("CE",MID,"MSH","",10,101,"MESSAGE CONTROL ID MISSING")
..;
.I 'SEGFND D
..S QUIT=1
..D ACK("CE",MID,REQSEG,"","",100,REQSEG_" SEGMENT MISSING OR OUT OF ORDER")
Q QUIT
;
PROCMSG(Y) ; Process message
N QUIT,I,SEGTYP,GMRCRF1,GMRCPID,GMRCPRD,GMRCOBR,GMRCNTE,GMRCIEN,GMRCICN,GMRCEML
N GMRCDFN,GMRCTIU,GMRCTIUS,ADDTXT,GMRCATIU,STID,PROGAUTH,REFDT,REFXDT,XDT
S (QUIT,I)=0,GMRCEML=""
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="PRD" D PRD(Y(I),.GMRCPRD)
;
S GMRCIEN=+GMRCRF1,GMRCSTS=$P(GMRCRF1,FS,2)
;
I 'GMRCIEN!('$D(^GMR(123,+GMRCIEN,0))) D Q QUIT
.S QUIT=1
.D ACK("CE",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("CE",MID,"PID",1,3,"VA207",$P(GMRCDFN,"^",2),1)
I GMRCICN'=$$GETICN^MPIF001(GMRCDFN) D Q QUIT
.S QUIT=1
.D ACK("CE",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("CE",MID,"RF1","",6,"VA207","ICN DOES NOT MATCH PATIENT DFN IN CONSULT",1)
;
; check for valid VistA user via user email value, create NAK if invalid and quit
S GMRCDT=$$NOW^XLFDT(),GMRCDT1=$$FMTE^XLFDT(GMRCDT,2)
; S XDT=$E($P(GMRCDT1,".",2)+1000000,2,5),GMRCDT1=$P(GMRCDT1,".")_XDT
S GMRCUSER=$$LOW^XLFSTR(GMRCEML)
I GMRCUSER'="" S GMRCUSER=$O(^VA(200,"ADUPN",$G(GMRCUSER),""))
I GMRCUSER'>0 S (NAKMSG,ERR1)="HSRM USER DOESN'T HAVE AN ACCOUNT ON THIS SYSTEM",ABORT="1^"_ERR1
I $G(NAKMSG)'="" S QUIT=1 D ANAK^GMRCCCR1($G(NAKMSG),$G(GMRCEML),$G(GMRCICN),$G(GMRCDFN),$G(GMRCIEN),GMRCDT1)
I +$G(ABORT)>0 D MESSAGE2^GMRCCCR1(MID,.ABORT,GMRCIEN) Q 1
;
; Reject if Referral Status is not valid
S STID=$P(GMRCSTS,CS)
I "A,AC,AP,BP,C,D,P,RJ,X,"'[STID_"," D
.S QUIT=1
.D ACK("CE",MID,"RF1","",1,"VA207","INVALID REFERRAL STATUS",1)
;
Q:QUIT
S GMRCSTS=$S(STID="A":"SCHEDULED",STID="AC":"ACTIVE",STID="AP":"ACTIVE",STID="BP":"COMPLETE",STID="C":"ACTIVE",STID="D":"COMPLETE",STID="P":"PENDING",STID="RJ":"ACTIVE",STID="X":"CANCELLED",1:"")
I GMRCSTS'="" D
. ; file status into field 8 of consult file
. K FDA S FDA(123,GMRCIEN_",",8)=GMRCSTS
. D FILE^DIE("E","FDA")
. K FDA,GMRCFDA
. ;
. S GMRCSTID=$S(STID="X":"CANCELLED",STID="A":"SCHEDULED",STID="BP":"COMPLETE/UPDATE",STID="D":"COMPLETE/UPDATE",1:"ADDED COMMENT")
. S GMRCSTID=$O(^GMR(123.1,"B",GMRCSTID,""))
. K FDA S FDA(123,GMRCIEN_",",9)=GMRCSTID
. D FILE^DIE("","FDA") K FDA
. ;
. ; create consult note for new status
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",1)=GMRCSTID
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
. D UPDATE^DIE("","GMRCFDA","GMRCCIEN")
. S GMRCTXT(1)="CONSULT STATUS CHANGED TO "_GMRCSTS_" "_GMRCDT1
. D WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
. K FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
;
; create consult note with new referral date from HSRM
I REFDT]"" D
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
. D UPDATE^DIE("","GMRCFDA","GMRCCIEN","GMRCERR")
. S GMRCTXT(1)="REFERRAL DATE IS "_REFDT ;
. D WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
. K FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
;
; create consult note with new referral expiration date from HSRM
I REFXDT]"" D
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
. D UPDATE^DIE("","GMRCFDA","GMRCCIEN")
. S GMRCTXT(1)="REFERRAL EXPIRATION DATE IS "_REFXDT ;
. D WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
. K FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
;
; create consult note with new program authority value from HSRM
I PROGAUTH]"" D
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
. S GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
. D UPDATE^DIE("","GMRCFDA","GMRCCIEN")
. S GMRCTXT(1)="PROGRAM AUTHORITY IS "_PROGAUTH
. D WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
. K FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
;
K GMRCFDA,GMRCDT,GMRCDT1,GMRCCIEN,GMRCSTID,GMRCTXT,GMRCUSER
Q QUIT
;
RF1(RF1SEG,RETVAL) ; Process RF1 Segment
N GMRCSTS,GMRCIEN
S GMRCSTS=$P(RF1SEG,FS,2)
S GMRCIEN=$P(RF1SEG,FS,7)
S REFDT=$P($P(RF1SEG,FS,8),CS)
S REFXDT=$P($P(RF1SEG,FS,9),CS)
S PROGAUTH=$P($P(RF1SEG,FS,11),CS,2)
S RETVAL=GMRCIEN_FS_GMRCSTS
Q
;
PID(PIDSEG,RETVAL) ; Process PID Segment
N GMRCICN,I,J,GMRCI,GMRCJ
S GMRCJ=$P(PIDSEG,FS,4),GMRCICN=""
F J=1:1:$L(GMRCJ,RS) D Q:GMRCICN'=""
. S GMRCI=$P(GMRCJ,RS,J)
. F I=1:1:$L(GMRCI,CS) D Q:GMRCICN'=""
.. I $P($P(GMRCJ,CS,I),RS)["NI" S GMRCICN=$P(GMRCI,CS,J) Q
S RETVAL=GMRCICN
Q
;
PRD(PRDSEG,RETVAL) ; Process PRD segment
I $L(GMRCEML)>0 S RETVAL=GMRCEML Q RETVAL ; already found in previous PRD segment
I $P($P(PRDSEG,FS,2),CS,1)'="RP" S RETVAL=0 Q RETVAL
S GMRCEML=$P(PRDSEG,FS,6),GMRCEML=$P(GMRCEML,CS,4)
S RETVAL=GMRCEML Q RETVAL
;
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 occurred 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,ERRI
;
;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
. K ERRARY
. 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 ERRI=0
.. S $P(HLA("HLA",2),FS,6)=CS_CS_CS_CD_CS_TXT
.. ;Process Error
.. S ERRI=ERRI+1
.. S ERRARY(ERRI,2)=$P($G(HLA("HLA",2)),"|",3)
.. I $P($G(HLA("HLA",2)),"|",6)'="" D ;
... S ERRARY(ERRI,3)=$P($P($G(HLA("HLA",2)),"|",6),"^",4)_"^"_$P($P($G(HLA("HLA",2)),"|",6),"^",5)
.. I $P($G(HLA("HLA",2)),"|",6)="" S ERRARY(ERRI,3)=$P($G(HLA("HLA",2)),"|",4)
. I $D(ERRARY) D MESSAGE(MID,.ERRARY)
. ; build message for MailMan
;
D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES)
Q
MESSAGE(MSGID,ERRARY) ; Send a MailMan Message with the errors
N MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J
S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1)))
S XMSUB="GMRC CCRA Consult Updates from HSRM HL7 Error"
S MSGTEXT(1)=" "
S MSGTEXT(2)="Error in receiving HL7 message from HSRM"
S MSGTEXT(3)="Date: "_DATE
S MSGTEXT(4)="Message ID: "_MSGID
S MSGTEXT(5)="Error(s):"
S I=0,J=5 F S I=$O(ERRARY(I)) Q:'I D
. S J=J+1,MSGTEXT(J)=" "
. S J=J+1,MSGTEXT(J)=" "_$P($G(ERRARY(I,3)),U)_" - "_$P($G(ERRARY(I,3)),U,2)
. I $P($G(ERRARY(I,2)),U,1)'="" S J=J+1,MSGTEXT(J)=" Segment: "_$P($G(ERRARY(I,2)),U,1)
. I $P($G(ERRARY(I,2)),U,2)'="" S J=J+1,MSGTEXT(J)=" Sequence: "_$P($G(ERRARY(I,2)),U,2)
. I $P($G(ERRARY(I,2)),U,3)'="" S J=J+1,MSGTEXT(J)=" Field: "_$P($G(ERRARY(I,2)),U,3)
. I $P($G(ERRARY(I,2)),U,4)'="" S J=J+1,MSGTEXT(J)=" Fld Rep: "_$P($G(ERRARY(I,2)),U,4)
. I $P($G(ERRARY(I,2)),U,5)'="" S J=J+1,MSGTEXT(J)=" Component: "_$P($G(ERRARY(I,2)),U,5)
. I $P($G(ERRARY(I,2)),U,6)'="" S J=J+1,MSGTEXT(J)=" Sub-component: "_$P($G(ERRARY(I,2)),U,6)
S XMTEXT="MSGTEXT("
S XMDUZ="GMRC-CCRA<-HSRP Transaction Error"
S XMY("G.GMRC HCP HL7 MESSAGES")="" ; ** CHECK THIS OUT **
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCCCRI 9810 printed Sep 23, 2025@19:21:17 Page 2
GMRCCCRI ;DAL/PHH/MBJ - PROCESS HL7 RRI^I13 MESSAGES FROM HSRM ;8/29/18
+1 ;;3.0;CONSULT/REQUEST TRACKING;**123**;FEB 2019;Build 51
+2 ;
+3 ; Built from pieces of GMRCHL7I and modified for CCRA consult status update
+4 QUIT
+5 ; Documented API's and Integration Agreements
+6 ; ----------------------------------------------
+7 ; 2165 GENACK^HLMA1
+8 ; 2701 $$GETDFN^MPIF001
+9 ; 2701 $$GETICN^MPIF001
+10 ; 3535 MAKEADD^TIUSRVP2
+11 ; 10103 $$HL7TFM^XLFDT
+12 ;
EN ; Entry point for routine
+1 NEW FS,CS,RS,ES,SS,MID,HLQUIT,HLNODE,I13MSG,ABORT,ERR1,NAKMSG
+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("CA",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","PV1"
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("CE",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("CE",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,GMRCPRD,GMRCOBR,GMRCNTE,GMRCIEN,GMRCICN,GMRCEML
+2 NEW GMRCDFN,GMRCTIU,GMRCTIUS,ADDTXT,GMRCATIU,STID,PROGAUTH,REFDT,REFXDT,XDT
+3 SET (QUIT,I)=0
SET GMRCEML=""
+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="PRD"
DO PRD(Y(I),.GMRCPRD)
End DoDot:1
+9 ;
+10 SET GMRCIEN=+GMRCRF1
SET GMRCSTS=$PIECE(GMRCRF1,FS,2)
+11 ;
+12 IF 'GMRCIEN!('$DATA(^GMR(123,+GMRCIEN,0)))
Begin DoDot:1
+13 SET QUIT=1
+14 DO ACK("CE",MID,"RF1","",6,"VA207","INVALID IEN FOR CONSULT",1)
End DoDot:1
QUIT QUIT
+15 ;
+16 SET GMRCICN=GMRCPID
+17 SET GMRCDFN=$$GETDFN^MPIF001($PIECE(GMRCICN,"V"))
+18 IF GMRCDFN'>0
Begin DoDot:1
+19 SET QUIT=1
+20 DO ACK("CE",MID,"PID",1,3,"VA207",$PIECE(GMRCDFN,"^",2),1)
End DoDot:1
QUIT QUIT
+21 IF GMRCICN'=$$GETICN^MPIF001(GMRCDFN)
Begin DoDot:1
+22 SET QUIT=1
+23 DO ACK("CE",MID,"PID",1,3,"VA207","ICN CHECKSUM DOES NOT MATCH CHECKSUM IN DATABASE",1)
End DoDot:1
QUIT QUIT
+24 ;
+25 IF $PIECE(^GMR(123,GMRCIEN,0),"^",2)'=GMRCDFN
Begin DoDot:1
+26 SET QUIT=1
+27 DO ACK("CE",MID,"RF1","",6,"VA207","ICN DOES NOT MATCH PATIENT DFN IN CONSULT",1)
End DoDot:1
QUIT QUIT
+28 ;
+29 ; check for valid VistA user via user email value, create NAK if invalid and quit
+30 SET GMRCDT=$$NOW^XLFDT()
SET GMRCDT1=$$FMTE^XLFDT(GMRCDT,2)
+31 ; S XDT=$E($P(GMRCDT1,".",2)+1000000,2,5),GMRCDT1=$P(GMRCDT1,".")_XDT
+32 SET GMRCUSER=$$LOW^XLFSTR(GMRCEML)
+33 IF GMRCUSER'=""
SET GMRCUSER=$ORDER(^VA(200,"ADUPN",$GET(GMRCUSER),""))
+34 IF GMRCUSER'>0
SET (NAKMSG,ERR1)="HSRM USER DOESN'T HAVE AN ACCOUNT ON THIS SYSTEM"
SET ABORT="1^"_ERR1
+35 IF $GET(NAKMSG)'=""
SET QUIT=1
DO ANAK^GMRCCCR1($GET(NAKMSG),$GET(GMRCEML),$GET(GMRCICN),$GET(GMRCDFN),$GET(GMRCIEN),GMRCDT1)
+36 IF +$GET(ABORT)>0
DO MESSAGE2^GMRCCCR1(MID,.ABORT,GMRCIEN)
QUIT 1
+37 ;
+38 ; Reject if Referral Status is not valid
+39 SET STID=$PIECE(GMRCSTS,CS)
+40 IF "A,AC,AP,BP,C,D,P,RJ,X,"'[STID_","
Begin DoDot:1
+41 SET QUIT=1
+42 DO ACK("CE",MID,"RF1","",1,"VA207","INVALID REFERRAL STATUS",1)
End DoDot:1
+43 ;
+44 if QUIT
QUIT
+45 SET GMRCSTS=$SELECT(STID="A":"SCHEDULED",STID="AC":"ACTIVE",STID="AP":"ACTIVE",STID="BP":"COMPLETE",STID="C":"ACTIVE",STID="D":"COMPLETE",STID="P":"PENDING",STID="RJ":"ACTIVE",STID="X":"CANCELLED",1:"")
+46 IF GMRCSTS'=""
Begin DoDot:1
+47 ; file status into field 8 of consult file
+48 KILL FDA
SET FDA(123,GMRCIEN_",",8)=GMRCSTS
+49 DO FILE^DIE("E","FDA")
+50 KILL FDA,GMRCFDA
+51 ;
+52 SET GMRCSTID=$SELECT(STID="X":"CANCELLED",STID="A":"SCHEDULED",STID="BP":"COMPLETE/UPDATE",STID="D":"COMPLETE/UPDATE",1:"ADDED COMMENT")
+53 SET GMRCSTID=$ORDER(^GMR(123.1,"B",GMRCSTID,""))
+54 KILL FDA
SET FDA(123,GMRCIEN_",",9)=GMRCSTID
+55 DO FILE^DIE("","FDA")
KILL FDA
+56 ;
+57 ; create consult note for new status
+58 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
+59 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",1)=GMRCSTID
+60 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
+61 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
+62 DO UPDATE^DIE("","GMRCFDA","GMRCCIEN")
+63 SET GMRCTXT(1)="CONSULT STATUS CHANGED TO "_GMRCSTS_" "_GMRCDT1
+64 DO WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
+65 KILL FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
End DoDot:1
+66 ;
+67 ; create consult note with new referral date from HSRM
+68 IF REFDT]""
Begin DoDot:1
+69 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
+70 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
+71 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
+72 DO UPDATE^DIE("","GMRCFDA","GMRCCIEN","GMRCERR")
+73 ;
SET GMRCTXT(1)="REFERRAL DATE IS "_REFDT
+74 DO WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
+75 KILL FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
End DoDot:1
+76 ;
+77 ; create consult note with new referral expiration date from HSRM
+78 IF REFXDT]""
Begin DoDot:1
+79 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
+80 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
+81 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
+82 DO UPDATE^DIE("","GMRCFDA","GMRCCIEN")
+83 ;
SET GMRCTXT(1)="REFERRAL EXPIRATION DATE IS "_REFXDT
+84 DO WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
+85 KILL FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
End DoDot:1
+86 ;
+87 ; create consult note with new program authority value from HSRM
+88 IF PROGAUTH]""
Begin DoDot:1
+89 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
+90 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
+91 SET GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
+92 DO UPDATE^DIE("","GMRCFDA","GMRCCIEN")
+93 SET GMRCTXT(1)="PROGRAM AUTHORITY IS "_PROGAUTH
+94 DO WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
+95 KILL FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
End DoDot:1
+96 ;
+97 KILL GMRCFDA,GMRCDT,GMRCDT1,GMRCCIEN,GMRCSTID,GMRCTXT,GMRCUSER
+98 QUIT QUIT
+99 ;
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 REFDT=$PIECE($PIECE(RF1SEG,FS,8),CS)
+5 SET REFXDT=$PIECE($PIECE(RF1SEG,FS,9),CS)
+6 SET PROGAUTH=$PIECE($PIECE(RF1SEG,FS,11),CS,2)
+7 SET RETVAL=GMRCIEN_FS_GMRCSTS
+8 QUIT
+9 ;
PID(PIDSEG,RETVAL) ; Process PID Segment
+1 NEW GMRCICN,I,J,GMRCI,GMRCJ
+2 SET GMRCJ=$PIECE(PIDSEG,FS,4)
SET GMRCICN=""
+3 FOR J=1:1:$LENGTH(GMRCJ,RS)
Begin DoDot:1
+4 SET GMRCI=$PIECE(GMRCJ,RS,J)
+5 FOR I=1:1:$LENGTH(GMRCI,CS)
Begin DoDot:2
+6 IF $PIECE($PIECE(GMRCJ,CS,I),RS)["NI"
SET GMRCICN=$PIECE(GMRCI,CS,J)
QUIT
End DoDot:2
if GMRCICN'=""
QUIT
End DoDot:1
if GMRCICN'=""
QUIT
+7 SET RETVAL=GMRCICN
+8 QUIT
+9 ;
PRD(PRDSEG,RETVAL) ; Process PRD segment
+1 ; already found in previous PRD segment
IF $LENGTH(GMRCEML)>0
SET RETVAL=GMRCEML
QUIT RETVAL
+2 IF $PIECE($PIECE(PRDSEG,FS,2),CS,1)'="RP"
SET RETVAL=0
QUIT RETVAL
+3 SET GMRCEML=$PIECE(PRDSEG,FS,6)
SET GMRCEML=$PIECE(GMRCEML,CS,4)
+4 SET RETVAL=GMRCEML
QUIT RETVAL
+5 ;
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 occurred 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,ERRI
+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 KILL ERRARY
+26 SET HLA("HLA",2)="ERR"
+27 SET $PIECE(HLA("HLA",2),FS,3)=SID_CS_SEG_CS_FLD
+28 SET $PIECE(HLA("HLA",2),FS,5)="E"
+29 ;
+30 ; Commit Error
+31 IF '+$GET(ACKTYP)
Begin DoDot:2
+32 SET $PIECE(HLA("HLA",2),FS,4)=CD_CS_TXT_CS_"0357"
End DoDot:2
+33 ;
+34 ; Application Error
+35 IF +$GET(ACKTYP)=1
Begin DoDot:2
+36 SET ERRI=0
+37 SET $PIECE(HLA("HLA",2),FS,6)=CS_CS_CS_CD_CS_TXT
+38 ;Process Error
+39 SET ERRI=ERRI+1
+40 SET ERRARY(ERRI,2)=$PIECE($GET(HLA("HLA",2)),"|",3)
+41 ;
IF $PIECE($GET(HLA("HLA",2)),"|",6)'=""
Begin DoDot:3
+42 SET ERRARY(ERRI,3)=$PIECE($PIECE($GET(HLA("HLA",2)),"|",6),"^",4)_"^"_$PIECE($PIECE($GET(HLA("HLA",2)),"|",6),"^",5)
End DoDot:3
+43 IF $PIECE($GET(HLA("HLA",2)),"|",6)=""
SET ERRARY(ERRI,3)=$PIECE($GET(HLA("HLA",2)),"|",4)
End DoDot:2
+44 IF $DATA(ERRARY)
DO MESSAGE(MID,.ERRARY)
+45 ; build message for MailMan
End DoDot:1
+46 ;
+47 DO GENACK^HLMA1(EID,$GET(HLMTIENS),EIDS,"LM",1,.RES)
+48 QUIT
MESSAGE(MSGID,ERRARY) ; Send a MailMan Message with the errors
+1 NEW MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J
+2 SET DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($PIECE(HL("DTM"),"-",1)))
+3 SET XMSUB="GMRC CCRA Consult Updates from HSRM HL7 Error"
+4 SET MSGTEXT(1)=" "
+5 SET MSGTEXT(2)="Error in receiving HL7 message from HSRM"
+6 SET MSGTEXT(3)="Date: "_DATE
+7 SET MSGTEXT(4)="Message ID: "_MSGID
+8 SET MSGTEXT(5)="Error(s):"
+9 SET I=0
SET J=5
FOR
SET I=$ORDER(ERRARY(I))
if 'I
QUIT
Begin DoDot:1
+10 SET J=J+1
SET MSGTEXT(J)=" "
+11 SET J=J+1
SET MSGTEXT(J)=" "_$PIECE($GET(ERRARY(I,3)),U)_" - "_$PIECE($GET(ERRARY(I,3)),U,2)
+12 IF $PIECE($GET(ERRARY(I,2)),U,1)'=""
SET J=J+1
SET MSGTEXT(J)=" Segment: "_$PIECE($GET(ERRARY(I,2)),U,1)
+13 IF $PIECE($GET(ERRARY(I,2)),U,2)'=""
SET J=J+1
SET MSGTEXT(J)=" Sequence: "_$PIECE($GET(ERRARY(I,2)),U,2)
+14 IF $PIECE($GET(ERRARY(I,2)),U,3)'=""
SET J=J+1
SET MSGTEXT(J)=" Field: "_$PIECE($GET(ERRARY(I,2)),U,3)
+15 IF $PIECE($GET(ERRARY(I,2)),U,4)'=""
SET J=J+1
SET MSGTEXT(J)=" Fld Rep: "_$PIECE($GET(ERRARY(I,2)),U,4)
+16 IF $PIECE($GET(ERRARY(I,2)),U,5)'=""
SET J=J+1
SET MSGTEXT(J)=" Component: "_$PIECE($GET(ERRARY(I,2)),U,5)
+17 IF $PIECE($GET(ERRARY(I,2)),U,6)'=""
SET J=J+1
SET MSGTEXT(J)=" Sub-component: "_$PIECE($GET(ERRARY(I,2)),U,6)
End DoDot:1
+18 SET XMTEXT="MSGTEXT("
+19 SET XMDUZ="GMRC-CCRA<-HSRP Transaction Error"
+20 ; ** CHECK THIS OUT **
SET XMY("G.GMRC HCP HL7 MESSAGES")=""
+21 DO ^XMD
+22 QUIT
