- GMRCHL7H ;DSS/KC - Receive HL7 Message for HCP ;Jun 13, 2018@09:30
- ;;3.0;CONSULT/REQUEST TRACKING;**75,85,96,88**;DEC 27, 1997;Build 153
- ;
- ;DBIA# Supported Reference
- ;----- --------------------------------
- ;2051 FIND^DIC
- ;2056 GET1^DIQ
- ;2161 INIT^HLFNC2
- ;2164 GENERATE^HLMA
- ;2541 KSP^XUPARAM
- ;2944 TGET^TIUSRVR1
- ;3267 SSN^DPTLK1
- ;3630 BLDPID^VAFCQRY
- ;4069 ^HL(772
- ;4966 ^HLMA
- ;5807 GETLINK^TIUSRVT1
- ;10103 FMTE^XLFDT, FMTHL7^XLFDT
- ;10104 UP^XLFSTR
- ;10106 FMDATE^HLFNC
- ;;Patch 85 fix for CA SDM ticket R6063960FY16
- ;;Patch 88 add consult no. and FSC support to MESSAGE
- ;
- EN(MSG) ;Entry point to routine from GMRC CONSULTS TO HCP protocol attached or GMRC EVSEND OR
- ;MSG = local array which contains the HL7 segments
- N I,QUIT,MSGTYP,DFN,ORC,GMRCDA,FS,MSGTYP2,MSGTYP3,ACTIEN,FROMSVC,OK,OKFROM,STATUS
- N UCID ;ABV/SCR 12/14/2017 *96*
- S (I,QUIT)=0,I=$O(MSG(I)) Q:'I S MSG=MSG(I) Q:$E(MSG,1,3)'="MSH" D Q:QUIT
- .S FS=$E(MSG,4) I $P(MSG,FS,3)'="CONSULTS" S QUIT=1 Q
- .S MSGTYP=$P(MSG,FS,9) I ",ORR,ORM,"'[","_MSGTYP_"," S QUIT=1 Q ;ORR is new consult, ORM are updates
- .Q
- F S I=$O(MSG(I)) Q:'I!QUIT S MSG=MSG(I) D
- .I $E(MSG,1,3)="PID" S DFN=$P(MSG,FS,4) I 'DFN!('$D(^DPT(DFN))) S QUIT=1 Q
- .I $E(MSG,1,3)="ORC" S ORC=MSG S GMRCDA=+$P(ORC,FS,4),MSGTYP2=$P(ORC,FS,2),MSGTYP3=$P(ORC,FS,6) D
- ..I MSGTYP3="IP" S ACTIEN=$O(^GMR(123,GMRCDA,40,99999),-1) D
- ...I ACTIEN S FROMSVC=$P($G(^GMR(123,GMRCDA,40,ACTIEN,0)),U,6) I FROMSVC S OKFROM=$$FEE(FROMSVC)
- ..S OK=$$FEE($$GET1^DIQ(123,GMRCDA,1,"I"))
- ..I '$G(OKFROM)&'$G(OK) S QUIT=1 ;not a Fee service or not forwarded from a fee service
- ..Q
- .Q
- Q:QUIT
- I MSGTYP="ORR" S MSGTYP3="NW"
- S STATUS=$$STATUS(MSGTYP2,MSGTYP3) I STATUS="UNKNOWN" Q ;don't process anything we haven't coded for
- ;done verifying this consult needs to go to HCP, start building HL7 message
- N SNAME,GMRCHL,ZERR,ZCNT,ECH,DATA,GDATA,URG,TYP,RES,EFFDT,PDUZ,PN,ADDR,PH,GMRCP,SENS,DX,DXCODE
- S SNAME="GMRC HCP REF-"_$S(MSGTYP2="DR":"I14",MSGTYP="ORR":"I12",MSGTYP2="OC":"I14",MSGTYP2="OD":"I14",1:"I13")_" SERVER"
- S GMRCHL("EID")=$$FIND1^DIC(101,,"X",SNAME)
- Q:'GMRCHL("EID") D INIT^HLFNC2(GMRCHL("EID"),.GMRCHL)
- S ZERR="",ZCNT=0,ECH=$E(GMRCHL("ECH")) ;component separator
- ;start creating the segments.
- S DATA=$NA(^TMP("GMRCHL7H",$J)) K @DATA D GETS^DIQ(123,GMRCDA,"*","IE",DATA)
- S GDATA=$NA(^TMP("GMRCHL7H",$J,123,+GMRCDA_",")) ;File 123 data
- ;RF1 segment
- K GMRCM
- S URG=$G(@GDATA@(5,"E")) ;I URG]"" S URG=$S(URG["ROUTINE":"R",URG["STAT":"S",1:"A")
- S URG=$P(URG,"- ",2)
- S TYP=$G(@GDATA@(1,"I"))_ECH_$G(@GDATA@(1,"E")) D GETLINK^TIUSRVT1(.RES,+TYP_";GMR(123.5,")
- S TYP=TYP_ECH_ECH_$P($G(RES),U)_ECH_$P($G(RES),U,4)
- S EFFDT=$$FMTHL7^XLFDT($G(@GDATA@(.01,"I")))
- S ZCNT=ZCNT+1,GMRCM(ZCNT)="RF1|"_STATUS_"|"_URG_"|"_TYP_"||"_$G(@GDATA@(14,"I"))_"|"_GMRCDA_"|"_EFFDT_"||||"
- ;**ABV/PIJ 10/10/2017 *96*- update RF1 segment
- S UCID=$$GET1^DIQ(123,GMRCDA,80)
- S:$G(UCID)'="" GMRCM(ZCNT)="RF1|"_STATUS_"|"_URG_"|"_TYP_"||"_$G(@GDATA@(14,"I"))_"|"_UCID_"|"_EFFDT_"||||"
- S:$G(UCID)="" ^XTMP("GMRCHL7H","UCID IS EMPTY",GMRCDA)=GMRCDA ;TEMP ERROR HANDLER
- ;*96*
- ;PRD segment
- S PDUZ=$G(@GDATA@(10,"I")),PN=$G(@GDATA@(10,"E")),PN=$$HLNAME^XLFNAME(PN,"S",ECH),$P(PN,ECH,9)=PDUZ
- S ADDR=$$ADDR^GMRCHL7P(PDUZ,.GMRCHL),PH=$$PH^GMRCHL7P(PDUZ,.GMRCHL)
- S ZCNT=ZCNT+1,GMRCM(ZCNT)="PRD|RP|"_PN_"|"_$G(ADDR)_"||"_$G(PH)_"|"
- ;PID segment May be multiple nodes in the return array - make nodes 2-n sub nodes
- D BLDPID^VAFCQRY(DFN,1,"ALL",.GMRCP,.GMRCHL,ZERR)
- S I=0 F S I=$O(GMRCP(I)) Q:'I D
- .I I=1 S ZCNT=ZCNT+1,GMRCM(ZCNT)=$TR(GMRCP(I),"""") Q
- .S GMRCM(ZCNT,I)=$TR(GMRCP(I),"""")
- K GMRCP
- ;DG1 segment ;Patch 85 modified
- S DX=$G(@GDATA@(30,"E"))
- S DXCODE=$G(@GDATA@(30.1,"E"))
- I $G(DX)["(" S DX=$P(DX,"(")
- S ZCNT=ZCNT+1,GMRCM(ZCNT)="DG1|1||"_$G(DXCODE)_ECH_$G(DX)_"|||W"
- ;OBR segment
- S ZCNT=ZCNT+1,GMRCM(ZCNT)="OBR|1|"_$P(ORC,FS,3)_"|"_$P(ORC,FS,4)_"|ZZ||"_$$FMTHL7^XLFDT($G(@GDATA@(17,"I")))
- ;PV1 segment
- D IN5^VADPT ;VAIP(18)=Attending Physician, VAIP(13,5)=Primary Physician for admission
- S ZCNT=ZCNT+1,GMRCM(ZCNT)="PV1|1|"_$S(VAIP(13):"I",1:"O")_"|||||"_VAIP(18)_"|"
- I VAIP(5) S $P(GMRCM(ZCNT),"|",4)=VAIP(5) ;location for last movement event
- S SENS=$$SSN^DPTLK1(DFN) I SENS["*SENSITIVE*" S $P(GMRCM(ZCNT),"|",17)="R" ;sensitive patient
- S $P(GMRCM(ZCNT),"|",18)=VAIP(13,5)
- D KVA^VADPT
- ;NTE segment
- D NTE(.GMRCHL)
- K ^TMP("GMRCHL7H",$J)
- ;
- ; When done, re-serve the (modified) referral message to HCP
- N HL,HLA,GMRCRES,GMRCHLP
- M HL=GMRCHL,HLA("HLS")=GMRCM
- M GMRCHL=^XTMP("GMRCHL7H","MESSAGE")
- D GENERATE^HLMA(GMRCHL("EID"),"LM",1,.GMRCRES,"",.GMRCHLP)
- Q
- NTE(HL) ;Find Reason for Request for New or Resubmit entries, Find TIU for complete, find Activity Comment for others
- N NTECNT,X S NTECNT=1
- I (MSGTYP="ORR"&(MSGTYP2'="DR"))!((MSGTYP3="IP")&'$G(OKFROM)) D Q
- .D AUTHDTTM
- .S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"|P|Reason for Request"
- .S I=0 F S I=$O(@GDATA@(20,I)) Q:'I S X=@GDATA@(20,I) Q:X["^TMP" D
- ..S X=$$TRIM^XLFSTR(X) I $L(X)=0 Q
- ..I X=$C(9,9) Q
- ..D HL7TXT^GMRCHL7P(.X,.HL,"\")
- ..S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- ..Q
- .Q
- ; Build NTE for CM^ADDENDED
- I MSGTYP2="XX",MSGTYP3="CM" D Q
- .N GMRCN,GMRCTXT,GMRCCMP,GMRCASTR
- .D AUTHDTTM
- .S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"|P|Progress Note"
- .S GMRCN=$P($G(^GMR(123,GMRCDA,50,1,0)),U) I GMRCN'["TIU(8925," Q
- .D TGET^TIUSRVR1(.GMRCTXT,$S(+$G(GMRCPARN):+GMRCPARN,+$G(TIUDA):+TIUDA,1:+GMRCN),"VIEW")
- .;
- .S GMRCCMP=$$DATE($P($G(^TIU(8925,+TIUDA,13)),U),"MM/DD/CCYY")_" ADDENDUM"_" STATUS: "_$$GET1^DIQ(8925,+TIUDA_",",.05)
- .S (I,GMRCASTR)=0
- .F S I=$O(@GMRCTXT@(I)) Q:I="" S X=@GMRCTXT@(I) D
- ..I X=GMRCCMP S GMRCASTR=I
- .;
- .I GMRCASTR D
- ..S I=GMRCASTR-1
- ..F S I=$O(@GMRCTXT@(I)) Q:I="" S X=@GMRCTXT@(I) D
- ...S X=$$TRIM^XLFSTR(X) I $L(X)=0 Q
- ...D HL7TXT^GMRCHL7P(.X,.HL,"\")
- ...S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- .K ^TMP("TIUVIEW",$J) ;clean up results of TIUSRVR1 call
- ;
- I MSGTYP3="CM" D Q
- .N GMRCN,GMRCTXT
- .D AUTHDTTM
- .S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"|P|Progress Note"
- .S GMRCN=$P($G(^GMR(123,GMRCDA,50,1,0)),U) I GMRCN'["TIU(8925," Q
- .D TGET^TIUSRVR1(.GMRCTXT,$S(+$G(TIUDA):+TIUDA,1:+GMRCN),"VIEW") S I=0
- .F S I=$O(@GMRCTXT@(I)) Q:I="" S X=@GMRCTXT@(I) D
- ..S X=$$TRIM^XLFSTR(X) I $L(X)=0 Q
- ..D HL7TXT^GMRCHL7P(.X,.HL,"\")
- ..S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- ..Q
- .K ^TMP("TIUVIEW",$J) ;clean up results of TIUSRVR1 call
- .Q
- I (MSGTYP2="DR") D Q
- .N ORIEN,CMT
- .D AUTHDTTM
- .S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"|L|Activity Comment"
- .S ORIEN=$G(@GDATA@(.03,"I")) I 'ORIEN Q
- .S CMT=$$GET1^DIQ(100,ORIEN_",",64),CMT=$$TRIM^XLFSTR(CMT)
- .D HL7TXT^GMRCHL7P(.CMT,.HL,"\")
- .S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|2||"_CMT
- .Q
- N ACT,ACTD,ACTIEN,Q
- S Q=0,ACTIEN=9999 F S ACTIEN=$O(^GMR(123,GMRCDA,40,ACTIEN),-1) Q:'ACTIEN!Q S X=$G(^GMR(123,GMRCDA,40,ACTIEN,0)) D
- .S ACT=$P(X,U,2),ACTD=$P($P($G(^GMR(123.1,+ACT,0)),U)," ")
- .I $P($P(STATUS,ECH,2)," ")'=ACTD Q
- .I +$O(^GMR(123,GMRCDA,40,ACTIEN,1,0)) D AUTHDTTM
- .S I=0 F S I=$O(^GMR(123,GMRCDA,40,ACTIEN,1,I)) Q:'I S X=$G(^GMR(123,GMRCDA,40,ACTIEN,1,I,0)) D
- ..I 'Q S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"|L|Activity Comment",Q=1
- ..S X=$$TRIM^XLFSTR(X) I $L(X)=0 Q
- ..D HL7TXT^GMRCHL7P(.X,.HL,"\")
- ..S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- ..Q
- .Q
- Q
- AUTHDTTM ; Add Author and Date/Time to NTE
- 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
- STATUS(T1,T2) ;get status for event
- ;also add IP^COMMENT when those events are captured
- I T2="DC"!(T1="DR") Q "DC^DISCONTINUED"
- I T2="NW" Q "NW^CPRS RELEASED ORDER"
- I T1="SC"&(T2="SC") Q "SC^RECEIVED"
- I T1="SC"&(T2="ZC") Q "SC^SCHEDULED"
- I T1="XX"&(T2="XX") Q "IP^ADDED COMMENT"
- I T2="CA" Q "CA^CANCELLED"
- I T2="CM" D
- .I '+$G(GMRCPARN),'+$G(TIUDA) S GMRCPARN=$P($G(^GMR(123,GMRCDA,50,1,0)),U)
- .S $P(ORC,FS,4)=$S(+$G(GMRCPARN):+GMRCPARN_";TIU^TIU",+$G(TIUDA):+TIUDA_";TIU^TIU",1:$P(ORC,FS,4))
- I T1="XX"&(T2="CM") Q "CM^ADDENDED"
- I T2="CM" Q "CM^COMPLETE"
- I T1="XX"&(T2="IP")&$G(OKFROM) Q "XX^FORWARDED"
- I T1="XX"&(T2="IP") Q "IP^RESUBMITTED"
- Q "UNKNOWN"
- FEE(FEESVC) ;send only if name contains HCPS
- I $G(FEESVC)="" Q 0
- N VAL
- S VAL=0
- I $$UP^XLFSTR($$GET1^DIQ(123.5,FEESVC,.01,"E"))["HCPS" S VAL=1
- Q VAL
- ;create a fake event for HCP since there is no HL7 event passed to GMRC EVSEND OR
- I '$G(GMRCDA) Q
- N DFN S DFN=$$GET1^DIQ(123,GMRCDA,.02,"I") I 'DFN,'$D(^DPT(DFN)) Q
- N T S T(1)="MSH|^~\&|CONSULTS||||||ORM"
- S T(2)="PID|||"_DFN
- S T(4)="ORC|XX|"_$$GET1^DIQ(123,GMRCDA,.03,"I")_";"_$$OITEM($$GET1^DIQ(123,GMRCDA,.03,"I"))_"^OR|"_GMRCDA_";GMRC^GMRC||XX|"
- D EN(.T)
- Q
- ADDEND(TIUDA) ;send addendums on Non VA Care consults to HCP
- ;create a fake event for HCP since there is no HL7 event passed to GMRC EVSEND OR
- I '$G(TIUDA) Q
- Q:'$D(^TIU(8925,+TIUDA,0))
- N TIUTYP,DFN,GMRCPARN,GMRCO,GMRCD,GMRCDA,GMRCD1,GMRC8925,T
- ;
- ; 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")
- ;
- 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
- ;
- S T(1)="MSH|^~\&|CONSULTS||||||ORM"
- S T(2)="PID|||"_DFN
- S T(4)="ORC|XX|"_$$GET1^DIQ(123,GMRCO,.03,"I")_";"_$$OITEM($$GET1^DIQ(123,GMRCO,.03,"I"))_"^OR|"_GMRCO_";GMRC^GMRC||CM|"
- I $$FEE($$GET1^DIQ(123,GMRCO,1,"I")) D EN(.T)
- Q
- TIME(X,FMT) ; Copied from $$TIME^TIULS
- ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
- N HR,MIN,SEC,GMRCI
- I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="HR:MIN"
- S X=$P(X,".",2),HR=$E(X,1,2)_$E("00",0,2-$L($E(X,1,2))),MIN=$E(X,3,4)_$E("00",0,2-$L($E(X,3,4))),SEC=$E(X,5,6)_$E("00",0,2-$L($E(X,5,6)))
- F GMRCI="HR","MIN","SEC" S:FMT[GMRCI FMT=$P(FMT,GMRCI)_@GMRCI_$P(FMT,GMRCI,2)
- Q FMT
- DATE(X,FMT) ; Copied from $$DATE^TIULS
- ; Call with X=2910419.01 and FMT=Return Format of date ("MM/DD")
- N AMTH,MM,CC,DD,YY,GMRCI,GMRCTMP
- I +X'>0 S $P(GMRCTMP," ",$L($G(FMT))+1)="",FMT=GMRCTMP G QDATE
- I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="MM/DD/YY"
- S MM=$E(X,4,5),DD=$E(X,6,7),YY=$E(X,2,3),CC=17+$E(X)
- S:FMT["AMTH" AMTH=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+MM)
- F GMRCI="AMTH","MM","DD","CC","YY" S:FMT[GMRCI FMT=$P(FMT,GMRCI)_@GMRCI_$P(FMT,GMRCI,2)
- I FMT["HR" S FMT=$$TIME(X,FMT)
- QDATE Q FMT
- OITEM(GMRCORDN) ; Orderable Item
- N RETVAL,GMRCOITM
- S RETVAL=1
- S GMRCOITM=+$O(^OR(100,GMRCORDN,.1,0))
- I GMRCOITM D
- .S RETVAL=+$G(^OR(100,GMRCORDN,.1,GMRCOITM,0))
- .I 'RETVAL S RETVAL=1
- Q RETVAL
- ACK ; Process ACK HL7 messages
- 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
- 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,I,FSCGRP,GMRCSTA,GMRCSTNA,GMRCNO,GMRCTEXT
- S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1)))
- S FSCGRP=$$GET^XPAR("SYS","GMRC FSC HCP SUPPORT EMAIL",1)
- S XMSUB="GMRC Consults to HCP HL7 Error"
- S (GMRCSTA,GMRCSTNA)="",GMRCSTA=$$KSP^XUPARAM("INST")
- I +$G(GMRCSTA)>0 D F4^XUAF4(GMRCSTA,.GMRCSTNA)
- S GMRCTEXT=$S($G(GMRCSTNA)>0:GMRCSTNA("NAME")_" ("_GMRCSTA_")",1:"Not Found")
- S GMRCNO=$$HLTEXT(MSGID)
- S MSGTEXT(1)=" "
- S MSGTEXT(2)="Error in transmitting HL7 message to HCP"
- S MSGTEXT(3)="Date: "_DATE
- S MSGTEXT(4)="Message ID: "_MSGID
- S MSGTEXT(5)="Facility: "_GMRCTEXT
- S MSGTEXT(6)="Consult No.: "_$S(+$G(GMRCNO)>0:GMRCNO,1:"Not Found")
- S MSGTEXT(7)="Error(s):"
- S I=0,J=7 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->HCP Transaction Error"
- S XMY("G.GMRC HCP HL7 MESSAGES")=""
- S:$G(FSCGRP)'="" XMY(FSCGRP)=""
- D ^XMD
- Q
- HLTEXT(MSGID) ;get hl7 message text; find obr and get consult record number
- N GMRCWPTX,GMRCMSID,GMRCOBR,GMRCIFN,I,GMRC773,GMRC772,GMRCNDX,GMRCFLG,GMRCOUT,GMRCERR,IDX
- S GMRCIFN=0,GMRCNDX="C",GMRCFLG="I",IDX=""
- D FIND^DIC(773,"","@;.01I;IX","X",MSGID,"*","C","","","GMRCOUT","GMRCERR")
- I $D(GMRCERR)>0 Q GMRCIFN
- I +GMRCOUT("DILIST",0)'>0 Q GMRCIFN
- S IDX=$O(GMRCOUT("DILIST",2,""))
- S:+IDX>0 GMRC773=GMRCOUT("DILIST",2,IDX)
- I +$G(GMRC773)'>0 Q GMRCIFN
- S GMRC772=$$GET1^DIQ(773,GMRC773_",",.01,GMRCFLG)
- I +$G(GMRC772)'>0 Q GMRCIFN
- S GMRCMSID=$$GET1^DIQ(772,GMRC772_",",200,"","GMRCWPTX")
- S I=0
- F S I=I+1 Q:'$D(GMRCWPTX(I)) D
- .Q:GMRCWPTX(I)'["OBR"
- .S GMRCOBR=GMRCWPTX(I)
- .S:$P(GMRCOBR,"|",4)["GMRC" GMRCIFN=$P(GMRCOBR,"|",4),GMRCIFN=$P(GMRCIFN,";")
- Q GMRCIFN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCHL7H 15192 printed Feb 18, 2025@23:12:12 Page 2
- GMRCHL7H ;DSS/KC - Receive HL7 Message for HCP ;Jun 13, 2018@09:30
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**75,85,96,88**;DEC 27, 1997;Build 153
- +2 ;
- +3 ;DBIA# Supported Reference
- +4 ;----- --------------------------------
- +5 ;2051 FIND^DIC
- +6 ;2056 GET1^DIQ
- +7 ;2161 INIT^HLFNC2
- +8 ;2164 GENERATE^HLMA
- +9 ;2541 KSP^XUPARAM
- +10 ;2944 TGET^TIUSRVR1
- +11 ;3267 SSN^DPTLK1
- +12 ;3630 BLDPID^VAFCQRY
- +13 ;4069 ^HL(772
- +14 ;4966 ^HLMA
- +15 ;5807 GETLINK^TIUSRVT1
- +16 ;10103 FMTE^XLFDT, FMTHL7^XLFDT
- +17 ;10104 UP^XLFSTR
- +18 ;10106 FMDATE^HLFNC
- +19 ;;Patch 85 fix for CA SDM ticket R6063960FY16
- +20 ;;Patch 88 add consult no. and FSC support to MESSAGE
- +21 ;
- EN(MSG) ;Entry point to routine from GMRC CONSULTS TO HCP protocol attached or GMRC EVSEND OR
- +1 ;MSG = local array which contains the HL7 segments
- +2 NEW I,QUIT,MSGTYP,DFN,ORC,GMRCDA,FS,MSGTYP2,MSGTYP3,ACTIEN,FROMSVC,OK,OKFROM,STATUS
- +3 ;ABV/SCR 12/14/2017 *96*
- NEW UCID
- +4 SET (I,QUIT)=0
- SET I=$ORDER(MSG(I))
- if 'I
- QUIT
- SET MSG=MSG(I)
- if $EXTRACT(MSG,1,3)'="MSH"
- QUIT
- Begin DoDot:1
- +5 SET FS=$EXTRACT(MSG,4)
- IF $PIECE(MSG,FS,3)'="CONSULTS"
- SET QUIT=1
- QUIT
- +6 ;ORR is new consult, ORM are updates
- SET MSGTYP=$PIECE(MSG,FS,9)
- IF ",ORR,ORM,"'[","_MSGTYP_","
- SET QUIT=1
- QUIT
- +7 QUIT
- End DoDot:1
- if QUIT
- QUIT
- +8 FOR
- SET I=$ORDER(MSG(I))
- if 'I!QUIT
- QUIT
- SET MSG=MSG(I)
- Begin DoDot:1
- +9 IF $EXTRACT(MSG,1,3)="PID"
- SET DFN=$PIECE(MSG,FS,4)
- IF 'DFN!('$DATA(^DPT(DFN)))
- SET QUIT=1
- QUIT
- +10 IF $EXTRACT(MSG,1,3)="ORC"
- SET ORC=MSG
- SET GMRCDA=+$PIECE(ORC,FS,4)
- SET MSGTYP2=$PIECE(ORC,FS,2)
- SET MSGTYP3=$PIECE(ORC,FS,6)
- Begin DoDot:2
- +11 IF MSGTYP3="IP"
- SET ACTIEN=$ORDER(^GMR(123,GMRCDA,40,99999),-1)
- Begin DoDot:3
- +12 IF ACTIEN
- SET FROMSVC=$PIECE($GET(^GMR(123,GMRCDA,40,ACTIEN,0)),U,6)
- IF FROMSVC
- SET OKFROM=$$FEE(FROMSVC)
- End DoDot:3
- +13 SET OK=$$FEE($$GET1^DIQ(123,GMRCDA,1,"I"))
- +14 ;not a Fee service or not forwarded from a fee service
- IF '$GET(OKFROM)&'$GET(OK)
- SET QUIT=1
- +15 QUIT
- End DoDot:2
- +16 QUIT
- End DoDot:1
- +17 if QUIT
- QUIT
- +18 IF MSGTYP="ORR"
- SET MSGTYP3="NW"
- +19 ;don't process anything we haven't coded for
- SET STATUS=$$STATUS(MSGTYP2,MSGTYP3)
- IF STATUS="UNKNOWN"
- QUIT
- +20 ;done verifying this consult needs to go to HCP, start building HL7 message
- +21 NEW SNAME,GMRCHL,ZERR,ZCNT,ECH,DATA,GDATA,URG,TYP,RES,EFFDT,PDUZ,PN,ADDR,PH,GMRCP,SENS,DX,DXCODE
- +22 SET SNAME="GMRC HCP REF-"_$SELECT(MSGTYP2="DR":"I14",MSGTYP="ORR":"I12",MSGTYP2="OC":"I14",MSGTYP2="OD":"I14",1:"I13")_" SERVER"
- +23 SET GMRCHL("EID")=$$FIND1^DIC(101,,"X",SNAME)
- +24 if 'GMRCHL("EID")
- QUIT
- DO INIT^HLFNC2(GMRCHL("EID"),.GMRCHL)
- +25 ;component separator
- SET ZERR=""
- SET ZCNT=0
- SET ECH=$EXTRACT(GMRCHL("ECH"))
- +26 ;start creating the segments.
- +27 SET DATA=$NAME(^TMP("GMRCHL7H",$JOB))
- KILL @DATA
- DO GETS^DIQ(123,GMRCDA,"*","IE",DATA)
- +28 ;File 123 data
- SET GDATA=$NAME(^TMP("GMRCHL7H",$JOB,123,+GMRCDA_","))
- +29 ;RF1 segment
- +30 KILL GMRCM
- +31 ;I URG]"" S URG=$S(URG["ROUTINE":"R",URG["STAT":"S",1:"A")
- SET URG=$GET(@GDATA@(5,"E"))
- +32 SET URG=$PIECE(URG,"- ",2)
- +33 SET TYP=$GET(@GDATA@(1,"I"))_ECH_$GET(@GDATA@(1,"E"))
- DO GETLINK^TIUSRVT1(.RES,+TYP_";GMR(123.5,")
- +34 SET TYP=TYP_ECH_ECH_$PIECE($GET(RES),U)_ECH_$PIECE($GET(RES),U,4)
- +35 SET EFFDT=$$FMTHL7^XLFDT($GET(@GDATA@(.01,"I")))
- +36 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="RF1|"_STATUS_"|"_URG_"|"_TYP_"||"_$GET(@GDATA@(14,"I"))_"|"_GMRCDA_"|"_EFFDT_"||||"
- +37 ;**ABV/PIJ 10/10/2017 *96*- update RF1 segment
- +38 SET UCID=$$GET1^DIQ(123,GMRCDA,80)
- +39 if $GET(UCID)'=""
- SET GMRCM(ZCNT)="RF1|"_STATUS_"|"_URG_"|"_TYP_"||"_$GET(@GDATA@(14,"I"))_"|"_UCID_"|"_EFFDT_"||||"
- +40 ;TEMP ERROR HANDLER
- if $GET(UCID)=""
- SET ^XTMP("GMRCHL7H","UCID IS EMPTY",GMRCDA)=GMRCDA
- +41 ;*96*
- +42 ;PRD segment
- +43 SET PDUZ=$GET(@GDATA@(10,"I"))
- SET PN=$GET(@GDATA@(10,"E"))
- SET PN=$$HLNAME^XLFNAME(PN,"S",ECH)
- SET $PIECE(PN,ECH,9)=PDUZ
- +44 SET ADDR=$$ADDR^GMRCHL7P(PDUZ,.GMRCHL)
- SET PH=$$PH^GMRCHL7P(PDUZ,.GMRCHL)
- +45 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="PRD|RP|"_PN_"|"_$GET(ADDR)_"||"_$GET(PH)_"|"
- +46 ;PID segment May be multiple nodes in the return array - make nodes 2-n sub nodes
- +47 DO BLDPID^VAFCQRY(DFN,1,"ALL",.GMRCP,.GMRCHL,ZERR)
- +48 SET I=0
- FOR
- SET I=$ORDER(GMRCP(I))
- if 'I
- QUIT
- Begin DoDot:1
- +49 IF I=1
- SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)=$TRANSLATE(GMRCP(I),"""")
- QUIT
- +50 SET GMRCM(ZCNT,I)=$TRANSLATE(GMRCP(I),"""")
- End DoDot:1
- +51 KILL GMRCP
- +52 ;DG1 segment ;Patch 85 modified
- +53 SET DX=$GET(@GDATA@(30,"E"))
- +54 SET DXCODE=$GET(@GDATA@(30.1,"E"))
- +55 IF $GET(DX)["("
- SET DX=$PIECE(DX,"(")
- +56 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="DG1|1||"_$GET(DXCODE)_ECH_$GET(DX)_"|||W"
- +57 ;OBR segment
- +58 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="OBR|1|"_$PIECE(ORC,FS,3)_"|"_$PIECE(ORC,FS,4)_"|ZZ||"_$$FMTHL7^XLFDT($GET(@GDATA@(17,"I")))
- +59 ;PV1 segment
- +60 ;VAIP(18)=Attending Physician, VAIP(13,5)=Primary Physician for admission
- DO IN5^VADPT
- +61 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="PV1|1|"_$SELECT(VAIP(13):"I",1:"O")_"|||||"_VAIP(18)_"|"
- +62 ;location for last movement event
- IF VAIP(5)
- SET $PIECE(GMRCM(ZCNT),"|",4)=VAIP(5)
- +63 ;sensitive patient
- SET SENS=$$SSN^DPTLK1(DFN)
- IF SENS["*SENSITIVE*"
- SET $PIECE(GMRCM(ZCNT),"|",17)="R"
- +64 SET $PIECE(GMRCM(ZCNT),"|",18)=VAIP(13,5)
- +65 DO KVA^VADPT
- +66 ;NTE segment
- +67 DO NTE(.GMRCHL)
- +68 KILL ^TMP("GMRCHL7H",$JOB)
- +69 ;
- +70 ; When done, re-serve the (modified) referral message to HCP
- +71 NEW HL,HLA,GMRCRES,GMRCHLP
- +72 MERGE HL=GMRCHL,HLA("HLS")=GMRCM
- +73 MERGE GMRCHL=^XTMP("GMRCHL7H","MESSAGE")
- +74 DO GENERATE^HLMA(GMRCHL("EID"),"LM",1,.GMRCRES,"",.GMRCHLP)
- +75 QUIT
- NTE(HL) ;Find Reason for Request for New or Resubmit entries, Find TIU for complete, find Activity Comment for others
- +1 NEW NTECNT,X
- SET NTECNT=1
- +2 IF (MSGTYP="ORR"&(MSGTYP2'="DR"))!((MSGTYP3="IP")&'$GET(OKFROM))
- Begin DoDot:1
- +3 DO AUTHDTTM
- +4 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|P|Reason for Request"
- +5 SET I=0
- FOR
- SET I=$ORDER(@GDATA@(20,I))
- if 'I
- QUIT
- SET X=@GDATA@(20,I)
- if X["^TMP"
- QUIT
- Begin DoDot:2
- +6 SET X=$$TRIM^XLFSTR(X)
- IF $LENGTH(X)=0
- QUIT
- +7 IF X=$CHAR(9,9)
- QUIT
- +8 DO HL7TXT^GMRCHL7P(.X,.HL,"\")
- +9 SET ZCNT=ZCNT+1
- SET NTECNT=NTECNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- +10 QUIT
- End DoDot:2
- +11 QUIT
- End DoDot:1
- QUIT
- +12 ; Build NTE for CM^ADDENDED
- +13 IF MSGTYP2="XX"
- IF MSGTYP3="CM"
- Begin DoDot:1
- +14 NEW GMRCN,GMRCTXT,GMRCCMP,GMRCASTR
- +15 DO AUTHDTTM
- +16 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|P|Progress Note"
- +17 SET GMRCN=$PIECE($GET(^GMR(123,GMRCDA,50,1,0)),U)
- IF GMRCN'["TIU(8925,"
- QUIT
- +18 DO TGET^TIUSRVR1(.GMRCTXT,$SELECT(+$GET(GMRCPARN):+GMRCPARN,+$GET(TIUDA):+TIUDA,1:+GMRCN),"VIEW")
- +19 ;
- +20 SET GMRCCMP=$$DATE($PIECE($GET(^TIU(8925,+TIUDA,13)),U),"MM/DD/CCYY")_" ADDENDUM"_" STATUS: "_$$GET1^DIQ(8925,+TIUDA_",",.05)
- +21 SET (I,GMRCASTR)=0
- +22 FOR
- SET I=$ORDER(@GMRCTXT@(I))
- if I=""
- QUIT
- SET X=@GMRCTXT@(I)
- Begin DoDot:2
- +23 IF X=GMRCCMP
- SET GMRCASTR=I
- End DoDot:2
- +24 ;
- +25 IF GMRCASTR
- Begin DoDot:2
- +26 SET I=GMRCASTR-1
- +27 FOR
- SET I=$ORDER(@GMRCTXT@(I))
- if I=""
- QUIT
- SET X=@GMRCTXT@(I)
- Begin DoDot:3
- +28 SET X=$$TRIM^XLFSTR(X)
- IF $LENGTH(X)=0
- QUIT
- +29 DO HL7TXT^GMRCHL7P(.X,.HL,"\")
- +30 SET ZCNT=ZCNT+1
- SET NTECNT=NTECNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- End DoDot:3
- End DoDot:2
- +31 ;clean up results of TIUSRVR1 call
- KILL ^TMP("TIUVIEW",$JOB)
- End DoDot:1
- QUIT
- +32 ;
- +33 IF MSGTYP3="CM"
- Begin DoDot:1
- +34 NEW GMRCN,GMRCTXT
- +35 DO AUTHDTTM
- +36 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|P|Progress Note"
- +37 SET GMRCN=$PIECE($GET(^GMR(123,GMRCDA,50,1,0)),U)
- IF GMRCN'["TIU(8925,"
- QUIT
- +38 DO TGET^TIUSRVR1(.GMRCTXT,$SELECT(+$GET(TIUDA):+TIUDA,1:+GMRCN),"VIEW")
- SET I=0
- +39 FOR
- SET I=$ORDER(@GMRCTXT@(I))
- if I=""
- QUIT
- SET X=@GMRCTXT@(I)
- Begin DoDot:2
- +40 SET X=$$TRIM^XLFSTR(X)
- IF $LENGTH(X)=0
- QUIT
- +41 DO HL7TXT^GMRCHL7P(.X,.HL,"\")
- +42 SET ZCNT=ZCNT+1
- SET NTECNT=NTECNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- +43 QUIT
- End DoDot:2
- +44 ;clean up results of TIUSRVR1 call
- KILL ^TMP("TIUVIEW",$JOB)
- +45 QUIT
- End DoDot:1
- QUIT
- +46 IF (MSGTYP2="DR")
- Begin DoDot:1
- +47 NEW ORIEN,CMT
- +48 DO AUTHDTTM
- +49 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|L|Activity Comment"
- +50 SET ORIEN=$GET(@GDATA@(.03,"I"))
- IF 'ORIEN
- QUIT
- +51 SET CMT=$$GET1^DIQ(100,ORIEN_",",64)
- SET CMT=$$TRIM^XLFSTR(CMT)
- +52 DO HL7TXT^GMRCHL7P(.CMT,.HL,"\")
- +53 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|2||"_CMT
- +54 QUIT
- End DoDot:1
- QUIT
- +55 NEW ACT,ACTD,ACTIEN,Q
- +56 SET Q=0
- SET ACTIEN=9999
- FOR
- SET ACTIEN=$ORDER(^GMR(123,GMRCDA,40,ACTIEN),-1)
- if 'ACTIEN!Q
- QUIT
- SET X=$GET(^GMR(123,GMRCDA,40,ACTIEN,0))
- Begin DoDot:1
- +57 SET ACT=$PIECE(X,U,2)
- SET ACTD=$PIECE($PIECE($GET(^GMR(123.1,+ACT,0)),U)," ")
- +58 IF $PIECE($PIECE(STATUS,ECH,2)," ")'=ACTD
- QUIT
- +59 IF +$ORDER(^GMR(123,GMRCDA,40,ACTIEN,1,0))
- DO AUTHDTTM
- +60 SET I=0
- FOR
- SET I=$ORDER(^GMR(123,GMRCDA,40,ACTIEN,1,I))
- if 'I
- QUIT
- SET X=$GET(^GMR(123,GMRCDA,40,ACTIEN,1,I,0))
- Begin DoDot:2
- +61 IF 'Q
- SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|L|Activity Comment"
- SET Q=1
- +62 SET X=$$TRIM^XLFSTR(X)
- IF $LENGTH(X)=0
- QUIT
- +63 DO HL7TXT^GMRCHL7P(.X,.HL,"\")
- +64 SET ZCNT=ZCNT+1
- SET NTECNT=NTECNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- +65 QUIT
- End DoDot:2
- +66 QUIT
- End DoDot:1
- +67 QUIT
- AUTHDTTM ; Add Author and Date/Time to NTE
- +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
- STATUS(T1,T2) ;get status for event
- +1 ;also add IP^COMMENT when those events are captured
- +2 IF T2="DC"!(T1="DR")
- QUIT "DC^DISCONTINUED"
- +3 IF T2="NW"
- QUIT "NW^CPRS RELEASED ORDER"
- +4 IF T1="SC"&(T2="SC")
- QUIT "SC^RECEIVED"
- +5 IF T1="SC"&(T2="ZC")
- QUIT "SC^SCHEDULED"
- +6 IF T1="XX"&(T2="XX")
- QUIT "IP^ADDED COMMENT"
- +7 IF T2="CA"
- QUIT "CA^CANCELLED"
- +8 IF T2="CM"
- Begin DoDot:1
- +9 IF '+$GET(GMRCPARN)
- IF '+$GET(TIUDA)
- SET GMRCPARN=$PIECE($GET(^GMR(123,GMRCDA,50,1,0)),U)
- +10 SET $PIECE(ORC,FS,4)=$SELECT(+$GET(GMRCPARN):+GMRCPARN_";TIU^TIU",+$GET(TIUDA):+TIUDA_";TIU^TIU",1:$PIECE(ORC,FS,4))
- End DoDot:1
- +11 IF T1="XX"&(T2="CM")
- QUIT "CM^ADDENDED"
- +12 IF T2="CM"
- QUIT "CM^COMPLETE"
- +13 IF T1="XX"&(T2="IP")&$GET(OKFROM)
- QUIT "XX^FORWARDED"
- +14 IF T1="XX"&(T2="IP")
- QUIT "IP^RESUBMITTED"
- +15 QUIT "UNKNOWN"
- FEE(FEESVC) ;send only if name contains HCPS
- +1 IF $GET(FEESVC)=""
- QUIT 0
- +2 NEW VAL
- +3 SET VAL=0
- +4 IF $$UP^XLFSTR($$GET1^DIQ(123.5,FEESVC,.01,"E"))["HCPS"
- SET VAL=1
- +5 QUIT VAL
- +1 ;create a fake event for HCP since there is no HL7 event passed to GMRC EVSEND OR
- +2 IF '$GET(GMRCDA)
- QUIT
- +3 NEW DFN
- SET DFN=$$GET1^DIQ(123,GMRCDA,.02,"I")
- IF 'DFN
- IF '$DATA(^DPT(DFN))
- QUIT
- +4 NEW T
- SET T(1)="MSH|^~\&|CONSULTS||||||ORM"
- +5 SET T(2)="PID|||"_DFN
- +6 SET T(4)="ORC|XX|"_$$GET1^DIQ(123,GMRCDA,.03,"I")_";"_$$OITEM($$GET1^DIQ(123,GMRCDA,.03,"I"))_"^OR|"_GMRCDA_";GMRC^GMRC||XX|"
- +7 DO EN(.T)
- +8 QUIT
- ADDEND(TIUDA) ;send addendums on Non VA Care consults to HCP
- +1 ;create a fake event for HCP since there is no HL7 event passed to GMRC EVSEND OR
- +2 IF '$GET(TIUDA)
- QUIT
- +3 if '$DATA(^TIU(8925,+TIUDA,0))
- QUIT
- +4 NEW TIUTYP,DFN,GMRCPARN,GMRCO,GMRCD,GMRCDA,GMRCD1,GMRC8925,T
- +5 ;
- +6 ; Quit if not an addendum
- +7 SET TIUTYP=$$GET1^DIQ(8925,TIUDA,.01,"I")
- +8 IF TIUTYP'=81
- QUIT
- +9 ;
- +10 SET DFN=$$GET1^DIQ(8925,TIUDA,.02,"I")
- +11 IF 'DFN
- IF '$DATA(^DPT(DFN))
- QUIT
- +12 ;
- +13 ; Get parent note IEN, if addendum IEN is passed in:
- +14 SET GMRCPARN=$$GET1^DIQ(8925,TIUDA,.06,"I")
- +15 ;
- +16 SET (GMRCO,GMRCD)=0
- +17 FOR
- SET GMRCD=$ORDER(^GMR(123,"AD",DFN,GMRCD))
- if 'GMRCD!(GMRCO)
- QUIT
- Begin DoDot:1
- +18 SET GMRCDA=0
- +19 FOR
- SET GMRCDA=$ORDER(^GMR(123,"AD",DFN,GMRCD,GMRCDA))
- if 'GMRCDA!(GMRCO)
- QUIT
- Begin DoDot:2
- +20 SET GMRCD1=0
- +21 FOR
- SET GMRCD1=$ORDER(^GMR(123,GMRCDA,50,GMRCD1))
- if 'GMRCD1!(GMRCO)
- QUIT
- Begin DoDot:3
- +22 SET GMRC8925=$$GET1^DIQ(123.03,GMRCD1_","_GMRCDA_",",.01,"I")
- +23 IF +GMRC8925=$SELECT(+GMRCPARN:+GMRCPARN,1:TIUDA)
- SET GMRCO=GMRCDA
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 if 'GMRCO
- QUIT
- +25 ;
- +26 SET T(1)="MSH|^~\&|CONSULTS||||||ORM"
- +27 SET T(2)="PID|||"_DFN
- +28 SET T(4)="ORC|XX|"_$$GET1^DIQ(123,GMRCO,.03,"I")_";"_$$OITEM($$GET1^DIQ(123,GMRCO,.03,"I"))_"^OR|"_GMRCO_";GMRC^GMRC||CM|"
- +29 IF $$FEE($$GET1^DIQ(123,GMRCO,1,"I"))
- DO EN(.T)
- +30 QUIT
- TIME(X,FMT) ; Copied from $$TIME^TIULS
- +1 ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
- +2 NEW HR,MIN,SEC,GMRCI
- +3 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
- SET FMT="HR:MIN"
- +4 SET X=$PIECE(X,".",2)
- SET HR=$EXTRACT(X,1,2)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,1,2)))
- SET MIN=$EXTRACT(X,3,4)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,3,4)))
- SET SEC=$EXTRACT(X,5,6)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,5,6)))
- +5 FOR GMRCI="HR","MIN","SEC"
- if FMT[GMRCI
- SET FMT=$PIECE(FMT,GMRCI)_@GMRCI_$PIECE(FMT,GMRCI,2)
- +6 QUIT FMT
- DATE(X,FMT) ; Copied from $$DATE^TIULS
- +1 ; Call with X=2910419.01 and FMT=Return Format of date ("MM/DD")
- +2 NEW AMTH,MM,CC,DD,YY,GMRCI,GMRCTMP
- +3 IF +X'>0
- SET $PIECE(GMRCTMP," ",$LENGTH($GET(FMT))+1)=""
- SET FMT=GMRCTMP
- GOTO QDATE
- +4 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
- SET FMT="MM/DD/YY"
- +5 SET MM=$EXTRACT(X,4,5)
- SET DD=$EXTRACT(X,6,7)
- SET YY=$EXTRACT(X,2,3)
- SET CC=17+$EXTRACT(X)
- +6 if FMT["AMTH"
- SET AMTH=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+MM)
- +7 FOR GMRCI="AMTH","MM","DD","CC","YY"
- if FMT[GMRCI
- SET FMT=$PIECE(FMT,GMRCI)_@GMRCI_$PIECE(FMT,GMRCI,2)
- +8 IF FMT["HR"
- SET FMT=$$TIME(X,FMT)
- QDATE QUIT FMT
- OITEM(GMRCORDN) ; Orderable Item
- +1 NEW RETVAL,GMRCOITM
- +2 SET RETVAL=1
- +3 SET GMRCOITM=+$ORDER(^OR(100,GMRCORDN,.1,0))
- +4 IF GMRCOITM
- Begin DoDot:1
- +5 SET RETVAL=+$GET(^OR(100,GMRCORDN,.1,GMRCOITM,0))
- +6 IF 'RETVAL
- SET RETVAL=1
- End DoDot:1
- +7 QUIT RETVAL
- ACK ; Process ACK HL7 messages
- +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
- 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,I,FSCGRP,GMRCSTA,GMRCSTNA,GMRCNO,GMRCTEXT
- +2 SET DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($PIECE(HL("DTM"),"-",1)))
- +3 SET FSCGRP=$$GET^XPAR("SYS","GMRC FSC HCP SUPPORT EMAIL",1)
- +4 SET XMSUB="GMRC Consults to HCP HL7 Error"
- +5 SET (GMRCSTA,GMRCSTNA)=""
- SET GMRCSTA=$$KSP^XUPARAM("INST")
- +6 IF +$GET(GMRCSTA)>0
- DO F4^XUAF4(GMRCSTA,.GMRCSTNA)
- +7 SET GMRCTEXT=$SELECT($GET(GMRCSTNA)>0:GMRCSTNA("NAME")_" ("_GMRCSTA_")",1:"Not Found")
- +8 SET GMRCNO=$$HLTEXT(MSGID)
- +9 SET MSGTEXT(1)=" "
- +10 SET MSGTEXT(2)="Error in transmitting HL7 message to HCP"
- +11 SET MSGTEXT(3)="Date: "_DATE
- +12 SET MSGTEXT(4)="Message ID: "_MSGID
- +13 SET MSGTEXT(5)="Facility: "_GMRCTEXT
- +14 SET MSGTEXT(6)="Consult No.: "_$SELECT(+$GET(GMRCNO)>0:GMRCNO,1:"Not Found")
- +15 SET MSGTEXT(7)="Error(s):"
- +16 SET I=0
- SET J=7
- FOR
- SET I=$ORDER(ERRARY(I))
- if 'I
- QUIT
- Begin DoDot:1
- +17 SET J=J+1
- SET MSGTEXT(J)=" "
- +18 SET J=J+1
- SET MSGTEXT(J)=" "_$PIECE($GET(ERRARY(I,3)),U)_" - "_$PIECE($GET(ERRARY(I,3)),U,2)
- +19 IF $PIECE($GET(ERRARY(I,2)),U,1)'=""
- SET J=J+1
- SET MSGTEXT(J)=" Segment: "_$PIECE($GET(ERRARY(I,2)),U,1)
- +20 IF $PIECE($GET(ERRARY(I,2)),U,2)'=""
- SET J=J+1
- SET MSGTEXT(J)=" Sequence: "_$PIECE($GET(ERRARY(I,2)),U,2)
- +21 IF $PIECE($GET(ERRARY(I,2)),U,3)'=""
- SET J=J+1
- SET MSGTEXT(J)=" Field: "_$PIECE($GET(ERRARY(I,2)),U,3)
- +22 IF $PIECE($GET(ERRARY(I,2)),U,4)'=""
- SET J=J+1
- SET MSGTEXT(J)=" Fld Rep: "_$PIECE($GET(ERRARY(I,2)),U,4)
- +23 IF $PIECE($GET(ERRARY(I,2)),U,5)'=""
- SET J=J+1
- SET MSGTEXT(J)=" Component: "_$PIECE($GET(ERRARY(I,2)),U,5)
- +24 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
- +25 SET XMTEXT="MSGTEXT("
- +26 SET XMDUZ="GMRC->HCP Transaction Error"
- +27 SET XMY("G.GMRC HCP HL7 MESSAGES")=""
- +28 if $GET(FSCGRP)'=""
- SET XMY(FSCGRP)=""
- +29 DO ^XMD
- +30 QUIT
- HLTEXT(MSGID) ;get hl7 message text; find obr and get consult record number
- +1 NEW GMRCWPTX,GMRCMSID,GMRCOBR,GMRCIFN,I,GMRC773,GMRC772,GMRCNDX,GMRCFLG,GMRCOUT,GMRCERR,IDX
- +2 SET GMRCIFN=0
- SET GMRCNDX="C"
- SET GMRCFLG="I"
- SET IDX=""
- +3 DO FIND^DIC(773,"","@;.01I;IX","X",MSGID,"*","C","","","GMRCOUT","GMRCERR")
- +4 IF $DATA(GMRCERR)>0
- QUIT GMRCIFN
- +5 IF +GMRCOUT("DILIST",0)'>0
- QUIT GMRCIFN
- +6 SET IDX=$ORDER(GMRCOUT("DILIST",2,""))
- +7 if +IDX>0
- SET GMRC773=GMRCOUT("DILIST",2,IDX)
- +8 IF +$GET(GMRC773)'>0
- QUIT GMRCIFN
- +9 SET GMRC772=$$GET1^DIQ(773,GMRC773_",",.01,GMRCFLG)
- +10 IF +$GET(GMRC772)'>0
- QUIT GMRCIFN
- +11 SET GMRCMSID=$$GET1^DIQ(772,GMRC772_",",200,"","GMRCWPTX")
- +12 SET I=0
- +13 FOR
- SET I=I+1
- if '$DATA(GMRCWPTX(I))
- QUIT
- Begin DoDot:1
- +14 if GMRCWPTX(I)'["OBR"
- QUIT
- +15 SET GMRCOBR=GMRCWPTX(I)
- +16 if $PIECE(GMRCOBR,"|",4)["GMRC"
- SET GMRCIFN=$PIECE(GMRCOBR,"|",4)
- SET GMRCIFN=$PIECE(GMRCIFN,";")
- End DoDot:1
- +17 QUIT GMRCIFN