GMRCIACT ;SLC/JFR - PROCESS ACTIONS ON IFC ; Aug 01, 2024@15:38:22
;;3.0;CONSULT/REQUEST TRACKING;**22,47,58,66,73,121,154,176,184,193,185,189**;DEC 27, 1997;Build 54
;
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to $$FIND1^DIC in ICR #2051
; Reference to ^DIE in ICR #2053
; Reference to ^HLMA1 in ICR #2165
; Reference to ^MPIF001 in ICR #2701
; Reference to ^XLFDT in ICR #10103
; Reference to ^XLFNAME in ICR #3065
; Reference to ^XUAF4 in ICR #2171
; Reference to ^XLFSTR in ICR #10104
; Reference to $$ADD^DGPROSAD in ICR #7421
; Reference to APPERROR^%ZTER in ICR #1621
;
Q ;don't start here!
NW(ARRAY) ;process and file new order
;Input:
; ARRAY = name of array containing message parts
;
N GMRCFDA,GMRCORC,GMRCDA,GMRCITM,GMRCITER,GMRCROUT,GMRCFCN,GMRCLAC,OBR19 ;
K ^TMP("GMRCIN",$J)
M ^TMP("GMRCIN",$J)=@ARRAY
S GMRCORC=^TMP("GMRCIN",$J,"ORC")
D I $D(GMRCITER) Q ;Check for order already being on file
. S GMRCFCN=+$P(GMRCORC,"|",2)
. S GMRCROUT=$$IEN^XUAF4($P($P(GMRCORC,"|",2),U,2))
. I '$O(^GMR(123,"AIFC",GMRCROUT,GMRCFCN,0)) Q ;no dup
. S GMRCITER=802
. S GMRCCRNR=$G(GMRCCRNR),GMRCMSGI=$G(GMRCMSGI) D APPACK^GMRCIAC2(0,"AR",GMRCITER,GMRCCRNR,GMRCMSGI) ;send app. ack w/ error ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
. K ^TMP("GMRCIN",$J) Q
I '$D(^TMP("GMRCIN",$J,"PID")) Q ;prepare reject message (no PID)
D ;get patient DFN from ICN in message
. N PAT,CRNRACCT ; p184
. S PAT=$$GETDFN^MPIF001(+$P(^TMP("GMRCIN",$J,"PID"),"|",2))
. I +PAT'>1 S GMRCFDA(.02)="" Q
. S GMRCFDA(.02)=+PAT
;
; Save patient account number in field #502. Below code shifted out of patient lookup so CRNRACCT set whether patient found or not. Needed for proxy add code. p189
;
S CRNRACCT=$P(^TMP("GMRCIN",$J,"PID"),"|",18),GMRCFDA(502)=CRNRACCT ; p184, 189
;
; Save ordering provider data and placer field 1 from OBR-16 and OBR-19 in fields #507 and 508
;
I $D(^TMP("GMRCIN",$J,"OBR")) D ; P184, 189
. N OBR16 S OBR16=$P(^("OBR"),"|",16),GMRCFDA(507)=$E(OBR16,1,255) ;
. S OBR19=$P(^("OBR"),"|",19),GMRCFDA(508)=$E(OBR19,1,255) ; 184V10 WTC 6/28/2022
. N OBR20 S OBR20=$P(^("OBR"),"|",20) I OBR20'="" S GMRCFDA(511)=$E(OBR20,1) ; 185V2 WTC 4/24/2023
. N OBR27 S OBR27=$P($P(^("OBR"),"|",27),U,4) I OBR27'="" S GMRCFDA(512)=$E(OBR27,1,30) ; 185V2 WTC 4/24/2023
;
; If patient not found and placer is Cerner, call proxy add to create patient. p189 wtc 4/12/2023
;
I '$G(GMRCFDA(.02)),$G(CRNRACCT)'="" D ;
. ;
. ; Extract EDIPI from PID-3.
. ;
. N EDIPI,RTNCODE,PIECE ;
. S EDIPI="" F PIECE=1:1 Q:$P($P(^TMP("GMRCIN",$J,"PID"),"|",3),"~",PIECE)="" I $P($P($P(^TMP("GMRCIN",$J,"PID"),"|",3),"~",PIECE),U,4)="EDIPI" S EDIPI=$P($P($P(^TMP("GMRCIN",$J,"PID"),"|",3),"~",PIECE),U,1) Q ;
. Q:EDIPI="" ;
. ;
. ; Call proxy add. If successful, save DFN. Otherwise, allow 201 error to be generated.
. ;
. S RTNCODE=$$ADD^DGPROSAD(EDIPI_"~USDOD~NI~200DOD",$P($$SITE^VASITE(),U,3)) ; ICR 7421
. I RTNCODE<0 D FAILPRXY^GMRCIUT1(GMRCMSGI,EDIPI,"",GMRCFCN,OBR19,$P(GMRCORC,"|",15),$P($$SITE^VASITE(),U,3),$P(RTNCODE,U,2)) Q ; P189 WTC 6/24/24
. S GMRCFDA(.02)=$P(RTNCODE,U,4) ;
;
I '$G(GMRCFDA(.02)) D Q ;reject message, patient is unknown
. N STA S STA=$P($P(^TMP("GMRCIN",$J,"ORC"),"|",2),U,2)
. N OBR S OBR=^TMP("GMRCIN",$J,"OBR")
. D PTERRMSG^GMRCIERR(^TMP("GMRCIN",$J,"PID"),STA,,OBR)
. S GMRCCRNR=$G(GMRCCRNR),GMRCMSGI=$G(GMRCMSGI) D APPACK^GMRCIAC2(0,"AR",201,GMRCCRNR,GMRCMSGI) ; send app. ack w/error ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
. K ^TMP("GMRCIN",$J) Q
D ;get ordered item and service
. S GMRCITM=$P(^TMP("GMRCIN",$J,"OBR"),"|",4)
. I GMRCITM["VA1233" D ; proc
.. N PROC
.. S PROC=$$GETPROC^GMRCIUTL(GMRCITM)
.. I +PROC'>0!('$P(PROC,U,2)) S GMRCITER=$P(PROC,U,3) Q
.. S GMRCFDA(4)=$P(PROC,U)_";GMR(123.3,"
.. S GMRCFDA(1)=$P(PROC,U,2)
. I GMRCITM["VA1235" D
.. N SERV
.. S SERV=$$GETSERV^GMRCIUTL(GMRCITM) ;consult
.. I +SERV'>0 S GMRCITER=$P(SERV,U,3)
.. S GMRCFDA(1)=SERV
I $D(GMRCITER) D Q ;error in procedure or service, reject new order
. S GMRCCRNR=$G(GMRCCRNR),GMRCMSGI=$G(GMRCMSGI) D APPACK^GMRCIAC2(0,"AR",GMRCITER,GMRCCRNR,GMRCMSGI) ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
. K ^TMP("GMRCIN",$J) Q
;
S GMRCFDA(.01)=$$NOW^XLFDT
S GMRCFDA(3)=$$HL7TFM^XLFDT($P(GMRCORC,"|",15))
S GMRCFDA(6)=$$FIND1^DIC(101,"","X","GMRCPLACE - ON CALL")
S GMRCFDA(17)=$$HL7TFM^XLFDT($P($P(GMRCORC,"|",7),U,4)) ;WAT/66 Earliest Date
D ;get urgency to file
. N URG
. S URG=$$URG^GMRCHL7A($P($P(GMRCORC,"|",7),U,6))
. I GMRCCRNR,URG="STAT" S URG="NEXT AVAILABLE" ;MKN *176
. S GMRCFDA(5)=$$FIND1^DIC(101,"","X","GMRCURGENCY - "_URG)
S GMRCFDA(8)=5
S GMRCFDA(9)=$S($P(GMRCORC,"|",16)["FI":24,1:23),GMRCLAC=GMRCFDA(9)
S GMRCFDA(14)=$P(^TMP("GMRCIN",$J,"OBR"),"|",18)
S GMRCFDA(.05)=$$IEN^XUAF4(+$P(GMRCORC,"|",17))
S GMRCFDA(.06)=GMRCFCN
S GMRCFDA(.07)=GMRCROUT
D ;get and set ordering prov info & entering person info
. N GMRCOP
. S GMRCOP=$$FMNAME^XLFNAME($P(GMRCORC,"|",12))
. Q:'$L(GMRCOP)
. S GMRCFDA(.126)=GMRCOP
. Q
S GMRCFDA(.125)="F"
I $L($P(GMRCORC,"|",14)) D
. N GMRCP14 S GMRCP14=$P(GMRCORC,"|",14)
. S GMRCFDA(.132)=$P(GMRCP14,"B") ; requestor's phone number
. S GMRCFDA(.133)=$P(GMRCP14,"B",2) ; requestor's dig pager
S GMRCFDA(13)=$S($D(GMRCFDA(4)):"P",1:"C")
I $D(^TMP("GMRCIN",$J,"OBX",2)) D
. N GMRCCSYS,CODINTXT
. S GMRCFDA(30)=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U,2)
. S GMRCFDA(30.1)=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U)
. S GMRCFDA(30.2)=$$HL7TFM^XLFDT($P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",14),U)) ;date OBX-14 WAT/73
. S GMRCCSYS=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U,3) ;code system WAT/73
. S GMRCCSYS=$S($G(GMRCCSYS)="I9C":"ICD",1:"10D")
. S GMRCFDA(30.3)=GMRCCSYS
. I $D(GMRCFDA(30.1)) D ;if dx code exists, ensure that code is removed from dx text
.. S CODINTXT="("_GMRCFDA(30.1)_")"
.. I GMRCFDA(30)[CODINTXT D
... S GMRCFDA(30)=$E(GMRCFDA(30),0,($L(GMRCFDA(30))-$L(CODINTXT)))
... S GMRCFDA(30)=$$TRIM^XLFSTR(GMRCFDA(30),"R")
;
;BL;121;Adding UCID to FILE #123 FIELD 80
;check for NTE segment
I $D(^TMP("GMRCIN",$J,"NTE")) D
. N NODE,UCIDNODE
. S NODE=0
. F S NODE=$O(^TMP("GMRCIN",$J,"NTE",NODE)) Q:NODE="" D
. . S UCIDNODE=$P(^TMP("GMRCIN",$J,"NTE",NODE),"|",2)
. . S:UCIDNODE["UCID:" GMRCFDA(80)=$P(UCIDNODE,"UCID:",2)
;
M FDA(1,123,"+1,")=GMRCFDA
D UPDATE^DIE("","FDA(1)","GMRCDA","GMRCERR")
I '$D(GMRCDA) D Q ;couldn't get new consult #
. S GMRCCRNR=$G(GMRCCRNR),GMRCMSGI=$G(GMRCMSGI) D APPACK^GMRCIAC2(0,"AR",901,GMRCCRNR,GMRCMSGI) ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
. K ^TMP("GMRCIN",$J) Q
K GMRCFDA,FDA
D ; file reason for request
. D TRIMWP^GMRCIUTL($NA(^TMP("GMRCIN",$J,"OBX",1)),5)
. D WP^DIE(123,GMRCDA(1)_",",20,"K",$NA(^TMP("GMRCIN",$J,"OBX",1)))
. Q
D ;file activity tracking
. N GMRCSEG
. S GMRCSEG("ORC")=GMRCORC
. S GMRCSEG("OBX",5,1)=^TMP("GMRCIN",$J,"OBX",5,1)
. D FILEACT^GMRCIAC2(GMRCDA(1),GMRCLAC,,"GMRCSEG",$G(GMRCCRNR),$G(GMRCROUT)) ; P184
D ;print SF-513
. I GMRCLAC=24 Q ;don't print if part of a FWD to IFC
. D PRNT^GMRCUTL1("",GMRCDA(1))
D ;send notifications
. I GMRCLAC=24 Q ;no alerts yet if part of FWD to IFC
. N GMRCORTX
. S GMRCORTX="New remotely ordered consult "_$$ORTX^GMRCAU(+GMRCDA(1))
. D MSG^GMRCP($P(^GMR(123,GMRCDA(1),0),U,2),GMRCORTX,GMRCDA(1),27,,1)
D ;send appl ack :-(
. N GMRCRSLT
. D RESP^GMRCIUTL("AA",HL("MID"),$P(GMRCORC,"|"),GMRCDA(1))
. D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
K ^TMP("GMRCIN",$J) Q:'GMRCCRNR ;
;
; Check if patient exists on converted VistA. If not, add the entry. p189 wtc 6/24/24
;
N RTNCODE,SITE,STA ;
S SITE=$P(^GMR(123,GMRCDA(1),0),U,23) Q:'SITE ;no ROUTING FACILITY
S STA=$$STA^XUAF4(SITE) I '$L(STA) Q ;can't find station num for that site
S RTNCODE=$$CHKPROXY^GMRCIUT1(GMRCDA(1),$P(^GMR(123,GMRCDA(1),0),U,2),STA,1) ;
Q
;
DIS(GMRCAR,GMRCCRNR,GMRCMSGI) ;dis-associate a result from a remote request ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
;Input:
; GMRCAR = array name containing message
; e.g. ^TMP("GMRCIF",$J)
; GMRCCRNR = 1 if message came from Cerner
; GMRCMSGI = message ID
;
K ^TMP("GMRCID",$J) ;p193
N GMRCDA,GMRCFDA,FDA,GMRCERR,GMRCORC
M ^TMP("GMRCID",$J)=@GMRCAR
S GMRCORC=^TMP("GMRCID",$J,"ORC")
S GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)
S GMRCCRNR=$G(GMRCCRNR,0),GMRCMSGI=$G(GMRCMSGI) ;MKN GMRC*3*154
I '$$LOCKREC^GMRCUTL1(GMRCDA) D Q ;couldn't lock record
. D APPACK^GMRCIAC2(GMRCDA,"AR",901,GMRCCRNR,GMRCMSGI) ;send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
. K ^TMP("GMRCID",$J) Q
; v--check to see if a dup transmission
I $$DUPACT^GMRCIAC2(GMRCDA,12,GMRCORC,^TMP("GMRCID",$J,"OBX",4,1),GMRCCRNR,GMRCMSGI) K ^TMP("GMRCID",$J) Q ;MKN GMRC*3*154 added CRNR and MSGI ;p193
;
D FILEACT^GMRCIAC2(GMRCDA,12,,$NA(^TMP("GMRCID",$J)),$G(GMRCCRNR),$$GET1^DIQ(123,GMRCDA,.07,"I")) ; act. tracking ; P184
D FILRES^GMRCIAC2(GMRCDA,^TMP("GMRCID",$J,"OBX",4,1)) ;file results
K GMRCERR,FDA,GMRCFDA
I $$STSCHG^GMRCDIS(GMRCDA) S FDA(1,123,GMRCDA_",",8)=6
S FDA(1,123,GMRCDA_",",9)=12
D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file last action and status
D ;send notifications
. I $P(^GMR(123,GMRCDA,12),U,5)="F" Q ;DIS from placer before IFC
. N GMRCORTX
. S GMRCORTX="Remote result removed from "_$$ORTX^GMRCAU(+GMRCDA)
. D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCORTX,GMRCDA,63,,1)
D ;send appl ACK
. D APPACK^GMRCIAC2(GMRCDA,"AA") ; send app. ACK and unlock record
K ^TMP("GMRCID",$J)
Q
;
OTHER(GMRCAR,GMRCCRNR,GMRCMSGI) ;process most IFC actions
;will process the receive, schedule, DC, cancel and added comment action
;
;Input:
; GMRCAR = array name containing message
; e.g. ^TMP("GMRCIF",$J)
; GMRCCRNR = 1 if message came from Cerner
; GMRCMSGI = message ID
;
N GMRCDA,GMRCFDA,GMRCORC,GMRCLAT,GMRCACT,GMRCROL,FDA
K ^TMP("GMRCIN",$J)
M ^TMP("GMRCIN",$J)=@GMRCAR
;
S GMRCORC=^TMP("GMRCIN",$J,"ORC")
S GMRCDA=$$GETDA^GMRCIAC2(GMRCORC) ;get ien to work on
S GMRCROL=$P(^GMR(123,GMRCDA,12),U,5)
S GMRCCRNR=$G(GMRCCRNR,0),GMRCMSGI=$G(GMRCMSGI) ;MKN GMRC*3*154
I '$$LOCKREC^GMRCUTL1(GMRCDA) D Q ;couldn't lock record
. D APPACK^GMRCIAC2(GMRCDA,"AR",901,GMRCCRNR,GMRCMSGI) ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
. K ^TMP("GMRCIN",$J) Q
;
I $P(GMRCORC,"|")'="IP" D ; status update
. N GMRCOS S GMRCOS=$P(GMRCORC,"|",5)
. S GMRCFDA(8)=$S(GMRCOS="IP":6,GMRCOS="SC":8,GMRCOS="CA":13,1:1)
. ; IP=receive, SC=schedule, CA=cancel, DC=discontinue
D ; get last action taken
. I '$G(GMRCFDA(8)) S (GMRCFDA(9),GMRCLAT)=20 Q
. I GMRCFDA(8)=6 S (GMRCFDA(9),GMRCLAT)=21 Q
. I GMRCFDA(8)=8 S (GMRCFDA(9),GMRCLAT)=8 Q
. I GMRCFDA(8)=1 S (GMRCFDA(9),GMRCLAT)=6 Q
. I GMRCFDA(8)=13 S (GMRCFDA(9),GMRCLAT)=19 Q
; ^--last action taken
; v-- check to see if a dup transmission
I $$DUPACT^GMRCIAC2(GMRCDA,GMRCLAT,GMRCORC,,GMRCCRNR,GMRCMSGI) K ^TMP("GMRCIN",$J) Q ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI ;p193
;
M FDA(1,123,GMRCDA_",")=GMRCFDA
D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file last action and update status
K GMRCFDA
D FILEACT^GMRCIAC2(GMRCDA,GMRCLAT,,$NA(^TMP("GMRCIN",$J)),$G(GMRCCRNR),$$GET1^DIQ(123,GMRCDA,.07,"I")) ; P184
D ;send notifications
. N GMRCTX,GMRCNOT,GMRCFL
. S GMRCFL=1
. I GMRCLAT=20!(GMRCLAT=8)!(GMRCLAT=21) D
.. I GMRCLAT=20 D I '$D(GMRCTX) Q
... I $P(^GMR(123,GMRCDA,40,1,0),U,2)'=24 D Q
.... S GMRCTX="Comment Added to remote"
... N ACT S ACT=1
... F S ACT=$O(^GMR(123,GMRCDA,40,ACT)) Q:'ACT!($D(GMRCTX)) D
.... I $P(^GMR(123,GMRCDA,40,ACT,0),U,2)=25,$O(^GMR(123,GMRCDA,40,ACT)) D
..... S GMRCTX="Comment Added to remote"
.. I '$D(GMRCTX),GMRCROL="F" Q ;sch & rec on filler part of FWD 2 IFC
.. I GMRCLAT=8 S GMRCTX="Scheduled remote"
.. I GMRCLAT=21 S GMRCTX="Received remote"
.. S GMRCTX=GMRCTX_" Consult: "_$$ORTX^GMRCAU(+GMRCDA)
.. S GMRCNOT=63
. I GMRCLAT=6 D
.. S GMRCFL=$$DCNOTE^GMRCADC(GMRCDA,.5)
.. S GMRCTX="Discontinued remote Consult: "_$$ORTX^GMRCAU(+GMRCDA)
.. S GMRCNOT=23
. I GMRCLAT=19 D
.. I GMRCROL="F" Q ;canc on a filler is part of FWD 2 IFC
.. S GMRCTX="Cancelled remote Consult: "_$$ORTX^GMRCAU(+GMRCDA)
.. S GMRCNOT=30
. I '$D(GMRCNOT) Q ;don't send any alerts
. D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCTX,GMRCDA,GMRCNOT,,GMRCFL)
;
D ;send appl ACK
. D APPACK^GMRCIAC2(GMRCDA,"AA") ;send app. ACK and unlock record
K ^TMP("GMRCIN",$J)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIACT 12806 printed Dec 13, 2024@01:45:55 Page 2
GMRCIACT ;SLC/JFR - PROCESS ACTIONS ON IFC ; Aug 01, 2024@15:38:22
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,47,58,66,73,121,154,176,184,193,185,189**;DEC 27, 1997;Build 54
+2 ;
+3 ;;Per VHA Directive 2004-038, this routine should not be modified.
+4 ;
+5 ; Reference to $$FIND1^DIC in ICR #2051
+6 ; Reference to ^DIE in ICR #2053
+7 ; Reference to ^HLMA1 in ICR #2165
+8 ; Reference to ^MPIF001 in ICR #2701
+9 ; Reference to ^XLFDT in ICR #10103
+10 ; Reference to ^XLFNAME in ICR #3065
+11 ; Reference to ^XUAF4 in ICR #2171
+12 ; Reference to ^XLFSTR in ICR #10104
+13 ; Reference to $$ADD^DGPROSAD in ICR #7421
+14 ; Reference to APPERROR^%ZTER in ICR #1621
+15 ;
+16 ;don't start here!
QUIT
NW(ARRAY) ;process and file new order
+1 ;Input:
+2 ; ARRAY = name of array containing message parts
+3 ;
+4 ;
NEW GMRCFDA,GMRCORC,GMRCDA,GMRCITM,GMRCITER,GMRCROUT,GMRCFCN,GMRCLAC,OBR19
+5 KILL ^TMP("GMRCIN",$JOB)
+6 MERGE ^TMP("GMRCIN",$JOB)=@ARRAY
+7 SET GMRCORC=^TMP("GMRCIN",$JOB,"ORC")
+8 ;Check for order already being on file
Begin DoDot:1
+9 SET GMRCFCN=+$PIECE(GMRCORC,"|",2)
+10 SET GMRCROUT=$$IEN^XUAF4($PIECE($PIECE(GMRCORC,"|",2),U,2))
+11 ;no dup
IF '$ORDER(^GMR(123,"AIFC",GMRCROUT,GMRCFCN,0))
QUIT
+12 SET GMRCITER=802
+13 ;send app. ack w/ error ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
SET GMRCCRNR=$GET(GMRCCRNR)
SET GMRCMSGI=$GET(GMRCMSGI)
DO APPACK^GMRCIAC2(0,"AR",GMRCITER,GMRCCRNR,GMRCMSGI)
+14 KILL ^TMP("GMRCIN",$JOB)
QUIT
End DoDot:1
IF $DATA(GMRCITER)
QUIT
+15 ;prepare reject message (no PID)
IF '$DATA(^TMP("GMRCIN",$JOB,"PID"))
QUIT
+16 ;get patient DFN from ICN in message
Begin DoDot:1
+17 ; p184
NEW PAT,CRNRACCT
+18 SET PAT=$$GETDFN^MPIF001(+$PIECE(^TMP("GMRCIN",$JOB,"PID"),"|",2))
+19 IF +PAT'>1
SET GMRCFDA(.02)=""
QUIT
+20 SET GMRCFDA(.02)=+PAT
End DoDot:1
+21 ;
+22 ; Save patient account number in field #502. Below code shifted out of patient lookup so CRNRACCT set whether patient found or not. Needed for proxy add code. p189
+23 ;
+24 ; p184, 189
SET CRNRACCT=$PIECE(^TMP("GMRCIN",$JOB,"PID"),"|",18)
SET GMRCFDA(502)=CRNRACCT
+25 ;
+26 ; Save ordering provider data and placer field 1 from OBR-16 and OBR-19 in fields #507 and 508
+27 ;
+28 ; P184, 189
IF $DATA(^TMP("GMRCIN",$JOB,"OBR"))
Begin DoDot:1
+29 ;
NEW OBR16
SET OBR16=$PIECE(^("OBR"),"|",16)
SET GMRCFDA(507)=$EXTRACT(OBR16,1,255)
+30 ; 184V10 WTC 6/28/2022
SET OBR19=$PIECE(^("OBR"),"|",19)
SET GMRCFDA(508)=$EXTRACT(OBR19,1,255)
+31 ; 185V2 WTC 4/24/2023
NEW OBR20
SET OBR20=$PIECE(^("OBR"),"|",20)
IF OBR20'=""
SET GMRCFDA(511)=$EXTRACT(OBR20,1)
+32 ; 185V2 WTC 4/24/2023
NEW OBR27
SET OBR27=$PIECE($PIECE(^("OBR"),"|",27),U,4)
IF OBR27'=""
SET GMRCFDA(512)=$EXTRACT(OBR27,1,30)
End DoDot:1
+33 ;
+34 ; If patient not found and placer is Cerner, call proxy add to create patient. p189 wtc 4/12/2023
+35 ;
+36 ;
IF '$GET(GMRCFDA(.02))
IF $GET(CRNRACCT)'=""
Begin DoDot:1
+37 ;
+38 ; Extract EDIPI from PID-3.
+39 ;
+40 ;
NEW EDIPI,RTNCODE,PIECE
+41 ;
SET EDIPI=""
FOR PIECE=1:1
if $PIECE($PIECE(^TMP("GMRCIN",$JOB,"PID"),"|",3),"~",PIECE)=""
QUIT
IF $PIECE($PIECE($PIECE(^TMP("GMRCIN",$JOB,"PID"),"|",3),"~",PIECE),U,4)="EDIPI"
SET EDIPI=$PIECE($PIECE($PIECE(^TMP("GMRCIN",$JOB,"PID"),"|",3),"~",PIECE),U,1)
QUIT
+42 ;
if EDIPI=""
QUIT
+43 ;
+44 ; Call proxy add. If successful, save DFN. Otherwise, allow 201 error to be generated.
+45 ;
+46 ; ICR 7421
SET RTNCODE=$$ADD^DGPROSAD(EDIPI_"~USDOD~NI~200DOD",$PIECE($$SITE^VASITE(),U,3))
+47 ; P189 WTC 6/24/24
IF RTNCODE<0
DO FAILPRXY^GMRCIUT1(GMRCMSGI,EDIPI,"",GMRCFCN,OBR19,$PIECE(GMRCORC,"|",15),$PIECE($$SITE^VASITE(),U,3),$PIECE(RTNCODE,U,2))
QUIT
+48 ;
SET GMRCFDA(.02)=$PIECE(RTNCODE,U,4)
End DoDot:1
+49 ;
+50 ;reject message, patient is unknown
IF '$GET(GMRCFDA(.02))
Begin DoDot:1
+51 NEW STA
SET STA=$PIECE($PIECE(^TMP("GMRCIN",$JOB,"ORC"),"|",2),U,2)
+52 NEW OBR
SET OBR=^TMP("GMRCIN",$JOB,"OBR")
+53 DO PTERRMSG^GMRCIERR(^TMP("GMRCIN",$JOB,"PID"),STA,,OBR)
+54 ; send app. ack w/error ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
SET GMRCCRNR=$GET(GMRCCRNR)
SET GMRCMSGI=$GET(GMRCMSGI)
DO APPACK^GMRCIAC2(0,"AR",201,GMRCCRNR,GMRCMSGI)
+55 KILL ^TMP("GMRCIN",$JOB)
QUIT
End DoDot:1
QUIT
+56 ;get ordered item and service
Begin DoDot:1
+57 SET GMRCITM=$PIECE(^TMP("GMRCIN",$JOB,"OBR"),"|",4)
+58 ; proc
IF GMRCITM["VA1233"
Begin DoDot:2
+59 NEW PROC
+60 SET PROC=$$GETPROC^GMRCIUTL(GMRCITM)
+61 IF +PROC'>0!('$PIECE(PROC,U,2))
SET GMRCITER=$PIECE(PROC,U,3)
QUIT
+62 SET GMRCFDA(4)=$PIECE(PROC,U)_";GMR(123.3,"
+63 SET GMRCFDA(1)=$PIECE(PROC,U,2)
End DoDot:2
+64 IF GMRCITM["VA1235"
Begin DoDot:2
+65 NEW SERV
+66 ;consult
SET SERV=$$GETSERV^GMRCIUTL(GMRCITM)
+67 IF +SERV'>0
SET GMRCITER=$PIECE(SERV,U,3)
+68 SET GMRCFDA(1)=SERV
End DoDot:2
End DoDot:1
+69 ;error in procedure or service, reject new order
IF $DATA(GMRCITER)
Begin DoDot:1
+70 ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
SET GMRCCRNR=$GET(GMRCCRNR)
SET GMRCMSGI=$GET(GMRCMSGI)
DO APPACK^GMRCIAC2(0,"AR",GMRCITER,GMRCCRNR,GMRCMSGI)
+71 KILL ^TMP("GMRCIN",$JOB)
QUIT
End DoDot:1
QUIT
+72 ;
+73 SET GMRCFDA(.01)=$$NOW^XLFDT
+74 SET GMRCFDA(3)=$$HL7TFM^XLFDT($PIECE(GMRCORC,"|",15))
+75 SET GMRCFDA(6)=$$FIND1^DIC(101,"","X","GMRCPLACE - ON CALL")
+76 ;WAT/66 Earliest Date
SET GMRCFDA(17)=$$HL7TFM^XLFDT($PIECE($PIECE(GMRCORC,"|",7),U,4))
+77 ;get urgency to file
Begin DoDot:1
+78 NEW URG
+79 SET URG=$$URG^GMRCHL7A($PIECE($PIECE(GMRCORC,"|",7),U,6))
+80 ;MKN *176
IF GMRCCRNR
IF URG="STAT"
SET URG="NEXT AVAILABLE"
+81 SET GMRCFDA(5)=$$FIND1^DIC(101,"","X","GMRCURGENCY - "_URG)
End DoDot:1
+82 SET GMRCFDA(8)=5
+83 SET GMRCFDA(9)=$SELECT($PIECE(GMRCORC,"|",16)["FI":24,1:23)
SET GMRCLAC=GMRCFDA(9)
+84 SET GMRCFDA(14)=$PIECE(^TMP("GMRCIN",$JOB,"OBR"),"|",18)
+85 SET GMRCFDA(.05)=$$IEN^XUAF4(+$PIECE(GMRCORC,"|",17))
+86 SET GMRCFDA(.06)=GMRCFCN
+87 SET GMRCFDA(.07)=GMRCROUT
+88 ;get and set ordering prov info & entering person info
Begin DoDot:1
+89 NEW GMRCOP
+90 SET GMRCOP=$$FMNAME^XLFNAME($PIECE(GMRCORC,"|",12))
+91 if '$LENGTH(GMRCOP)
QUIT
+92 SET GMRCFDA(.126)=GMRCOP
+93 QUIT
End DoDot:1
+94 SET GMRCFDA(.125)="F"
+95 IF $LENGTH($PIECE(GMRCORC,"|",14))
Begin DoDot:1
+96 NEW GMRCP14
SET GMRCP14=$PIECE(GMRCORC,"|",14)
+97 ; requestor's phone number
SET GMRCFDA(.132)=$PIECE(GMRCP14,"B")
+98 ; requestor's dig pager
SET GMRCFDA(.133)=$PIECE(GMRCP14,"B",2)
End DoDot:1
+99 SET GMRCFDA(13)=$SELECT($DATA(GMRCFDA(4)):"P",1:"C")
+100 IF $DATA(^TMP("GMRCIN",$JOB,"OBX",2))
Begin DoDot:1
+101 NEW GMRCCSYS,CODINTXT
+102 SET GMRCFDA(30)=$PIECE($PIECE(^TMP("GMRCIN",$JOB,"OBX",2,1),"|",5),U,2)
+103 SET GMRCFDA(30.1)=$PIECE($PIECE(^TMP("GMRCIN",$JOB,"OBX",2,1),"|",5),U)
+104 ;date OBX-14 WAT/73
SET GMRCFDA(30.2)=$$HL7TFM^XLFDT($PIECE($PIECE(^TMP("GMRCIN",$JOB,"OBX",2,1),"|",14),U))
+105 ;code system WAT/73
SET GMRCCSYS=$PIECE($PIECE(^TMP("GMRCIN",$JOB,"OBX",2,1),"|",5),U,3)
+106 SET GMRCCSYS=$SELECT($GET(GMRCCSYS)="I9C":"ICD",1:"10D")
+107 SET GMRCFDA(30.3)=GMRCCSYS
+108 ;if dx code exists, ensure that code is removed from dx text
IF $DATA(GMRCFDA(30.1))
Begin DoDot:2
+109 SET CODINTXT="("_GMRCFDA(30.1)_")"
+110 IF GMRCFDA(30)[CODINTXT
Begin DoDot:3
+111 SET GMRCFDA(30)=$EXTRACT(GMRCFDA(30),0,($LENGTH(GMRCFDA(30))-$LENGTH(CODINTXT)))
+112 SET GMRCFDA(30)=$$TRIM^XLFSTR(GMRCFDA(30),"R")
End DoDot:3
End DoDot:2
End DoDot:1
+113 ;
+114 ;BL;121;Adding UCID to FILE #123 FIELD 80
+115 ;check for NTE segment
+116 IF $DATA(^TMP("GMRCIN",$JOB,"NTE"))
Begin DoDot:1
+117 NEW NODE,UCIDNODE
+118 SET NODE=0
+119 FOR
SET NODE=$ORDER(^TMP("GMRCIN",$JOB,"NTE",NODE))
if NODE=""
QUIT
Begin DoDot:2
+120 SET UCIDNODE=$PIECE(^TMP("GMRCIN",$JOB,"NTE",NODE),"|",2)
+121 if UCIDNODE["UCID
SET GMRCFDA(80)=$PIECE(UCIDNODE,"UCID:",2)
End DoDot:2
End DoDot:1
+122 ;
+123 MERGE FDA(1,123,"+1,")=GMRCFDA
+124 DO UPDATE^DIE("","FDA(1)","GMRCDA","GMRCERR")
+125 ;couldn't get new consult #
IF '$DATA(GMRCDA)
Begin DoDot:1
+126 ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
SET GMRCCRNR=$GET(GMRCCRNR)
SET GMRCMSGI=$GET(GMRCMSGI)
DO APPACK^GMRCIAC2(0,"AR",901,GMRCCRNR,GMRCMSGI)
+127 KILL ^TMP("GMRCIN",$JOB)
QUIT
End DoDot:1
QUIT
+128 KILL GMRCFDA,FDA
+129 ; file reason for request
Begin DoDot:1
+130 DO TRIMWP^GMRCIUTL($NAME(^TMP("GMRCIN",$JOB,"OBX",1)),5)
+131 DO WP^DIE(123,GMRCDA(1)_",",20,"K",$NAME(^TMP("GMRCIN",$JOB,"OBX",1)))
+132 QUIT
End DoDot:1
+133 ;file activity tracking
Begin DoDot:1
+134 NEW GMRCSEG
+135 SET GMRCSEG("ORC")=GMRCORC
+136 SET GMRCSEG("OBX",5,1)=^TMP("GMRCIN",$JOB,"OBX",5,1)
+137 ; P184
DO FILEACT^GMRCIAC2(GMRCDA(1),GMRCLAC,,"GMRCSEG",$GET(GMRCCRNR),$GET(GMRCROUT))
End DoDot:1
+138 ;print SF-513
Begin DoDot:1
+139 ;don't print if part of a FWD to IFC
IF GMRCLAC=24
QUIT
+140 DO PRNT^GMRCUTL1("",GMRCDA(1))
End DoDot:1
+141 ;send notifications
Begin DoDot:1
+142 ;no alerts yet if part of FWD to IFC
IF GMRCLAC=24
QUIT
+143 NEW GMRCORTX
+144 SET GMRCORTX="New remotely ordered consult "_$$ORTX^GMRCAU(+GMRCDA(1))
+145 DO MSG^GMRCP($PIECE(^GMR(123,GMRCDA(1),0),U,2),GMRCORTX,GMRCDA(1),27,,1)
End DoDot:1
+146 ;send appl ack :-(
Begin DoDot:1
+147 NEW GMRCRSLT
+148 DO RESP^GMRCIUTL("AA",HL("MID"),$PIECE(GMRCORC,"|"),GMRCDA(1))
+149 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
End DoDot:1
+150 ;
KILL ^TMP("GMRCIN",$JOB)
if 'GMRCCRNR
QUIT
+151 ;
+152 ; Check if patient exists on converted VistA. If not, add the entry. p189 wtc 6/24/24
+153 ;
+154 ;
NEW RTNCODE,SITE,STA
+155 ;no ROUTING FACILITY
SET SITE=$PIECE(^GMR(123,GMRCDA(1),0),U,23)
if 'SITE
QUIT
+156 ;can't find station num for that site
SET STA=$$STA^XUAF4(SITE)
IF '$LENGTH(STA)
QUIT
+157 ;
SET RTNCODE=$$CHKPROXY^GMRCIUT1(GMRCDA(1),$PIECE(^GMR(123,GMRCDA(1),0),U,2),STA,1)
+158 QUIT
+159 ;
DIS(GMRCAR,GMRCCRNR,GMRCMSGI) ;dis-associate a result from a remote request ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
+1 ;Input:
+2 ; GMRCAR = array name containing message
+3 ; e.g. ^TMP("GMRCIF",$J)
+4 ; GMRCCRNR = 1 if message came from Cerner
+5 ; GMRCMSGI = message ID
+6 ;
+7 ;p193
KILL ^TMP("GMRCID",$JOB)
+8 NEW GMRCDA,GMRCFDA,FDA,GMRCERR,GMRCORC
+9 MERGE ^TMP("GMRCID",$JOB)=@GMRCAR
+10 SET GMRCORC=^TMP("GMRCID",$JOB,"ORC")
+11 SET GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)
+12 ;MKN GMRC*3*154
SET GMRCCRNR=$GET(GMRCCRNR,0)
SET GMRCMSGI=$GET(GMRCMSGI)
+13 ;couldn't lock record
IF '$$LOCKREC^GMRCUTL1(GMRCDA)
Begin DoDot:1
+14 ;send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
DO APPACK^GMRCIAC2(GMRCDA,"AR",901,GMRCCRNR,GMRCMSGI)
+15 KILL ^TMP("GMRCID",$JOB)
QUIT
End DoDot:1
QUIT
+16 ; v--check to see if a dup transmission
+17 ;MKN GMRC*3*154 added CRNR and MSGI ;p193
IF $$DUPACT^GMRCIAC2(GMRCDA,12,GMRCORC,^TMP("GMRCID",$JOB,"OBX",4,1),GMRCCRNR,GMRCMSGI)
KILL ^TMP("GMRCID",$JOB)
QUIT
+18 ;
+19 ; act. tracking ; P184
DO FILEACT^GMRCIAC2(GMRCDA,12,,$NAME(^TMP("GMRCID",$JOB)),$GET(GMRCCRNR),$$GET1^DIQ(123,GMRCDA,.07,"I"))
+20 ;file results
DO FILRES^GMRCIAC2(GMRCDA,^TMP("GMRCID",$JOB,"OBX",4,1))
+21 KILL GMRCERR,FDA,GMRCFDA
+22 IF $$STSCHG^GMRCDIS(GMRCDA)
SET FDA(1,123,GMRCDA_",",8)=6
+23 SET FDA(1,123,GMRCDA_",",9)=12
+24 ;file last action and status
DO UPDATE^DIE("","FDA(1)",,"GMRCERR")
+25 ;send notifications
Begin DoDot:1
+26 ;DIS from placer before IFC
IF $PIECE(^GMR(123,GMRCDA,12),U,5)="F"
QUIT
+27 NEW GMRCORTX
+28 SET GMRCORTX="Remote result removed from "_$$ORTX^GMRCAU(+GMRCDA)
+29 DO MSG^GMRCP($PIECE(^GMR(123,GMRCDA,0),U,2),GMRCORTX,GMRCDA,63,,1)
End DoDot:1
+30 ;send appl ACK
Begin DoDot:1
+31 ; send app. ACK and unlock record
DO APPACK^GMRCIAC2(GMRCDA,"AA")
End DoDot:1
+32 KILL ^TMP("GMRCID",$JOB)
+33 QUIT
+34 ;
OTHER(GMRCAR,GMRCCRNR,GMRCMSGI) ;process most IFC actions
+1 ;will process the receive, schedule, DC, cancel and added comment action
+2 ;
+3 ;Input:
+4 ; GMRCAR = array name containing message
+5 ; e.g. ^TMP("GMRCIF",$J)
+6 ; GMRCCRNR = 1 if message came from Cerner
+7 ; GMRCMSGI = message ID
+8 ;
+9 NEW GMRCDA,GMRCFDA,GMRCORC,GMRCLAT,GMRCACT,GMRCROL,FDA
+10 KILL ^TMP("GMRCIN",$JOB)
+11 MERGE ^TMP("GMRCIN",$JOB)=@GMRCAR
+12 ;
+13 SET GMRCORC=^TMP("GMRCIN",$JOB,"ORC")
+14 ;get ien to work on
SET GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)
+15 SET GMRCROL=$PIECE(^GMR(123,GMRCDA,12),U,5)
+16 ;MKN GMRC*3*154
SET GMRCCRNR=$GET(GMRCCRNR,0)
SET GMRCMSGI=$GET(GMRCMSGI)
+17 ;couldn't lock record
IF '$$LOCKREC^GMRCUTL1(GMRCDA)
Begin DoDot:1
+18 ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
DO APPACK^GMRCIAC2(GMRCDA,"AR",901,GMRCCRNR,GMRCMSGI)
+19 KILL ^TMP("GMRCIN",$JOB)
QUIT
End DoDot:1
QUIT
+20 ;
+21 ; status update
IF $PIECE(GMRCORC,"|")'="IP"
Begin DoDot:1
+22 NEW GMRCOS
SET GMRCOS=$PIECE(GMRCORC,"|",5)
+23 SET GMRCFDA(8)=$SELECT(GMRCOS="IP":6,GMRCOS="SC":8,GMRCOS="CA":13,1:1)
+24 ; IP=receive, SC=schedule, CA=cancel, DC=discontinue
End DoDot:1
+25 ; get last action taken
Begin DoDot:1
+26 IF '$GET(GMRCFDA(8))
SET (GMRCFDA(9),GMRCLAT)=20
QUIT
+27 IF GMRCFDA(8)=6
SET (GMRCFDA(9),GMRCLAT)=21
QUIT
+28 IF GMRCFDA(8)=8
SET (GMRCFDA(9),GMRCLAT)=8
QUIT
+29 IF GMRCFDA(8)=1
SET (GMRCFDA(9),GMRCLAT)=6
QUIT
+30 IF GMRCFDA(8)=13
SET (GMRCFDA(9),GMRCLAT)=19
QUIT
End DoDot:1
+31 ; ^--last action taken
+32 ; v-- check to see if a dup transmission
+33 ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI ;p193
IF $$DUPACT^GMRCIAC2(GMRCDA,GMRCLAT,GMRCORC,,GMRCCRNR,GMRCMSGI)
KILL ^TMP("GMRCIN",$JOB)
QUIT
+34 ;
+35 MERGE FDA(1,123,GMRCDA_",")=GMRCFDA
+36 ;file last action and update status
DO UPDATE^DIE("","FDA(1)",,"GMRCERR")
+37 KILL GMRCFDA
+38 ; P184
DO FILEACT^GMRCIAC2(GMRCDA,GMRCLAT,,$NAME(^TMP("GMRCIN",$JOB)),$GET(GMRCCRNR),$$GET1^DIQ(123,GMRCDA,.07,"I"))
+39 ;send notifications
Begin DoDot:1
+40 NEW GMRCTX,GMRCNOT,GMRCFL
+41 SET GMRCFL=1
+42 IF GMRCLAT=20!(GMRCLAT=8)!(GMRCLAT=21)
Begin DoDot:2
+43 IF GMRCLAT=20
Begin DoDot:3
+44 IF $PIECE(^GMR(123,GMRCDA,40,1,0),U,2)'=24
Begin DoDot:4
+45 SET GMRCTX="Comment Added to remote"
End DoDot:4
QUIT
+46 NEW ACT
SET ACT=1
+47 FOR
SET ACT=$ORDER(^GMR(123,GMRCDA,40,ACT))
if 'ACT!($DATA(GMRCTX))
QUIT
Begin DoDot:4
+48 IF $PIECE(^GMR(123,GMRCDA,40,ACT,0),U,2)=25
IF $ORDER(^GMR(123,GMRCDA,40,ACT))
Begin DoDot:5
+49 SET GMRCTX="Comment Added to remote"
End DoDot:5
End DoDot:4
End DoDot:3
IF '$DATA(GMRCTX)
QUIT
+50 ;sch & rec on filler part of FWD 2 IFC
IF '$DATA(GMRCTX)
IF GMRCROL="F"
QUIT
+51 IF GMRCLAT=8
SET GMRCTX="Scheduled remote"
+52 IF GMRCLAT=21
SET GMRCTX="Received remote"
+53 SET GMRCTX=GMRCTX_" Consult: "_$$ORTX^GMRCAU(+GMRCDA)
+54 SET GMRCNOT=63
End DoDot:2
+55 IF GMRCLAT=6
Begin DoDot:2
+56 SET GMRCFL=$$DCNOTE^GMRCADC(GMRCDA,.5)
+57 SET GMRCTX="Discontinued remote Consult: "_$$ORTX^GMRCAU(+GMRCDA)
+58 SET GMRCNOT=23
End DoDot:2
+59 IF GMRCLAT=19
Begin DoDot:2
+60 ;canc on a filler is part of FWD 2 IFC
IF GMRCROL="F"
QUIT
+61 SET GMRCTX="Cancelled remote Consult: "_$$ORTX^GMRCAU(+GMRCDA)
+62 SET GMRCNOT=30
End DoDot:2
+63 ;don't send any alerts
IF '$DATA(GMRCNOT)
QUIT
+64 DO MSG^GMRCP($PIECE(^GMR(123,GMRCDA,0),U,2),GMRCTX,GMRCDA,GMRCNOT,,GMRCFL)
End DoDot:1
+65 ;
+66 ;send appl ACK
Begin DoDot:1
+67 ;send app. ACK and unlock record
DO APPACK^GMRCIAC2(GMRCDA,"AA")
End DoDot:1
+68 KILL ^TMP("GMRCIN",$JOB)
+69 QUIT
+70 ;
