- 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 Feb 18, 2025@23:11:38 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