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 Oct 16, 2024@17:46:07 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
