GMRCCCR1 ;COG/PB - Receive HL7 Message for HCP ;3/21/18 09:00
;;3.0;CONSULT/REQUEST TRACKING;**99,106,112,123,134,146,158,173,203**;JUN 1, 2018;Build 6
;
;DBIA# Supported Reference
;----- --------------------------------
;10106 HLADDR^HLFNC
;4648 TFL^VAFCTFU2
;
; MJ - 5/24/2018 patch 106 changes to add - GETADD function
; MJ - 2/28/2019 patch 112 subroutines added or split from GMRCCCRA
; MJ - 4/02/2019 patch 123 updated to find VistA user from HSRM message and create NAK if invalid
; MJ - 7/30/2019 patch 134 fix control character issue in TIU notes
; MJ - 9/20/2019 patch 146 clear space-only address fields
; PB - 6/22/2021 patch 173 to pull the EDIPI and add it to the PID segment
;
Q
;
GETADD(INSP) ;
; INSP contains internal value of insurance plan for this patient (IN1 segment)
N ADDLN1,ADDLN2,ADDLN3,ADDCITY,ADDST,ADDZIP,VADD,VCSZ,X
S ADDLN1=$$GET1^DIQ(36,INSP_",",.111)
S ADDLN2=$$GET1^DIQ(36,INSP_",",.112)
S ADDLN3=$$GET1^DIQ(36,INSP_",",.113)
S ADDCITY=$$GET1^DIQ(36,INSP_",",.114)
S ADDST=$$GET1^DIQ(36,INSP_",",.115,"I") ; S:ADDST ADDST=ADDST_"~"_$$GET1^DIQ(36,INSP_",",.115)
S ADDZIP=$$GET1^DIQ(36,INSP_",",.116)
S VADD=ADDLN1_"^"_ADDLN2,VCSZ=ADDCITY_"^"_ADDST_"^"_ADDZIP
S X=$$HLADDR^HLFNC(VADD,VCSZ)
S:X]"" $P(X,"^",7)="M" ; address type = 'mailing'
Q X
; end patch 106 mod
;
CLRADD(ADDRESS) ;
; patch 146 - take any address field that contains only spaces and change to null
N I,J,ADD
F I=1:1:$L(ADDRESS,"^") D ;
. S ADD=$P(ADDRESS,"^",I) I $L(ADD) D ;
.. F Q:$E(ADD,1)'=" " S ADD=$E(ADD,2,$L(ADD))
.. S $P(ADDRESS,"^",I)=ADD
Q ADDRESS
;
MESSAGE(MSGID,ERRARY) ; Send a MailMan Message with the errors
; moved here for patch 112
N MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,I,J
S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1)))
S XMSUB="GMRC CCRA Consults to HSRM HL7 Error"
S MSGTEXT(1)=" "
S MSGTEXT(2)="Error in transmitting HL7 message to 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")=""
D ^XMD
Q
;
MESSAGE2(MSGID,ABORT,CONID) ; Send a MailMan Message with the errors
N MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J,SITE,MSG
S SITE=$$KSP^XUPARAM("INST")
S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1)))
S XMSUB="Consult ID "_CONID_" - GMRC CCRA Scheduling 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 MSG="Error(s): "_$P(ABORT,"^",2)_"/VISTA "_SITE_"/Consult ID:"_CONID_". Please manually synchronize the consult"
S MSG=MSG_" in VistA #"_SITE_" with the information currently available in HSRM."
S MSGTEXT(5)=MSG
S XMTEXT="MSGTEXT("
S XMDUZ="GMRC-CCRA <-HSRM Transaction Error"
S XMY("G.GMRC HSRM SIU HL7 MESSAGES")="" ; ** CHECK THIS OUT **
D ^XMD
Q
;
CCONTROL(GMRCDA) ; patch 112
; remove control characters from data before building OBR segment
;
S YY=0 F S YY=$O(^GMR(123,GMRCDA,40,YY)) Q:YY'>0 D
.S XX=0 F S XX=$O(^GMR(123,GMRCDA,40,YY,1,XX)) Q:XX'>0 D
..K NODE
.. ;S TESTSTRING=$C(13)
..S NODE=$G(^GMR(123,GMRCDA,40,YY,1,XX,0))
..I $G(NODE)[$C(13,10,10) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(13,10,10)," ") ; <cr><lf><lf>
..I $G(NODE)[$C(13,10) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(13,10)," ") ; <cr><lf>
..I $G(NODE)[$C(13) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(13)," ") ; TERM char
..I $G(NODE)[$C(1) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(1)," ") ; SOH
..I $G(NODE)[$C(2) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(2)," ") ; STX
..I $G(NODE)[$C(3) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(3)," ") ; ETX
..I $G(NODE)[$C(4) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(4)," ") ; EOT
..I $G(NODE)[$C(5) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(5)," ") ; ENQ
..I $G(NODE)[$C(6) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(6)," ") ; ACK
..I $G(NODE)[$C(21) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(21)," ") ; NAK
..I $G(NODE)[$C(23) S ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TR(^GMR(123,GMRCDA,40,YY,1,XX,0),$C(23)," ") ; ETB
..;I $C(13,10,10)[$G(NODE) W !,XX," ",NODE
..K NODE ;,TESTSTRING
K XX,YY
Q
;
ANAK(NAKMSG,USERMAIL,ICN,DFN,CONID,GMRCDT) ; Application Error, send NAK back
N PATNAME,EID,EIDS,MSGN,SITE,CONPAT,RES,NAKMSG1
Q:$G(NAKMSG)=""
Q:$G(DFN)'>0
Q:$G(CONID)=""
Q:$G(GMRCDT)=""
Q:$G(^DPT(DFN,0))=""
S CONPAT=$$GET1^DIQ(123,CONID_",",.02,"I")
Q:$G(CONPAT)'=DFN ;Patient in appt msg not the same as patient in the consult
S PATNAME=$P(^DPT(DFN,0),"^"),SITE=$$KSP^XUPARAM("INST")
S:$G(ICN)="" ICN=$P(^DPT(DFN,"MPI"),"^",10)
S EID=$G(HL("EID"))
S EIDS=$G(HL("EIDS"))
S MSGN=$G(HL("MID"))
; S NAKMSG1=NAKMSG_"/VISTA "_SITE_"/Consult ID:"_CONID_". Please manually synchronize the consult"
; S NAKMSG1=NAKMSG1_" in VistA #"_SITE_" with the information currently available in HSRM."
S HLA("HLA",1)="MSA|AE|"_$G(MSGN)_"|"_$G(USERMAIL)_" "_$G(NAKMSG)_"|||"_$G(ICN)_"^"_$G(PATNAME)_"^"_SITE_"^"_CONID_"^"_GMRCDT
D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES)
Q
TIUC(X) ; Check each segment of the TIU notes for HL7 control characters
Q:$G(X)=""
I $G(X)[$C(13,10,10) S X=$TR(X,$C(13,10,10),"") ; <cr><lf><lf>
I $G(X)[$C(13,10) S X=$TR(X,$C(13,10),"") ; <cr><lf>
I $G(X)[$C(13) S X=$TR(X,$C(13),"") ; TERM char
I $G(X)[$C(1) S X=$TR(X,$C(1),"") ; SOH
I $G(X)[$C(2) S X=$TR(X,$C(2),"") ; STX
I $G(X)[$C(3) S X=$TR(X,$C(3),"") ; ETX
I $G(X)[$C(4) S X=$TR(X,$C(4),"") ; EOT
I $G(X)[$C(5) S X=$TR(X,$C(5),"") ; ENQ
I $G(X)[$C(6) S X=$TR(X,$C(6),"") ; ACK
I $G(X)[$C(21) S X=$TR(X,$C(21),"") ; NAK
I $G(X)[$C(23) S X=$TR(X,$C(23),"") ; ETB
I $G(X)[$C(11) S X=$TR(X,$C(11)," ") ; TAB with space
Q X
ADDEND ; moved from ADDEND^GMRCCCRA routine for space ; patch 146 ; MJ
; returns 0 if value not found
;
; modified in patch GMRC*3.0*106 to use ICR 2693
D EXTRACT^TIULQ(TIUDA)
;
; Quit if not an addendum
S TIUTYP=^TMP("TIULQ",$J,+TIUDA,.01,"I")
I TIUTYP'=81 Q 0
;
S DFN=^TMP("TIULQ",$J,+TIUDA,.02,"I")
I 'DFN!('$D(^DPT(DFN))) Q 0
;
; Get parent note IEN, if addendum IEN is passed in:
S GMRCPARN=^TMP("TIULQ",$J,+TIUDA,.06,"I")
;
; Quit if not an addendum
;S TIUTYP=$$GET1^DIQ(8925,TIUDA,.01,"I")
;I TIUTYP'=81 Q
;
;S DFN=$$GET1^DIQ(8925,TIUDA,.02,"I")
;I 'DFN,'$D(^DPT(DFN)) Q
;
; Get parent note IEN, if addendum IEN is passed in:
;S GMRCPARN=$$GET1^DIQ(8925,TIUDA,.06,"I")
;
; end patch 106 mods
;
S (GMRCO,GMRCD)=0
F S GMRCD=$O(^GMR(123,"AD",DFN,GMRCD)) Q:'GMRCD!(GMRCO) D
.S GMRCDA=0
.F S GMRCDA=$O(^GMR(123,"AD",DFN,GMRCD,GMRCDA)) Q:'GMRCDA!(GMRCO) D
..S GMRCD1=0
..F S GMRCD1=$O(^GMR(123,GMRCDA,50,GMRCD1)) Q:'GMRCD1!(GMRCO) D
...S GMRC8925=$$GET1^DIQ(123.03,GMRCD1_","_GMRCDA_",",.01,"I")
...I +GMRC8925=$S(+GMRCPARN:+GMRCPARN,1:TIUDA) S GMRCO=GMRCDA
Q GMRCO
;
AUTHDTTM ;
S ACTIEN=$G(ACTIEN,$O(^GMR(123,GMRCDA,40,99999),-1))
I '+ACTIEN D Q
.S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||Author\R\\R\"
.S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||Datetime\R\\R\"
.S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||Comment\R\\R\"
.S NTECNT=4
;
S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||Author\R\\R\"_$$GET1^DIQ(123.02,ACTIEN_","_GMRCDA_",",4)
S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||Datetime\R\\R\"_$$FMTHL7^XLFDT($$GET1^DIQ(123.02,ACTIEN_","_GMRCDA_",",2,"I"))
S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||Comment\R\\R\"
S NTECNT=4
Q
ACK ;
N GMRCMSG,I,X,DONE,MSGID,ERRARY,ERRI
;Get the message
S ERRI=0
F I=1:1 X HLNEXT Q:(HLQUIT'>0) D
. S GMRCMSG(I,1)=HLNODE
. S X=0 F S X=+$O(HLNODE(X)) Q:'X S GMRCMSG(I,(X+1))=HLNODE(X)
S DONE=0
S I=0 F S I=$O(GMRCMSG(I)) Q:'+I D Q:DONE
. I $P($G(GMRCMSG(I,1)),"|",1)="MSA" D Q
. . I $P($G(GMRCMSG(I,1)),"|",2)="AA" S DONE=1 Q
. . S MSGID=$P($G(GMRCMSG(I,1)),"|",3)
. I $P($G(GMRCMSG(I,1)),"|",1)="ERR" D
. . ;Process Error
. . S ERRI=ERRI+1
. . S ERRARY(ERRI,2)=$P($G(GMRCMSG(I,1)),"|",3)
. . I $P($G(GMRCMSG(I,1)),"|",6)'="" D Q
. . . S ERRARY(ERRI,3)=$P($P($G(GMRCMSG(I,1)),"|",6),"^",4)_"^"_$P($P($G(GMRCMSG(I,1)),"|",6),"^",5)
. . S ERRARY(ERRI,3)=$P($G(GMRCMSG(I,1)),"|",4)
I $D(ERRARY) D MESSAGE(MSGID,.ERRARY)
Q
EDIPI(DFN,GMRCP) ;
N EDIPI,ICN,PT,LST,XX,HSRMEDIPI,PIDSEG,PID,YY,LCNT,NUMSEGS,PIDLEN,SEGCNT,PIDLEN1,PATID,NGMRCP,FIELDS,FIELDS1,TMPGMRCP
Q:$G(DFN)'>0
Q:$G(GMRCP(1))=""
S ICN=$$GETICN^MPIF001(DFN),EDIPI=""
Q:$G(ICN)=""
S PT=ICN_"^NI^USVHA^200M"
D TFL^VAFCTFU2(.LST,PT)
;I $P(LST(1),"^")=-1 S PT=DFN_"^PI^USVHA^"_$$KSP^XUPARAM("INST")
;Q:$P(LST(1),"^")=-1
S XX=0 F S XX=$O(LST(XX)) Q:XX'>0 D
.I $P(LST(XX),"^",3)="USDOD" D
..Q:$P(LST(XX),"^",5)="H"
..S EDIPI=$P(LST(XX),"^")
;For the first patch after 203, modify the line below to I $G(EDIPI)="" S GMRCP=1 Q
I $G(EDIPI)="" M NEWGMRCP=GMRCP Q
;N HSRMEDIPI
S HSRMEDIPI=EDIPI_"^^^USDOD&&0363^EDIPI^VA FACILITY&200DOD&L"
K XX
K PID,PIDSEG
S PID="",(NGMRCP,XX)=0 F S XX=$O(GMRCP(XX)) Q:$G(XX)'>0 D
.S NGMRCP=NGMRCP+1
.S PID=PID_$G(GMRCP(XX))
K I S (FIELDS1,FIELDS,NUMSEGS,SEGCNT)=0,LCNT=1
S PIDLEN=$L(PID) F I=1:1:PIDLEN I $E(PID,I)="|" S FIELDS=FIELDS+1
S PATID=HSRMEDIPI_"~"_$P(PID,"|",4)
S:PATID'="" $P(PID,"|",4)=PATID
S PIDLEN1=$L(PID) F I=1:1:PIDLEN1 I $E(PID,I)="|" S FIELDS1=FIELDS1+1
K I F I=1:1:NGMRCP ;K GMRCP(I)
S NUMSEGS=PIDLEN1/240 I $P(NUMSEGS,".",2)>0 S SEGCNT=$P(NUMSEGS,".",1)+1
K I F I=1:1:PIDLEN1 Q:LCNT>SEGCNT S ^TMP($J,"GMRCP",(LCNT))=$E(PID,I,I+240),I=I+240,LCNT=LCNT+1
;S GMRCP=PID
M NEWGMRCP=^TMP($J,"GMRCP")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCCCR1 10856 printed Sep 23, 2025@19:21:15 Page 2
GMRCCCR1 ;COG/PB - Receive HL7 Message for HCP ;3/21/18 09:00
+1 ;;3.0;CONSULT/REQUEST TRACKING;**99,106,112,123,134,146,158,173,203**;JUN 1, 2018;Build 6
+2 ;
+3 ;DBIA# Supported Reference
+4 ;----- --------------------------------
+5 ;10106 HLADDR^HLFNC
+6 ;4648 TFL^VAFCTFU2
+7 ;
+8 ; MJ - 5/24/2018 patch 106 changes to add - GETADD function
+9 ; MJ - 2/28/2019 patch 112 subroutines added or split from GMRCCCRA
+10 ; MJ - 4/02/2019 patch 123 updated to find VistA user from HSRM message and create NAK if invalid
+11 ; MJ - 7/30/2019 patch 134 fix control character issue in TIU notes
+12 ; MJ - 9/20/2019 patch 146 clear space-only address fields
+13 ; PB - 6/22/2021 patch 173 to pull the EDIPI and add it to the PID segment
+14 ;
+15 QUIT
+16 ;
GETADD(INSP) ;
+1 ; INSP contains internal value of insurance plan for this patient (IN1 segment)
+2 NEW ADDLN1,ADDLN2,ADDLN3,ADDCITY,ADDST,ADDZIP,VADD,VCSZ,X
+3 SET ADDLN1=$$GET1^DIQ(36,INSP_",",.111)
+4 SET ADDLN2=$$GET1^DIQ(36,INSP_",",.112)
+5 SET ADDLN3=$$GET1^DIQ(36,INSP_",",.113)
+6 SET ADDCITY=$$GET1^DIQ(36,INSP_",",.114)
+7 ; S:ADDST ADDST=ADDST_"~"_$$GET1^DIQ(36,INSP_",",.115)
SET ADDST=$$GET1^DIQ(36,INSP_",",.115,"I")
+8 SET ADDZIP=$$GET1^DIQ(36,INSP_",",.116)
+9 SET VADD=ADDLN1_"^"_ADDLN2
SET VCSZ=ADDCITY_"^"_ADDST_"^"_ADDZIP
+10 SET X=$$HLADDR^HLFNC(VADD,VCSZ)
+11 ; address type = 'mailing'
if X]""
SET $PIECE(X,"^",7)="M"
+12 QUIT X
+13 ; end patch 106 mod
+14 ;
CLRADD(ADDRESS) ;
+1 ; patch 146 - take any address field that contains only spaces and change to null
+2 NEW I,J,ADD
+3 ;
FOR I=1:1:$LENGTH(ADDRESS,"^")
Begin DoDot:1
+4 ;
SET ADD=$PIECE(ADDRESS,"^",I)
IF $LENGTH(ADD)
Begin DoDot:2
+5 FOR
if $EXTRACT(ADD,1)'=" "
QUIT
SET ADD=$EXTRACT(ADD,2,$LENGTH(ADD))
+6 SET $PIECE(ADDRESS,"^",I)=ADD
End DoDot:2
End DoDot:1
+7 QUIT ADDRESS
+8 ;
MESSAGE(MSGID,ERRARY) ; Send a MailMan Message with the errors
+1 ; moved here for patch 112
+2 NEW MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,I,J
+3 SET DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($PIECE(HL("DTM"),"-",1)))
+4 SET XMSUB="GMRC CCRA Consults to HSRM HL7 Error"
+5 SET MSGTEXT(1)=" "
+6 SET MSGTEXT(2)="Error in transmitting HL7 message to HSRM"
+7 SET MSGTEXT(3)="Date: "_DATE
+8 SET MSGTEXT(4)="Message ID: "_MSGID
+9 SET MSGTEXT(5)="Error(s):"
+10 SET I=0
SET J=5
FOR
SET I=$ORDER(ERRARY(I))
if 'I
QUIT
Begin DoDot:1
+11 SET J=J+1
SET MSGTEXT(J)=" "
+12 SET J=J+1
SET MSGTEXT(J)=" "_$PIECE($GET(ERRARY(I,3)),U)_" - "_$PIECE($GET(ERRARY(I,3)),U,2)
+13 IF $PIECE($GET(ERRARY(I,2)),U,1)'=""
SET J=J+1
SET MSGTEXT(J)=" Segment: "_$PIECE($GET(ERRARY(I,2)),U,1)
+14 IF $PIECE($GET(ERRARY(I,2)),U,2)'=""
SET J=J+1
SET MSGTEXT(J)=" Sequence: "_$PIECE($GET(ERRARY(I,2)),U,2)
+15 IF $PIECE($GET(ERRARY(I,2)),U,3)'=""
SET J=J+1
SET MSGTEXT(J)=" Field: "_$PIECE($GET(ERRARY(I,2)),U,3)
+16 IF $PIECE($GET(ERRARY(I,2)),U,4)'=""
SET J=J+1
SET MSGTEXT(J)=" Fld Rep: "_$PIECE($GET(ERRARY(I,2)),U,4)
+17 IF $PIECE($GET(ERRARY(I,2)),U,5)'=""
SET J=J+1
SET MSGTEXT(J)=" Component: "_$PIECE($GET(ERRARY(I,2)),U,5)
+18 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
+19 SET XMTEXT="MSGTEXT("
+20 SET XMDUZ="GMRC-CCRA->HSRP Transaction Error"
+21 SET XMY("G.GMRC HCP HL7 MESSAGES")=""
+22 DO ^XMD
+23 QUIT
+24 ;
MESSAGE2(MSGID,ABORT,CONID) ; Send a MailMan Message with the errors
+1 NEW MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J,SITE,MSG
+2 SET SITE=$$KSP^XUPARAM("INST")
+3 SET DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($PIECE(HL("DTM"),"-",1)))
+4 SET XMSUB="Consult ID "_CONID_" - GMRC CCRA Scheduling Updates from HSRM - HL7 Error"
+5 SET MSGTEXT(1)=" "
+6 SET MSGTEXT(2)="Error in receiving HL7 message from HSRM"
+7 SET MSGTEXT(3)="Date: "_DATE
+8 SET MSGTEXT(4)="Message ID: "_MSGID
+9 SET MSG="Error(s): "_$PIECE(ABORT,"^",2)_"/VISTA "_SITE_"/Consult ID:"_CONID_". Please manually synchronize the consult"
+10 SET MSG=MSG_" in VistA #"_SITE_" with the information currently available in HSRM."
+11 SET MSGTEXT(5)=MSG
+12 SET XMTEXT="MSGTEXT("
+13 SET XMDUZ="GMRC-CCRA <-HSRM Transaction Error"
+14 ; ** CHECK THIS OUT **
SET XMY("G.GMRC HSRM SIU HL7 MESSAGES")=""
+15 DO ^XMD
+16 QUIT
+17 ;
CCONTROL(GMRCDA) ; patch 112
+1 ; remove control characters from data before building OBR segment
+2 ;
+3 SET YY=0
FOR
SET YY=$ORDER(^GMR(123,GMRCDA,40,YY))
if YY'>0
QUIT
Begin DoDot:1
+4 SET XX=0
FOR
SET XX=$ORDER(^GMR(123,GMRCDA,40,YY,1,XX))
if XX'>0
QUIT
Begin DoDot:2
+5 KILL NODE
+6 ;S TESTSTRING=$C(13)
+7 SET NODE=$GET(^GMR(123,GMRCDA,40,YY,1,XX,0))
+8 ; <cr><lf><lf>
IF $GET(NODE)[$CHAR(13,10,10)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(13,10,10)," ")
+9 ; <cr><lf>
IF $GET(NODE)[$CHAR(13,10)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(13,10)," ")
+10 ; TERM char
IF $GET(NODE)[$CHAR(13)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(13)," ")
+11 ; SOH
IF $GET(NODE)[$CHAR(1)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(1)," ")
+12 ; STX
IF $GET(NODE)[$CHAR(2)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(2)," ")
+13 ; ETX
IF $GET(NODE)[$CHAR(3)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(3)," ")
+14 ; EOT
IF $GET(NODE)[$CHAR(4)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(4)," ")
+15 ; ENQ
IF $GET(NODE)[$CHAR(5)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(5)," ")
+16 ; ACK
IF $GET(NODE)[$CHAR(6)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(6)," ")
+17 ; NAK
IF $GET(NODE)[$CHAR(21)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(21)," ")
+18 ; ETB
IF $GET(NODE)[$CHAR(23)
SET ^GMR(123,GMRCDA,40,YY,1,XX,0)=$TRANSLATE(^GMR(123,GMRCDA,40,YY,1,XX,0),$CHAR(23)," ")
+19 ;I $C(13,10,10)[$G(NODE) W !,XX," ",NODE
+20 ;,TESTSTRING
KILL NODE
End DoDot:2
End DoDot:1
+21 KILL XX,YY
+22 QUIT
+23 ;
ANAK(NAKMSG,USERMAIL,ICN,DFN,CONID,GMRCDT) ; Application Error, send NAK back
+1 NEW PATNAME,EID,EIDS,MSGN,SITE,CONPAT,RES,NAKMSG1
+2 if $GET(NAKMSG)=""
QUIT
+3 if $GET(DFN)'>0
QUIT
+4 if $GET(CONID)=""
QUIT
+5 if $GET(GMRCDT)=""
QUIT
+6 if $GET(^DPT(DFN,0))=""
QUIT
+7 SET CONPAT=$$GET1^DIQ(123,CONID_",",.02,"I")
+8 ;Patient in appt msg not the same as patient in the consult
if $GET(CONPAT)'=DFN
QUIT
+9 SET PATNAME=$PIECE(^DPT(DFN,0),"^")
SET SITE=$$KSP^XUPARAM("INST")
+10 if $GET(ICN)=""
SET ICN=$PIECE(^DPT(DFN,"MPI"),"^",10)
+11 SET EID=$GET(HL("EID"))
+12 SET EIDS=$GET(HL("EIDS"))
+13 SET MSGN=$GET(HL("MID"))
+14 ; S NAKMSG1=NAKMSG_"/VISTA "_SITE_"/Consult ID:"_CONID_". Please manually synchronize the consult"
+15 ; S NAKMSG1=NAKMSG1_" in VistA #"_SITE_" with the information currently available in HSRM."
+16 SET HLA("HLA",1)="MSA|AE|"_$GET(MSGN)_"|"_$GET(USERMAIL)_" "_$GET(NAKMSG)_"|||"_$GET(ICN)_"^"_$GET(PATNAME)_"^"_SITE_"^"_CONID_"^"_GMRCDT
+17 DO GENACK^HLMA1(EID,$GET(HLMTIENS),EIDS,"LM",1,.RES)
+18 QUIT
TIUC(X) ; Check each segment of the TIU notes for HL7 control characters
+1 if $GET(X)=""
QUIT
+2 ; <cr><lf><lf>
IF $GET(X)[$CHAR(13,10,10)
SET X=$TRANSLATE(X,$CHAR(13,10,10),"")
+3 ; <cr><lf>
IF $GET(X)[$CHAR(13,10)
SET X=$TRANSLATE(X,$CHAR(13,10),"")
+4 ; TERM char
IF $GET(X)[$CHAR(13)
SET X=$TRANSLATE(X,$CHAR(13),"")
+5 ; SOH
IF $GET(X)[$CHAR(1)
SET X=$TRANSLATE(X,$CHAR(1),"")
+6 ; STX
IF $GET(X)[$CHAR(2)
SET X=$TRANSLATE(X,$CHAR(2),"")
+7 ; ETX
IF $GET(X)[$CHAR(3)
SET X=$TRANSLATE(X,$CHAR(3),"")
+8 ; EOT
IF $GET(X)[$CHAR(4)
SET X=$TRANSLATE(X,$CHAR(4),"")
+9 ; ENQ
IF $GET(X)[$CHAR(5)
SET X=$TRANSLATE(X,$CHAR(5),"")
+10 ; ACK
IF $GET(X)[$CHAR(6)
SET X=$TRANSLATE(X,$CHAR(6),"")
+11 ; NAK
IF $GET(X)[$CHAR(21)
SET X=$TRANSLATE(X,$CHAR(21),"")
+12 ; ETB
IF $GET(X)[$CHAR(23)
SET X=$TRANSLATE(X,$CHAR(23),"")
+13 ; TAB with space
IF $GET(X)[$CHAR(11)
SET X=$TRANSLATE(X,$CHAR(11)," ")
+14 QUIT X
ADDEND ; moved from ADDEND^GMRCCCRA routine for space ; patch 146 ; MJ
+1 ; returns 0 if value not found
+2 ;
+3 ; modified in patch GMRC*3.0*106 to use ICR 2693
+4 DO EXTRACT^TIULQ(TIUDA)
+5 ;
+6 ; Quit if not an addendum
+7 SET TIUTYP=^TMP("TIULQ",$JOB,+TIUDA,.01,"I")
+8 IF TIUTYP'=81
QUIT 0
+9 ;
+10 SET DFN=^TMP("TIULQ",$JOB,+TIUDA,.02,"I")
+11 IF 'DFN!('$DATA(^DPT(DFN)))
QUIT 0
+12 ;
+13 ; Get parent note IEN, if addendum IEN is passed in:
+14 SET GMRCPARN=^TMP("TIULQ",$JOB,+TIUDA,.06,"I")
+15 ;
+16 ; Quit if not an addendum
+17 ;S TIUTYP=$$GET1^DIQ(8925,TIUDA,.01,"I")
+18 ;I TIUTYP'=81 Q
+19 ;
+20 ;S DFN=$$GET1^DIQ(8925,TIUDA,.02,"I")
+21 ;I 'DFN,'$D(^DPT(DFN)) Q
+22 ;
+23 ; Get parent note IEN, if addendum IEN is passed in:
+24 ;S GMRCPARN=$$GET1^DIQ(8925,TIUDA,.06,"I")
+25 ;
+26 ; end patch 106 mods
+27 ;
+28 SET (GMRCO,GMRCD)=0
+29 FOR
SET GMRCD=$ORDER(^GMR(123,"AD",DFN,GMRCD))
if 'GMRCD!(GMRCO)
QUIT
Begin DoDot:1
+30 SET GMRCDA=0
+31 FOR
SET GMRCDA=$ORDER(^GMR(123,"AD",DFN,GMRCD,GMRCDA))
if 'GMRCDA!(GMRCO)
QUIT
Begin DoDot:2
+32 SET GMRCD1=0
+33 FOR
SET GMRCD1=$ORDER(^GMR(123,GMRCDA,50,GMRCD1))
if 'GMRCD1!(GMRCO)
QUIT
Begin DoDot:3
+34 SET GMRC8925=$$GET1^DIQ(123.03,GMRCD1_","_GMRCDA_",",.01,"I")
+35 IF +GMRC8925=$SELECT(+GMRCPARN:+GMRCPARN,1:TIUDA)
SET GMRCO=GMRCDA
End DoDot:3
End DoDot:2
End DoDot:1
+36 QUIT GMRCO
+37 ;
AUTHDTTM ;
+1 SET ACTIEN=$GET(ACTIEN,$ORDER(^GMR(123,GMRCDA,40,99999),-1))
+2 IF '+ACTIEN
Begin DoDot:1
+3 SET ZCNT=ZCNT+1
SET GMRCM(ZCNT)="NTE|"_NTECNT_"||Author\R\\R\"
+4 SET ZCNT=ZCNT+1
SET NTECNT=NTECNT+1
SET GMRCM(ZCNT)="NTE|"_NTECNT_"||Datetime\R\\R\"
+5 SET ZCNT=ZCNT+1
SET NTECNT=NTECNT+1
SET GMRCM(ZCNT)="NTE|"_NTECNT_"||Comment\R\\R\"
+6 SET NTECNT=4
End DoDot:1
QUIT
+7 ;
+8 SET ZCNT=ZCNT+1
SET GMRCM(ZCNT)="NTE|"_NTECNT_"||Author\R\\R\"_$$GET1^DIQ(123.02,ACTIEN_","_GMRCDA_",",4)
+9 SET ZCNT=ZCNT+1
SET NTECNT=NTECNT+1
SET GMRCM(ZCNT)="NTE|"_NTECNT_"||Datetime\R\\R\"_$$FMTHL7^XLFDT($$GET1^DIQ(123.02,ACTIEN_","_GMRCDA_",",2,"I"))
+10 SET ZCNT=ZCNT+1
SET NTECNT=NTECNT+1
SET GMRCM(ZCNT)="NTE|"_NTECNT_"||Comment\R\\R\"
+11 SET NTECNT=4
+12 QUIT
ACK ;
+1 NEW GMRCMSG,I,X,DONE,MSGID,ERRARY,ERRI
+2 ;Get the message
+3 SET ERRI=0
+4 FOR I=1:1
XECUTE HLNEXT
if (HLQUIT'>0)
QUIT
Begin DoDot:1
+5 SET GMRCMSG(I,1)=HLNODE
+6 SET X=0
FOR
SET X=+$ORDER(HLNODE(X))
if 'X
QUIT
SET GMRCMSG(I,(X+1))=HLNODE(X)
End DoDot:1
+7 SET DONE=0
+8 SET I=0
FOR
SET I=$ORDER(GMRCMSG(I))
if '+I
QUIT
Begin DoDot:1
+9 IF $PIECE($GET(GMRCMSG(I,1)),"|",1)="MSA"
Begin DoDot:2
+10 IF $PIECE($GET(GMRCMSG(I,1)),"|",2)="AA"
SET DONE=1
QUIT
+11 SET MSGID=$PIECE($GET(GMRCMSG(I,1)),"|",3)
End DoDot:2
QUIT
+12 IF $PIECE($GET(GMRCMSG(I,1)),"|",1)="ERR"
Begin DoDot:2
+13 ;Process Error
+14 SET ERRI=ERRI+1
+15 SET ERRARY(ERRI,2)=$PIECE($GET(GMRCMSG(I,1)),"|",3)
+16 IF $PIECE($GET(GMRCMSG(I,1)),"|",6)'=""
Begin DoDot:3
+17 SET ERRARY(ERRI,3)=$PIECE($PIECE($GET(GMRCMSG(I,1)),"|",6),"^",4)_"^"_$PIECE($PIECE($GET(GMRCMSG(I,1)),"|",6),"^",5)
End DoDot:3
QUIT
+18 SET ERRARY(ERRI,3)=$PIECE($GET(GMRCMSG(I,1)),"|",4)
End DoDot:2
End DoDot:1
if DONE
QUIT
+19 IF $DATA(ERRARY)
DO MESSAGE(MSGID,.ERRARY)
+20 QUIT
EDIPI(DFN,GMRCP) ;
+1 NEW EDIPI,ICN,PT,LST,XX,HSRMEDIPI,PIDSEG,PID,YY,LCNT,NUMSEGS,PIDLEN,SEGCNT,PIDLEN1,PATID,NGMRCP,FIELDS,FIELDS1,TMPGMRCP
+2 if $GET(DFN)'>0
QUIT
+3 if $GET(GMRCP(1))=""
QUIT
+4 SET ICN=$$GETICN^MPIF001(DFN)
SET EDIPI=""
+5 if $GET(ICN)=""
QUIT
+6 SET PT=ICN_"^NI^USVHA^200M"
+7 DO TFL^VAFCTFU2(.LST,PT)
+8 ;I $P(LST(1),"^")=-1 S PT=DFN_"^PI^USVHA^"_$$KSP^XUPARAM("INST")
+9 ;Q:$P(LST(1),"^")=-1
+10 SET XX=0
FOR
SET XX=$ORDER(LST(XX))
if XX'>0
QUIT
Begin DoDot:1
+11 IF $PIECE(LST(XX),"^",3)="USDOD"
Begin DoDot:2
+12 if $PIECE(LST(XX),"^",5)="H"
QUIT
+13 SET EDIPI=$PIECE(LST(XX),"^")
End DoDot:2
End DoDot:1
+14 ;For the first patch after 203, modify the line below to I $G(EDIPI)="" S GMRCP=1 Q
+15 IF $GET(EDIPI)=""
MERGE NEWGMRCP=GMRCP
QUIT
+16 ;N HSRMEDIPI
+17 SET HSRMEDIPI=EDIPI_"^^^USDOD&&0363^EDIPI^VA FACILITY&200DOD&L"
+18 KILL XX
+19 KILL PID,PIDSEG
+20 SET PID=""
SET (NGMRCP,XX)=0
FOR
SET XX=$ORDER(GMRCP(XX))
if $GET(XX)'>0
QUIT
Begin DoDot:1
+21 SET NGMRCP=NGMRCP+1
+22 SET PID=PID_$GET(GMRCP(XX))
End DoDot:1
+23 KILL I
SET (FIELDS1,FIELDS,NUMSEGS,SEGCNT)=0
SET LCNT=1
+24 SET PIDLEN=$LENGTH(PID)
FOR I=1:1:PIDLEN
IF $EXTRACT(PID,I)="|"
SET FIELDS=FIELDS+1
+25 SET PATID=HSRMEDIPI_"~"_$PIECE(PID,"|",4)
+26 if PATID'=""
SET $PIECE(PID,"|",4)=PATID
+27 SET PIDLEN1=$LENGTH(PID)
FOR I=1:1:PIDLEN1
IF $EXTRACT(PID,I)="|"
SET FIELDS1=FIELDS1+1
+28 ;K GMRCP(I)
KILL I
FOR I=1:1:NGMRCP
+29 SET NUMSEGS=PIDLEN1/240
IF $PIECE(NUMSEGS,".",2)>0
SET SEGCNT=$PIECE(NUMSEGS,".",1)+1
+30 KILL I
FOR I=1:1:PIDLEN1
if LCNT>SEGCNT
QUIT
SET ^TMP($JOB,"GMRCP",(LCNT))=$EXTRACT(PID,I,I+240)
SET I=I+240
SET LCNT=LCNT+1
+31 ;S GMRCP=PID
+32 MERGE NEWGMRCP=^TMP($JOB,"GMRCP")
+33 QUIT
