- GMRCCCRA ;COG/PB/LB/MJ - Receive HL7 Message for HCP ;3/21/18 09:00
- ;;3.0;CONSULT/REQUEST TRACKING;**99,106,112,123,134,146,158,163,173,190,203**;JUN 1, 2018;Build 6
- ;
- ;DBIA# Supported Reference
- ;----- --------------------------------
- ;2161 INIT^HLFNC2
- ;2164 GENERATE^HLMA
- ;2944 TGET^TIUSRVR1
- ;3267 SSN^DPTLK1
- ;3630 BLDPID^VAFCQRY
- ;5807 GETLINK^TIUSRVT1
- ;10103 FMTE^XLFDT, FMTHL7^XLFDT
- ;10104 UP^XLFSTR
- ;10106 FMDATE^HLFNC
- ;1252 OUTPTPR^SDUTL3
- ;6917 EN^VAFHLIN1
- ;10106 HLADDR^HLFNC
- ;2467 OR^ORX8
- ;2171 NS^XUAF4
- ;2693 EXTRACT^TIULQ
- ;
- ;Patch 85 fix for CA SDM ticket R6063960FY16
- ;Patch 99 fix for screen to send community care consults HL7 messages - Cognosante - PB Mar 5 2018
- ;Patch 99 commented out PCP code- 2nd PRD segment -until Intersystems ready M14/M15- Cognosante-LB Apr 3 2018
- ;Patch 106 added code to include IN1 segments with reimburse flag, and division value in PV1.
- ;Patch 106 cleaned up per several ICRs.
- ;Patch 112 critical fix to remove control characters before sending consult, as bad data was causing infinite loop of HL7 process.
- ;Patch 123 consult status updates inbound to VistA, OHI additions outbound from VistA in IN1 segment
- ;Patch 134 fix control character issue in TIU notes
- ;Patch 146 fix if the consult was transferred from an imaging order, sets the DXCODE from the DX text
- ;Patch 146 fix PRD address problem, set to null fields that contain only spaces
- ;Patch 158 add code to convert start and end times from eastern to local, code to update the new field 81 in file 123
- ;Patch 163 add code to allow editing of new file 81 in file 123
- ;proposed for CCRA release 8.0 - successfully send Administrative Complete consult notes
- ;Patch 173 add EDIPI to the PID segment
- ;Patch 190 adds a check for a discontinue comment in the Order file, field 65 if Order file, field 64 is null.
- ;
- EN(MSG) ;Entry point to routine from GMRC CONSULTS TO CCRA protocol attached to 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
- ..D CCONTROL^GMRCCCR1(GMRCDA) ; strip out consult lines that contain only $C(13,10,10) to fix infinite msg loop - patch 112
- ..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
- N PCP,PCDUZ,PCPN,PCADDR,PCPH,GMRCERR,UPDATE81,FDA
- ;S SNAME="GMRC HCP REF-"_$S(MSGTYP2="DR":"I14",MSGTYP="ORR":"I12",MSGTYP2="OC":"I14",MSGTYP2="OD":"I14",1:"I13")_" SERVER"
- S SNAME="GMRC CCRA-HSRM 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("GMRCHL7CCRA",$J)) K @DATA D GETS^DIQ(123,GMRCDA,"*","IE",DATA)
- S GDATA=$NA(^TMP("GMRCHL7CCRA",$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_"||||"
- 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
- ;PRD segments
- ;"RP"- Referring Provider segment
- S PDUZ=+$G(@GDATA@(10,"I")),PN=$G(@GDATA@(10,"E")),PN=$$HLNAME^XLFNAME(PN,"S",ECH),$P(PN,ECH,9)=PDUZ
- N NPI S NPI=$P($G(^VA(200,PDUZ,"NPI")),"^")
- S ADDR=$$ADDR^GMRCHL7P(PDUZ,.GMRCHL),PH=$$PH^GMRCHL7P(PDUZ,.GMRCHL)
- S ADDR=$$CLRADD^GMRCCCR1(ADDR) ; patch 146 - MJ
- S ZCNT=ZCNT+1,GMRCM(ZCNT)="PRD|RP|"_PN_"|"_$G(ADDR)_"||"_$G(PH)_"||"_+$G(NPI)
- ;commented out PCP code- 2nd PRD segment -until Intersystems ready M14/M15- Cognosante-LB Apr 3 2018
- ;PCP code-starts here-
- ;"PP"- Primary Care Provider segment if the info exists
- S PCP=$$OUTPTPR^SDUTL3(DFN)
- I +PCP D
- . S PCDUZ=+PCP,PCPN=$P(PCP,"^",2),PCPN=$$HLNAME^XLFNAME(PCPN,"S",ECH),$P(PCPN,ECH,9)=PCDUZ
- . S PCADDR=$$ADDR^GMRCHL7P(PCDUZ,.GMRCHL),PCPH=$$PH^GMRCHL7P(PCDUZ,.GMRCHL)
- . S PCADDR=$$CLRADD^GMRCCCR1(PCADDR) ; patch 146 - MJ
- . S NPI=$P($G(^VA(200,PCDUZ,"NPI")),"^")
- . S ZCNT=ZCNT+1,GMRCM(ZCNT)="PRD|PP|"_PCPN_"|"_$G(PCADDR)_"||"_$G(PCPH)_"||"_+$G(NPI)
- ;PCP code-ends here-
- ;PID segment May be multiple nodes in the return array - make nodes 2-n sub nodes
- K LOOPER S LOOPER=0 N TGMRCP,TMPGMRCP
- PID ;
- K PID N GMRCP
- D BLDPID^VAFCQRY(DFN,1,"ALL",.GMRCP,.GMRCHL,ZERR)
- M TGMRCP=GMRCP
- K NEWGMRCP
- K ^TMP($J,"GMRCP")
- ;D EDIPI^GMRCCCR1(DFN,.GMRCP)
- D EDIPI^GMRCCCR1(DFN,.GMRCP)
- I $G(NEWGMRCP(1))'="" M GMRCP=NEWGMRCP
- ;for the first patch after 203, fix the issue of not sending a PID if no edipi:
- ;I $G(GMRCP)=1 M GMRCP=TGMRCP
- I $G(GMRCP(1))="" K GMRCP M GMRCP=^TMP($J,"GMRCP")
- 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,^TMP($J,"GMRCP")
- ;MJ - 5/24/2018 patch 106 changes to add - IN1 segments
- N GMRC0,I,INSP,INSPX,RETVAL,X,GMRCIN1,N,GMRCSTR,PLAN,PRECERT,TYPE ; PLAN, PRECERT, TYPE added for patch 123
- S GMRCSTR=",3,4,5,7,8,9,12,13,15,16,17,28,36" ; IN1 fields to capture
- D EN^VAFHLIN1(DFN,GMRCSTR,,"|","GMRCIN1","^~\&") ; get IN1 segments
- ;loop through IN1 segments found
- F I=0:0 S I=$O(GMRCIN1(I)) Q:'I I I>0 D
- . S GMRC0=$G(GMRCIN1(I,0)) I GMRC0']"" Q
- . S INSP=$P(GMRC0,"|",4)
- . S PRECERT="" ; added for patch 123
- . S N=0 F S N=$O(^DPT(DFN,.312,N)) Q:'N I $D(^(N,0)) D
- .. S X=^DPT(DFN,.312,N,0)
- .. ;begin patch 123 mods
- .. N COORDBEN,LASTVER,Y
- .. S COORDBEN=$P(X,"^",20)
- .. S COORDBEN=$S(COORDBEN=1:"PRIMARY",COORDBEN=2:"SECONDARY",COORDBEN=3:"TERTIARY",1:"")
- .. S $P(GMRC0,"|",22)=COORDBEN
- .. S Y=$G(^DPT(DFN,.312,N,1)),LASTVER=$P(Y,"^",3)
- .. I +LASTVER>0 S LASTVER=LASTVER+17000000
- .. S $P(GMRC0,"|",30)=LASTVER
- .. S PLAN=+$P(X,"^",18)
- .. S PRECERT=$G(^IBA(355.3,PLAN,0)),TYPE=$P(PRECERT,"^",15),PRECERT=$P(PRECERT,"^",6)
- .. S PRECERT=$S(PRECERT=1:"YES",0:"NO",1:"")
- .. S $P(GMRC0,"|",16)=TYPE
- .. S PLANID=+$G(^IBA(355.3,PLAN,6)) S:PLANID=0 PLANID=""
- .. I $L(PLANID)>0 S PLANID=$P($G(^IBCNR(366.03,PLANID,0)),"^",1)
- .. S $P(GMRC0,"|",3)=PLANID ;
- .. K COORDBEN,LASTVER,PLANID,Y
- .. ;end patch 123 mods
- .. N X1 S X1=$G(^DIC(36,+X,0)) I X1="" Q ; no insurance company entry
- .. S INSPX=$P(X,U,1)
- .. I INSP=INSPX D ; insurance plan found matches that of the segment
- ... S RETVAL=$$GET1^DIQ(36,INSP_",",1,"I") ; get reimbursable flag
- ... S RETVAL=$S(RETVAL="Y":"YES",RETVAL="*":"*",RETVAL="**":"**",RETVAL="":"YES",RETVAL="N":"NO",1:"?")
- ... S $P(GMRC0,"|",33)=RETVAL ; add flag back into segment
- ... ;get address
- ... S $P(GMRC0,"|",6)=$$GETADD^GMRCCCR1(INSP) ; get address info and put it into segment field 5
- ... S GMRCIN1(I,0)=GMRC0
- . S ZCNT=ZCNT+1,GMRCM(ZCNT)=GMRCIN1(I,0) ; add segment to message
- . ;patch 123 mods - if PRECERT value exists, create IN3 segment
- . I $L(PRECERT) S ZCNT=ZCNT+1,GMRCM(ZCNT)="IN3",$P(GMRCM(ZCNT),"|",21)="^"_PRECERT,PRECERT=""
- . ;end patch 123 mods
- K GMRC0,I,INSP,INSPX,RETVAL,X,GMRCIN1,N,GMRCSTR,PLAN,PRECERT,TYPE ; PLAN, PRECERT, TYPE added for patch 123
- ;end patch 106 changes
- ;DG1 segment ;Patch 85 modified
- ;if this is a radiology order converted to a consult the dxcode will not be in the consult in field 30.1
- ;the DX text has the dxcode in it, the code below parses it.
- ;radiology dx text:Encounter for other specified special examinations (ICD-10-CM Z01.89)
- S DX=$G(@GDATA@(30,"E"))
- S DXCODE=$G(@GDATA@(30.1,"E"))
- N TDXCODE
- I $G(DX)["(" S TDXCODE=$P($P(DX,"ICD-10-CM ",2),")",1),DX=$P(DX,"(") ;PB - patch 146
- S:$G(DXCODE)="" DXCODE=$G(TDXCODE)
- 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
- ;patch 106 - add in division value
- N GMRCDIV
- S GMRCDIV=$$NS^XUAF4(DUZ(2)),GMRCDIV=$P(GMRCDIV,"^",2)
- N ORGDIV S ORGDIV=$$GET1^DIQ(123,GMRCDA_",",81,"I")
- I $G(ORGDIV)'="" S:$G(ORGDIV)'=$G(GMRCDIV) GMRCDIV=$G(ORGDIV)
- I $G(ORGDIV)="" D
- .Q:($G(MSGTYP)="SC"&($G(MSGTYP3)="ZC")) ; patch 163 - PB don't update the new field if it is a scheduling update
- .N FDA S FDA(123,$G(GMRCDA)_",",81)=GMRCDIV D UPDATE^DIE(,"FDA",$G(GMRCDA)_",","GMRCERR")
- N A,B S A="&"_GMRCDIV,B=$P(GMRCM(ZCNT),"|",4),$P(B,"^",4)=A,$P(GMRCM(ZCNT),"|",4)=B K A,B
- K GMRCDIV
- ;End patch 106 mod
- S SENS=$$SSN^DPTLK1(DFN) I SENS["*SENSITIVE*" S $P(GMRCM(ZCNT),"|",17)="R" ;sensitive patient
- S $P(GMRCM(ZCNT),"|",18)=VAIP(13,5)
- ;begin patch 106 mod
- K VAIP
- ;end patch 106 mod
- D KVA^VADPT
- ;NTE segment
- D NTE(.GMRCHL)
- I $G(^GMR(123,GMRCDA,5))'="" D ; patch 163 - PB set referral facility on PV1 to value in field 81, file 123
- .N XXCNT,P4
- .S XXCNT=0 F S XXCNT=$O(GMRCM(XXCNT)) Q:XXCNT'>0 D
- ..S:$P(GMRCM(XXCNT),"|")="PV1" P4=$P(GMRCM(XXCNT),"|",4),$P(P4,"&",2)=$P(^GMR(123,GMRCDA,5),"^"),$P(GMRCM(XXCNT),"|",4)=P4
- K ^TMP("GMRCHL7CCRA",$J)
- ;When done, re-serve the (modified) referral message to CCRA
- N HL,HLA,GMRCRES,GMRCHLP
- M HL=GMRCHL,HLA("HLS")=GMRCM
- M GMRCHL=^XTMP("GMRCHL7H","MESSAGE")
- ;D EDIPI^GMRCCCR1(DFN)
- 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
- ..S X=$$TIUC^GMRCCCR1(X)
- ..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")
- .;line below modified in patch 106 to use GET1^DIQ call for date
- .S GMRCCMP=$$DATE^GMRCCCRA($$GET1^DIQ(8925,+TIUDA_",",1301,"I"),"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 X=$$TIUC^GMRCCCR1(X)
- ...S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- .K ^TMP("TIUVIEW",$J) ;clean up results of TIUSRVR1 call
- ;patch 146 - DONE flag used to determine if notes are found. If so, no need to drop to default
- ;some cases of DR/CM combo have notes stored in level 50, some in level 40
- ;both need to be accounted for
- ;I MSGTYP3="CM" D Q ; pre-146
- N DONE S DONE=0 ; patch 146
- I MSGTYP3="CM" D Q:DONE ; patch 146
- .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 X=$$TIUC^GMRCCCR1(X)
- ..S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X,DONE=1 ; patch 146 - DONE
- ..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)
- .I $G(CMT)="" S CMT=$$GET1^DIQ(100,ORIEN_",",65) ;Patch 190 - PB if field 64 is null check field 65
- .I $G(CMT)'="" S CMT=$$TRIM^XLFSTR($G(CMT))
- .S CMT=$TR($G(CMT),$C(13,10,10),$C(10,10))
- .D HL7TXT^GMRCHL7P(.CMT,.HL,"\")
- .S:$G(CMT)'="" CMT=$$TIUC^GMRCCCR1(CMT) ;Patch 190 - PB if the comment is null, don't call the control character screen API
- .S ZCNT=ZCNT+1,GMRCM(ZCNT)="NTE|2||"_CMT
- .Q
- N ACT,ACTD,ACTIEN,Q,UPDATE81
- S UPDATE81=0
- 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 X=$$TIUC^GMRCCCR1(X)
- ..S ZCNT=ZCNT+1,NTECNT=NTECNT+1,GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- ..I $$UP^XLFSTR($G(X))["EDIT REFERRAL FACILITY:" D ; patch 163 - PB if the edit is to change referral facility parse and update field 81, file 123
- ...S X=$TR(X,$C(10),"")
- ...S UPDATE81=$P(X,": ",2)
- ...Q:$G(UPDATE81)=0
- ...N FDA S FDA(123,$G(GMRCDA)_",",81)=$G(UPDATE81) D UPDATE^DIE(,"FDA",$G(GMRCDA)_",","GMRCERR")
- ..Q
- .Q
- Q
- AUTHDTTM ; Add Author and Date/Time to NTE
- D AUTHDTTM^GMRCCCR1 ; patch 146, for size
- 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/UPDATE" ; patch 146, was "CM^COMPLETE", didn't match file 123.1 ; MJ
- 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
- I $$UP^XLFSTR($$GET1^DIQ(123.5,FEESVC,.01,"E"))["COMMUNITY CARE" S VAL=1 ;*99 - PB - Mar 5, 2018
- I $$UP^XLFSTR($$GET1^DIQ(123.5,FEESVC,.01,"E"))["DOD TREATMENT" S VAL=1 ;*99 - PB - Mar 5, 2018
- 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 ; modified "," to "!" within patch 106
- 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
- S GMRCO=$$ADDEND^GMRCCCR1 Q:'GMRCO ; patch 146, needed for space ; MJ
- 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
- ; Receives X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
- N HR,MIN,SEC,TIUI
- 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 TIUI="HR","MIN","SEC" S:FMT[TIUI FMT=$P(FMT,TIUI)_@TIUI_$P(FMT,TIUI,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,TIUI,TIUTMP
- I +X'>0 S $P(TIUTMP," ",$L($G(FMT))+1)="",FMT=TIUTMP 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 TIUI="AMTH","MM","DD","CC","YY" S:FMT[TIUI FMT=$P(FMT,TIUI)_@TIUI_$P(FMT,TIUI,2)
- I FMT["HR" S FMT=$$TIME(X,FMT)
- QDATE Q FMT
- OITEM(GMRCORDN) ; Orderable Item
- ; patch 106 - modified to use ICR 2467
- N RETVAL ;,GMRCOITM
- S RETVAL=1
- S RETVAL=+$$OI^ORX8(GMRCORDN)
- I 'RETVAL S RETVAL=1
- ;end patch 106 mods
- Q RETVAL
- ACK ; Process ACK HL7 messages
- D ACK^GMRCCCR1 ; patch 146, moved for space
- Q
- MESSAGE(MSGID,ERRARY) ; Send a MailMan Message with the errors
- D MESSAGE^GMRCCCR1(MSGID,.ERRARY)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCCCRA 18659 printed Feb 18, 2025@23:11:39 Page 2
- GMRCCCRA ;COG/PB/LB/MJ - Receive HL7 Message for HCP ;3/21/18 09:00
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**99,106,112,123,134,146,158,163,173,190,203**;JUN 1, 2018;Build 6
- +2 ;
- +3 ;DBIA# Supported Reference
- +4 ;----- --------------------------------
- +5 ;2161 INIT^HLFNC2
- +6 ;2164 GENERATE^HLMA
- +7 ;2944 TGET^TIUSRVR1
- +8 ;3267 SSN^DPTLK1
- +9 ;3630 BLDPID^VAFCQRY
- +10 ;5807 GETLINK^TIUSRVT1
- +11 ;10103 FMTE^XLFDT, FMTHL7^XLFDT
- +12 ;10104 UP^XLFSTR
- +13 ;10106 FMDATE^HLFNC
- +14 ;1252 OUTPTPR^SDUTL3
- +15 ;6917 EN^VAFHLIN1
- +16 ;10106 HLADDR^HLFNC
- +17 ;2467 OR^ORX8
- +18 ;2171 NS^XUAF4
- +19 ;2693 EXTRACT^TIULQ
- +20 ;
- +21 ;Patch 85 fix for CA SDM ticket R6063960FY16
- +22 ;Patch 99 fix for screen to send community care consults HL7 messages - Cognosante - PB Mar 5 2018
- +23 ;Patch 99 commented out PCP code- 2nd PRD segment -until Intersystems ready M14/M15- Cognosante-LB Apr 3 2018
- +24 ;Patch 106 added code to include IN1 segments with reimburse flag, and division value in PV1.
- +25 ;Patch 106 cleaned up per several ICRs.
- +26 ;Patch 112 critical fix to remove control characters before sending consult, as bad data was causing infinite loop of HL7 process.
- +27 ;Patch 123 consult status updates inbound to VistA, OHI additions outbound from VistA in IN1 segment
- +28 ;Patch 134 fix control character issue in TIU notes
- +29 ;Patch 146 fix if the consult was transferred from an imaging order, sets the DXCODE from the DX text
- +30 ;Patch 146 fix PRD address problem, set to null fields that contain only spaces
- +31 ;Patch 158 add code to convert start and end times from eastern to local, code to update the new field 81 in file 123
- +32 ;Patch 163 add code to allow editing of new file 81 in file 123
- +33 ;proposed for CCRA release 8.0 - successfully send Administrative Complete consult notes
- +34 ;Patch 173 add EDIPI to the PID segment
- +35 ;Patch 190 adds a check for a discontinue comment in the Order file, field 65 if Order file, field 64 is null.
- +36 ;
- EN(MSG) ;Entry point to routine from GMRC CONSULTS TO CCRA protocol attached to 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 ; strip out consult lines that contain only $C(13,10,10) to fix infinite msg loop - patch 112
- DO CCONTROL^GMRCCCR1(GMRCDA)
- +12 IF MSGTYP3="IP"
- SET ACTIEN=$ORDER(^GMR(123,GMRCDA,40,99999),-1)
- Begin DoDot:3
- +13 IF ACTIEN
- SET FROMSVC=$PIECE($GET(^GMR(123,GMRCDA,40,ACTIEN,0)),U,6)
- IF FROMSVC
- SET OKFROM=$$FEE(FROMSVC)
- End DoDot:3
- +14 SET OK=$$FEE($$GET1^DIQ(123,GMRCDA,1,"I"))
- +15 ;not a Fee service or not forwarded from a fee service
- IF '$GET(OKFROM)&'$GET(OK)
- SET QUIT=1
- +16 QUIT
- End DoDot:2
- +17 QUIT
- End DoDot:1
- +18 if QUIT
- QUIT
- +19 IF MSGTYP="ORR"
- SET MSGTYP3="NW"
- +20 ;don't process anything we haven't coded for
- SET STATUS=$$STATUS(MSGTYP2,MSGTYP3)
- IF STATUS="UNKNOWN"
- QUIT
- +21 ;done verifying this consult needs to go to HCP, start building HL7 message
- +22 NEW SNAME,GMRCHL,ZERR,ZCNT,ECH,DATA,GDATA,URG,TYP,RES,EFFDT,PDUZ,PN,ADDR,PH,GMRCP,SENS,DX,DXCODE
- +23 NEW PCP,PCDUZ,PCPN,PCADDR,PCPH,GMRCERR,UPDATE81,FDA
- +24 ;S SNAME="GMRC HCP REF-"_$S(MSGTYP2="DR":"I14",MSGTYP="ORR":"I12",MSGTYP2="OC":"I14",MSGTYP2="OD":"I14",1:"I13")_" SERVER"
- +25 SET SNAME="GMRC CCRA-HSRM REF-"_$SELECT(MSGTYP2="DR":"I14",MSGTYP="ORR":"I12",MSGTYP2="OC":"I14",MSGTYP2="OD":"I14",1:"I13")_" SERVER"
- +26 SET GMRCHL("EID")=$$FIND1^DIC(101,,"X",SNAME)
- +27 if 'GMRCHL("EID")
- QUIT
- DO INIT^HLFNC2(GMRCHL("EID"),.GMRCHL)
- +28 ;component separator
- SET ZERR=""
- SET ZCNT=0
- SET ECH=$EXTRACT(GMRCHL("ECH"))
- +29 ;start creating the segments.
- +30 SET DATA=$NAME(^TMP("GMRCHL7CCRA",$JOB))
- KILL @DATA
- DO GETS^DIQ(123,GMRCDA,"*","IE",DATA)
- +31 ;File 123 data
- SET GDATA=$NAME(^TMP("GMRCHL7CCRA",$JOB,123,+GMRCDA_","))
- +32 ;RF1 segment
- +33 KILL GMRCM
- +34 ;I URG]"" S URG=$S(URG["ROUTINE":"R",URG["STAT":"S",1:"A")
- SET URG=$GET(@GDATA@(5,"E"))
- +35 SET URG=$PIECE(URG,"- ",2)
- +36 SET TYP=$GET(@GDATA@(1,"I"))_ECH_$GET(@GDATA@(1,"E"))
- DO GETLINK^TIUSRVT1(.RES,+TYP_";GMR(123.5,")
- +37 SET TYP=TYP_ECH_ECH_$PIECE($GET(RES),U)_ECH_$PIECE($GET(RES),U,4)
- +38 SET EFFDT=$$FMTHL7^XLFDT($GET(@GDATA@(.01,"I")))
- +39 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="RF1|"_STATUS_"|"_URG_"|"_TYP_"||"_$GET(@GDATA@(14,"I"))_"|"_GMRCDA_"|"_EFFDT_"||||"
- +40 SET UCID=$$GET1^DIQ(123,GMRCDA,80)
- +41 if $GET(UCID)'=""
- SET GMRCM(ZCNT)="RF1|"_STATUS_"|"_URG_"|"_TYP_"||"_$GET(@GDATA@(14,"I"))_"|"_UCID_"|"_EFFDT_"||||"
- +42 ;TEMP ERROR HANDLER
- if $GET(UCID)=""
- SET ^XTMP("GMRCHL7H","UCID IS EMPTY",GMRCDA)=GMRCDA
- +43 ;PRD segments
- +44 ;"RP"- Referring Provider segment
- +45 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
- +46 NEW NPI
- SET NPI=$PIECE($GET(^VA(200,PDUZ,"NPI")),"^")
- +47 SET ADDR=$$ADDR^GMRCHL7P(PDUZ,.GMRCHL)
- SET PH=$$PH^GMRCHL7P(PDUZ,.GMRCHL)
- +48 ; patch 146 - MJ
- SET ADDR=$$CLRADD^GMRCCCR1(ADDR)
- +49 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="PRD|RP|"_PN_"|"_$GET(ADDR)_"||"_$GET(PH)_"||"_+$GET(NPI)
- +50 ;commented out PCP code- 2nd PRD segment -until Intersystems ready M14/M15- Cognosante-LB Apr 3 2018
- +51 ;PCP code-starts here-
- +52 ;"PP"- Primary Care Provider segment if the info exists
- +53 SET PCP=$$OUTPTPR^SDUTL3(DFN)
- +54 IF +PCP
- Begin DoDot:1
- +55 SET PCDUZ=+PCP
- SET PCPN=$PIECE(PCP,"^",2)
- SET PCPN=$$HLNAME^XLFNAME(PCPN,"S",ECH)
- SET $PIECE(PCPN,ECH,9)=PCDUZ
- +56 SET PCADDR=$$ADDR^GMRCHL7P(PCDUZ,.GMRCHL)
- SET PCPH=$$PH^GMRCHL7P(PCDUZ,.GMRCHL)
- +57 ; patch 146 - MJ
- SET PCADDR=$$CLRADD^GMRCCCR1(PCADDR)
- +58 SET NPI=$PIECE($GET(^VA(200,PCDUZ,"NPI")),"^")
- +59 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="PRD|PP|"_PCPN_"|"_$GET(PCADDR)_"||"_$GET(PCPH)_"||"_+$GET(NPI)
- End DoDot:1
- +60 ;PCP code-ends here-
- +61 ;PID segment May be multiple nodes in the return array - make nodes 2-n sub nodes
- +62 KILL LOOPER
- SET LOOPER=0
- NEW TGMRCP,TMPGMRCP
- PID ;
- +1 KILL PID
- NEW GMRCP
- +2 DO BLDPID^VAFCQRY(DFN,1,"ALL",.GMRCP,.GMRCHL,ZERR)
- +3 MERGE TGMRCP=GMRCP
- +4 KILL NEWGMRCP
- +5 KILL ^TMP($JOB,"GMRCP")
- +6 ;D EDIPI^GMRCCCR1(DFN,.GMRCP)
- +7 DO EDIPI^GMRCCCR1(DFN,.GMRCP)
- +8 IF $GET(NEWGMRCP(1))'=""
- MERGE GMRCP=NEWGMRCP
- +9 ;for the first patch after 203, fix the issue of not sending a PID if no edipi:
- +10 ;I $G(GMRCP)=1 M GMRCP=TGMRCP
- +11 IF $GET(GMRCP(1))=""
- KILL GMRCP
- MERGE GMRCP=^TMP($JOB,"GMRCP")
- +12 SET I=0
- FOR
- SET I=$ORDER(GMRCP(I))
- if 'I
- QUIT
- Begin DoDot:1
- +13 IF I=1
- SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)=$TRANSLATE(GMRCP(I),"""")
- QUIT
- +14 SET GMRCM(ZCNT,I)=$TRANSLATE(GMRCP(I),"""")
- End DoDot:1
- +15 KILL GMRCP,^TMP($JOB,"GMRCP")
- +16 ;MJ - 5/24/2018 patch 106 changes to add - IN1 segments
- +17 ; PLAN, PRECERT, TYPE added for patch 123
- NEW GMRC0,I,INSP,INSPX,RETVAL,X,GMRCIN1,N,GMRCSTR,PLAN,PRECERT,TYPE
- +18 ; IN1 fields to capture
- SET GMRCSTR=",3,4,5,7,8,9,12,13,15,16,17,28,36"
- +19 ; get IN1 segments
- DO EN^VAFHLIN1(DFN,GMRCSTR,,"|","GMRCIN1","^~\&")
- +20 ;loop through IN1 segments found
- +21 FOR I=0:0
- SET I=$ORDER(GMRCIN1(I))
- if 'I
- QUIT
- IF I>0
- Begin DoDot:1
- +22 SET GMRC0=$GET(GMRCIN1(I,0))
- IF GMRC0']""
- QUIT
- +23 SET INSP=$PIECE(GMRC0,"|",4)
- +24 ; added for patch 123
- SET PRECERT=""
- +25 SET N=0
- FOR
- SET N=$ORDER(^DPT(DFN,.312,N))
- if 'N
- QUIT
- IF $DATA(^(N,0))
- Begin DoDot:2
- +26 SET X=^DPT(DFN,.312,N,0)
- +27 ;begin patch 123 mods
- +28 NEW COORDBEN,LASTVER,Y
- +29 SET COORDBEN=$PIECE(X,"^",20)
- +30 SET COORDBEN=$SELECT(COORDBEN=1:"PRIMARY",COORDBEN=2:"SECONDARY",COORDBEN=3:"TERTIARY",1:"")
- +31 SET $PIECE(GMRC0,"|",22)=COORDBEN
- +32 SET Y=$GET(^DPT(DFN,.312,N,1))
- SET LASTVER=$PIECE(Y,"^",3)
- +33 IF +LASTVER>0
- SET LASTVER=LASTVER+17000000
- +34 SET $PIECE(GMRC0,"|",30)=LASTVER
- +35 SET PLAN=+$PIECE(X,"^",18)
- +36 SET PRECERT=$GET(^IBA(355.3,PLAN,0))
- SET TYPE=$PIECE(PRECERT,"^",15)
- SET PRECERT=$PIECE(PRECERT,"^",6)
- +37 SET PRECERT=$SELECT(PRECERT=1:"YES",0:"NO",1:"")
- +38 SET $PIECE(GMRC0,"|",16)=TYPE
- +39 SET PLANID=+$GET(^IBA(355.3,PLAN,6))
- if PLANID=0
- SET PLANID=""
- +40 IF $LENGTH(PLANID)>0
- SET PLANID=$PIECE($GET(^IBCNR(366.03,PLANID,0)),"^",1)
- +41 ;
- SET $PIECE(GMRC0,"|",3)=PLANID
- +42 KILL COORDBEN,LASTVER,PLANID,Y
- +43 ;end patch 123 mods
- +44 ; no insurance company entry
- NEW X1
- SET X1=$GET(^DIC(36,+X,0))
- IF X1=""
- QUIT
- +45 SET INSPX=$PIECE(X,U,1)
- +46 ; insurance plan found matches that of the segment
- IF INSP=INSPX
- Begin DoDot:3
- +47 ; get reimbursable flag
- SET RETVAL=$$GET1^DIQ(36,INSP_",",1,"I")
- +48 SET RETVAL=$SELECT(RETVAL="Y":"YES",RETVAL="*":"*",RETVAL="**":"**",RETVAL="":"YES",RETVAL="N":"NO",1:"?")
- +49 ; add flag back into segment
- SET $PIECE(GMRC0,"|",33)=RETVAL
- +50 ;get address
- +51 ; get address info and put it into segment field 5
- SET $PIECE(GMRC0,"|",6)=$$GETADD^GMRCCCR1(INSP)
- +52 SET GMRCIN1(I,0)=GMRC0
- End DoDot:3
- End DoDot:2
- +53 ; add segment to message
- SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)=GMRCIN1(I,0)
- +54 ;patch 123 mods - if PRECERT value exists, create IN3 segment
- +55 IF $LENGTH(PRECERT)
- SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="IN3"
- SET $PIECE(GMRCM(ZCNT),"|",21)="^"_PRECERT
- SET PRECERT=""
- +56 ;end patch 123 mods
- End DoDot:1
- +57 ; PLAN, PRECERT, TYPE added for patch 123
- KILL GMRC0,I,INSP,INSPX,RETVAL,X,GMRCIN1,N,GMRCSTR,PLAN,PRECERT,TYPE
- +58 ;end patch 106 changes
- +59 ;DG1 segment ;Patch 85 modified
- +60 ;if this is a radiology order converted to a consult the dxcode will not be in the consult in field 30.1
- +61 ;the DX text has the dxcode in it, the code below parses it.
- +62 ;radiology dx text:Encounter for other specified special examinations (ICD-10-CM Z01.89)
- +63 SET DX=$GET(@GDATA@(30,"E"))
- +64 SET DXCODE=$GET(@GDATA@(30.1,"E"))
- +65 NEW TDXCODE
- +66 ;PB - patch 146
- IF $GET(DX)["("
- SET TDXCODE=$PIECE($PIECE(DX,"ICD-10-CM ",2),")",1)
- SET DX=$PIECE(DX,"(")
- +67 if $GET(DXCODE)=""
- SET DXCODE=$GET(TDXCODE)
- +68 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="DG1|1||"_$GET(DXCODE)_ECH_$GET(DX)_"|||W"
- +69 ;OBR segment
- +70 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="OBR|1|"_$PIECE(ORC,FS,3)_"|"_$PIECE(ORC,FS,4)_"|ZZ||"_$$FMTHL7^XLFDT($GET(@GDATA@(17,"I")))
- +71 ;PV1 segment
- +72 ;VAIP(18)=Attending Physician, VAIP(13,5)=Primary Physician for admission
- DO IN5^VADPT
- +73 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="PV1|1|"_$SELECT(VAIP(13):"I",1:"O")_"|||||"_VAIP(18)_"|"
- +74 ;location for last movement event
- IF VAIP(5)
- SET $PIECE(GMRCM(ZCNT),"|",4)=VAIP(5)
- +75 ;patch 106 - add in division value
- +76 NEW GMRCDIV
- +77 SET GMRCDIV=$$NS^XUAF4(DUZ(2))
- SET GMRCDIV=$PIECE(GMRCDIV,"^",2)
- +78 NEW ORGDIV
- SET ORGDIV=$$GET1^DIQ(123,GMRCDA_",",81,"I")
- +79 IF $GET(ORGDIV)'=""
- if $GET(ORGDIV)'=$GET(GMRCDIV)
- SET GMRCDIV=$GET(ORGDIV)
- +80 IF $GET(ORGDIV)=""
- Begin DoDot:1
- +81 ; patch 163 - PB don't update the new field if it is a scheduling update
- if ($GET(MSGTYP)="SC"&($GET(MSGTYP3)="ZC"))
- QUIT
- +82 NEW FDA
- SET FDA(123,$GET(GMRCDA)_",",81)=GMRCDIV
- DO UPDATE^DIE(,"FDA",$GET(GMRCDA)_",","GMRCERR")
- End DoDot:1
- +83 NEW A,B
- SET A="&"_GMRCDIV
- SET B=$PIECE(GMRCM(ZCNT),"|",4)
- SET $PIECE(B,"^",4)=A
- SET $PIECE(GMRCM(ZCNT),"|",4)=B
- KILL A,B
- +84 KILL GMRCDIV
- +85 ;End patch 106 mod
- +86 ;sensitive patient
- SET SENS=$$SSN^DPTLK1(DFN)
- IF SENS["*SENSITIVE*"
- SET $PIECE(GMRCM(ZCNT),"|",17)="R"
- +87 SET $PIECE(GMRCM(ZCNT),"|",18)=VAIP(13,5)
- +88 ;begin patch 106 mod
- +89 KILL VAIP
- +90 ;end patch 106 mod
- +91 DO KVA^VADPT
- +92 ;NTE segment
- +93 DO NTE(.GMRCHL)
- +94 ; patch 163 - PB set referral facility on PV1 to value in field 81, file 123
- IF $GET(^GMR(123,GMRCDA,5))'=""
- Begin DoDot:1
- +95 NEW XXCNT,P4
- +96 SET XXCNT=0
- FOR
- SET XXCNT=$ORDER(GMRCM(XXCNT))
- if XXCNT'>0
- QUIT
- Begin DoDot:2
- +97 if $PIECE(GMRCM(XXCNT),"|")="PV1"
- SET P4=$PIECE(GMRCM(XXCNT),"|",4)
- SET $PIECE(P4,"&",2)=$PIECE(^GMR(123,GMRCDA,5),"^")
- SET $PIECE(GMRCM(XXCNT),"|",4)=P4
- End DoDot:2
- End DoDot:1
- +98 KILL ^TMP("GMRCHL7CCRA",$JOB)
- +99 ;When done, re-serve the (modified) referral message to CCRA
- +100 NEW HL,HLA,GMRCRES,GMRCHLP
- +101 MERGE HL=GMRCHL,HLA("HLS")=GMRCM
- +102 MERGE GMRCHL=^XTMP("GMRCHL7H","MESSAGE")
- +103 ;D EDIPI^GMRCCCR1(DFN)
- +104 DO GENERATE^HLMA(GMRCHL("EID"),"LM",1,.GMRCRES,"",.GMRCHLP)
- +105 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 SET X=$$TIUC^GMRCCCR1(X)
- +9 DO HL7TXT^GMRCHL7P(.X,.HL,"\")
- +10 SET ZCNT=ZCNT+1
- SET NTECNT=NTECNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- +11 QUIT
- End DoDot:2
- +12 QUIT
- End DoDot:1
- QUIT
- +13 ;Build NTE for CM^ADDENDED
- +14 IF MSGTYP2="XX"
- IF MSGTYP3="CM"
- Begin DoDot:1
- +15 NEW GMRCN,GMRCTXT,GMRCCMP,GMRCASTR
- +16 DO AUTHDTTM
- +17 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|P|Progress Note"
- +18 SET GMRCN=$PIECE($GET(^GMR(123,GMRCDA,50,1,0)),U)
- IF GMRCN'["TIU(8925,"
- QUIT
- +19 DO TGET^TIUSRVR1(.GMRCTXT,$SELECT(+$GET(GMRCPARN):+GMRCPARN,+$GET(TIUDA):+TIUDA,1:+GMRCN),"VIEW")
- +20 ;line below modified in patch 106 to use GET1^DIQ call for date
- +21 SET GMRCCMP=$$DATE^GMRCCCRA($$GET1^DIQ(8925,+TIUDA_",",1301,"I"),"MM/DD/CCYY")_" ADDENDUM"_" STATUS: "_$$GET1^DIQ(8925,+TIUDA_",",.05)
- +22 SET (I,GMRCASTR)=0
- +23 FOR
- SET I=$ORDER(@GMRCTXT@(I))
- if I=""
- QUIT
- SET X=@GMRCTXT@(I)
- Begin DoDot:2
- +24 IF X=GMRCCMP
- SET GMRCASTR=I
- End DoDot:2
- +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 X=$$TIUC^GMRCCCR1(X)
- +31 SET ZCNT=ZCNT+1
- SET NTECNT=NTECNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- End DoDot:3
- End DoDot:2
- +32 ;clean up results of TIUSRVR1 call
- KILL ^TMP("TIUVIEW",$JOB)
- End DoDot:1
- QUIT
- +33 ;patch 146 - DONE flag used to determine if notes are found. If so, no need to drop to default
- +34 ;some cases of DR/CM combo have notes stored in level 50, some in level 40
- +35 ;both need to be accounted for
- +36 ;I MSGTYP3="CM" D Q ; pre-146
- +37 ; patch 146
- NEW DONE
- SET DONE=0
- +38 ; patch 146
- IF MSGTYP3="CM"
- Begin DoDot:1
- +39 NEW GMRCN,GMRCTXT
- +40 DO AUTHDTTM
- +41 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|P|Progress Note"
- +42 SET GMRCN=$PIECE($GET(^GMR(123,GMRCDA,50,1,0)),U)
- IF GMRCN'["TIU(8925,"
- QUIT
- +43 DO TGET^TIUSRVR1(.GMRCTXT,$SELECT(+$GET(TIUDA):+TIUDA,1:+GMRCN),"VIEW")
- SET I=0
- +44 FOR
- SET I=$ORDER(@GMRCTXT@(I))
- if I=""
- QUIT
- SET X=@GMRCTXT@(I)
- Begin DoDot:2
- +45 SET X=$$TRIM^XLFSTR(X)
- IF $LENGTH(X)=0
- QUIT
- +46 DO HL7TXT^GMRCHL7P(.X,.HL,"\")
- +47 SET X=$$TIUC^GMRCCCR1(X)
- +48 ; patch 146 - DONE
- SET ZCNT=ZCNT+1
- SET NTECNT=NTECNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- SET DONE=1
- +49 QUIT
- End DoDot:2
- +50 ;clean up results of TIUSRVR1 call
- KILL ^TMP("TIUVIEW",$JOB)
- +51 QUIT
- End DoDot:1
- if DONE
- QUIT
- +52 IF (MSGTYP2="DR")
- Begin DoDot:1
- +53 NEW ORIEN,CMT
- +54 DO AUTHDTTM
- +55 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|L|Activity Comment"
- +56 SET ORIEN=$GET(@GDATA@(.03,"I"))
- IF 'ORIEN
- QUIT
- +57 SET CMT=$$GET1^DIQ(100,ORIEN_",",64)
- +58 ;Patch 190 - PB if field 64 is null check field 65
- IF $GET(CMT)=""
- SET CMT=$$GET1^DIQ(100,ORIEN_",",65)
- +59 IF $GET(CMT)'=""
- SET CMT=$$TRIM^XLFSTR($GET(CMT))
- +60 SET CMT=$TRANSLATE($GET(CMT),$CHAR(13,10,10),$CHAR(10,10))
- +61 DO HL7TXT^GMRCHL7P(.CMT,.HL,"\")
- +62 ;Patch 190 - PB if the comment is null, don't call the control character screen API
- if $GET(CMT)'=""
- SET CMT=$$TIUC^GMRCCCR1(CMT)
- +63 SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|2||"_CMT
- +64 QUIT
- End DoDot:1
- QUIT
- +65 NEW ACT,ACTD,ACTIEN,Q,UPDATE81
- +66 SET UPDATE81=0
- +67 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
- +68 SET ACT=$PIECE(X,U,2)
- SET ACTD=$PIECE($PIECE($GET(^GMR(123.1,+ACT,0)),U)," ")
- +69 IF $PIECE($PIECE(STATUS,ECH,2)," ")'=ACTD
- QUIT
- +70 IF +$ORDER(^GMR(123,GMRCDA,40,ACTIEN,1,0))
- DO AUTHDTTM
- +71 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
- +72 IF 'Q
- SET ZCNT=ZCNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"|L|Activity Comment"
- SET Q=1
- +73 SET X=$$TRIM^XLFSTR(X)
- IF $LENGTH(X)=0
- QUIT
- +74 DO HL7TXT^GMRCHL7P(.X,.HL,"\")
- +75 SET X=$$TIUC^GMRCCCR1(X)
- +76 SET ZCNT=ZCNT+1
- SET NTECNT=NTECNT+1
- SET GMRCM(ZCNT)="NTE|"_NTECNT_"||"_X
- +77 ; patch 163 - PB if the edit is to change referral facility parse and update field 81, file 123
- IF $$UP^XLFSTR($GET(X))["EDIT REFERRAL FACILITY:"
- Begin DoDot:3
- +78 SET X=$TRANSLATE(X,$CHAR(10),"")
- +79 SET UPDATE81=$PIECE(X,": ",2)
- +80 if $GET(UPDATE81)=0
- QUIT
- +81 NEW FDA
- SET FDA(123,$GET(GMRCDA)_",",81)=$GET(UPDATE81)
- DO UPDATE^DIE(,"FDA",$GET(GMRCDA)_",","GMRCERR")
- End DoDot:3
- +82 QUIT
- End DoDot:2
- +83 QUIT
- End DoDot:1
- +84 QUIT
- AUTHDTTM ; Add Author and Date/Time to NTE
- +1 ; patch 146, for size
- DO AUTHDTTM^GMRCCCR1
- +2 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 ; patch 146, was "CM^COMPLETE", didn't match file 123.1 ; MJ
- IF T2="CM"
- QUIT "CM^COMPLETE/UPDATE"
- +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 ;*99 - PB - Mar 5, 2018
- IF $$UP^XLFSTR($$GET1^DIQ(123.5,FEESVC,.01,"E"))["COMMUNITY CARE"
- SET VAL=1
- +6 ;*99 - PB - Mar 5, 2018
- IF $$UP^XLFSTR($$GET1^DIQ(123.5,FEESVC,.01,"E"))["DOD TREATMENT"
- SET VAL=1
- +7 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 ;N DFN S DFN=$$GET1^DIQ(123,GMRCDA,.02,"I") I 'DFN,'$D(^DPT(DFN)) Q ; modified "," to "!" within patch 106
- +4 NEW DFN
- SET DFN=+$$GET1^DIQ(123,GMRCDA,.02,"I")
- IF 'DFN!('$DATA(^DPT(DFN)))
- QUIT
- +5 NEW T
- SET T(1)="MSH|^~\&|CONSULTS||||||ORM"
- +6 SET T(2)="PID|||"_DFN
- +7 SET T(4)="ORC|XX|"_$$GET1^DIQ(123,GMRCDA,.03,"I")_";"_$$OITEM($$GET1^DIQ(123,GMRCDA,.03,"I"))_"^OR|"_GMRCDA_";GMRC^GMRC||XX|"
- +8 DO EN(.T)
- +9 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 ; patch 146, needed for space ; MJ
- SET GMRCO=$$ADDEND^GMRCCCR1
- if 'GMRCO
- QUIT
- +6 SET T(1)="MSH|^~\&|CONSULTS||||||ORM"
- +7 SET T(2)="PID|||"_DFN
- +8 SET T(4)="ORC|XX|"_$$GET1^DIQ(123,GMRCO,.03,"I")_";"_$$OITEM($$GET1^DIQ(123,GMRCO,.03,"I"))_"^OR|"_GMRCO_";GMRC^GMRC||CM|"
- +9 IF $$FEE($$GET1^DIQ(123,GMRCO,1,"I"))
- DO EN(.T)
- +10 QUIT
- TIME(X,FMT) ; Copied from $$TIME^TIULS
- +1 ; Receives X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
- +2 NEW HR,MIN,SEC,TIUI
- +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 TIUI="HR","MIN","SEC"
- if FMT[TIUI
- SET FMT=$PIECE(FMT,TIUI)_@TIUI_$PIECE(FMT,TIUI,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,TIUI,TIUTMP
- +3 IF +X'>0
- SET $PIECE(TIUTMP," ",$LENGTH($GET(FMT))+1)=""
- SET FMT=TIUTMP
- 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 TIUI="AMTH","MM","DD","CC","YY"
- if FMT[TIUI
- SET FMT=$PIECE(FMT,TIUI)_@TIUI_$PIECE(FMT,TIUI,2)
- +8 IF FMT["HR"
- SET FMT=$$TIME(X,FMT)
- QDATE QUIT FMT
- OITEM(GMRCORDN) ; Orderable Item
- +1 ; patch 106 - modified to use ICR 2467
- +2 ;,GMRCOITM
- NEW RETVAL
- +3 SET RETVAL=1
- +4 SET RETVAL=+$$OI^ORX8(GMRCORDN)
- +5 IF 'RETVAL
- SET RETVAL=1
- +6 ;end patch 106 mods
- +7 QUIT RETVAL
- ACK ; Process ACK HL7 messages
- +1 ; patch 146, moved for space
- DO ACK^GMRCCCR1
- +2 QUIT
- MESSAGE(MSGID,ERRARY) ; Send a MailMan Message with the errors
- +1 DO MESSAGE^GMRCCCR1(MSGID,.ERRARY)
- +2 QUIT