GMRCIUT1 ;SLC/JFR - UTILITIES FOR INTER-FACILITY CONSULTS ; Jan 27, 2025@06:04:10
;;3.0;CONSULT/REQUEST TRACKING;**189,205**;DEC 27, 1997;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q ;don't start at the top
;
CHKPROXY(GMRCDA,GMRCDFN,STA,DONOTLOG) ;
;
; GMRCDA = Consult, pointer to #123
; GMRCDFN = Patient, pointer to #2
; STA = Routing station number
; DONOTLOG = Flag to prevent logging in IFC Message Log (#123.6). 1=DO NOT LOG. [OPTIONAL]
;
; Checks success/failure of proxy add. Returns 1 if all is OK and IFC can be sent, 0^REASON if not.
;
;pull patient Correlation list
;
N DGKEY,DGOUT,CNT,IDS,CERNERID,CONSULTDFN,RTNCODE,EDIPI ;
;
S DGKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$P($$SITE^VASITE,"^",3)
D TFL^VAFCTFU2(.DGOUT,DGKEY)
;
S CONSULTDFN="",CERNERID="" ;
S CNT=0 F S CNT=$O(DGOUT(CNT)) Q:'CNT S IDS=$G(DGOUT(CNT)) D ;
.I $P(IDS,"^",4)="200CRNR" I $P(IDS,"^",2)="PI" S CERNERID=IDS ;
.I $P(IDS,"^",4)=STA I $P(IDS,"^",2)="PI" I $P(IDS,"^",5)="A"!($P(IDS,"^",5)="C") S CONSULTDFN=IDS ;
;
; Destination site is converted.
;
I $$CRNRSITE^VAFCCRNR(STA)=1 D Q RTNCODE ;
. I CERNERID'="",CONSULTDFN'="" S RTNCODE=1 Q ;
. ;
. I CERNERID="" S RTNCODE="0^CERNER INCOMPLETE" Q ;
. ;
. I CONSULTDFN="" D Q ;
.. ;
.. ; Call proxy add for converted VistA.
.. ;
.. S EDIPI=$$EDIPI^GMRCIUTL(GMRCDFN) ;
.. S RTNCODE=$$ADD^DGPROSAD(EDIPI_"~USDOD~NI~200DOD",STA) ; ICR 7421
.. I RTNCODE<0 D ; Proxy add failed.
... I '$G(DONOTLOG) D LOGMSG^GMRCIUTL(GMRCDA,1,"",205) ;
... D FAILPRXY("",EDIPI,GMRCDA,"","","",STA,$P(RTNCODE,U,2)) ; P189 WTC 6/24/24
... S RTNCODE="0^CONVERTED VISTA INCOMPLETE" ;
.. Q:$G(DONOTLOG) ;
.. ;
.. ; Suppress 201 error if IFC already has a 203 error in the message log. wtc 11.22.23 p189
.. ;
.. N ACTIEN,SUPPRESS,LOGIEN S SUPPRESS=0,ACTIEN=0 F S ACTIEN=$O(^GMR(123.6,"AC",GMRCDA,ACTIEN)) Q:'ACTIEN D Q:SUPPRESS ;
... S LOGIEN=0 F S LOGIEN=$O(^GMR(123.6,"AC",GMRCDA,ACTIEN,1,LOGIEN)) Q:'LOGIEN I $P($G(^GMR(123.6,LOGIEN,0)),U,8)=203 S SUPPRESS=1 Q ;
.. ;
.. I 'SUPPRESS D LOGMSG^GMRCIUTL(GMRCDA,1,"",201) ;
;
; Destination site is non-converted.
;
I $$CRNRSITE^VAFCCRNR(STA)'=1 D Q RTNCODE ;
. I CONSULTDFN'="" S RTNCODE=1 Q ;
. ;
. S RTNCODE="0^NON-CONVERTED VISTA INCOMPLETE" ;
. D LOGMSG^GMRCIUTL(GMRCDA,1,"",201) ;
;
Q "0^UNKNOWN" ;
;
FAILPRXY(MSGID,EDIPI,GMRCDA,CRNRORDR,ORDRDESC,ORDRDATE,STA,REASON) ;
;
; Send MailMan message when proxy add fails.
;
; MSGID = HL7 Message ID (MSH-10) [OPTIONAL]
; EDIPI = Patient's EDIPI [OPTIONAL]
; GMRCDA = Consult IEN (pointer to #123) [OPTIONAL]
; CRNRORDR = Cerner order number [OPTIONAL]
; ORDRDESC = Ordering description [OPTIONAL]
; ORDRDATE = Ordering date in HL7 format [OPTIONAL]
; STA = Station where proxy add attempted [OPTIONAL]
; REASON = Proxy add failure reason [REQUIRED]
;
Q:$G(REASON)="" ;
;
N XMSUB,XMDUZ,XMTEXT,XMY,GRPIEN,MEM,GRP,N ;
S GRP="IFC PATIENT ERROR MESSAGES" ;
S XMSUB="Failed IFC transaction: Proxy Add Failed",XMTEXT="XMTEXT(" ;
S N=0 ;
I $G(MSGID)'="" S N=N+1,XMTEXT(N)="Message ID: "_MSGID ;
I $G(EDIPI)'="" S N=N+1,XMTEXT(N)="EDIPI: "_EDIPI ;
I $G(GMRCDA)'="" S N=N+1,XMTEXT(N)="Consult Number: "_GMRCDA ;
I $G(CRNRORDR)'="" S N=N+1,XMTEXT(N)="Cerner Order Number: "_CRNRORDR ;
I $G(ORDRDESC)'="" S N=N+1,XMTEXT(N)="Order Description: "_ORDRDESC ;
I $G(ORDRDATE)'="" S N=N+1,XMTEXT(N)="Order Date: "_$$FMTE^XLFDT($$HL7TFM^XLFDT(ORDRDATE)) ;
I $G(STA)'="" S N=N+1,XMTEXT(N)="Station where proxy add attempted: "_STA ;
S N=N+1,XMTEXT(N)="Failure Reason: "_REASON ;
S GRPIEN=$O(^XMB(3.8,"B",GRP,"")) Q:'GRPIEN
;Set up XMY for MEMBERS
S MEM=0 F S MEM=$O(^XMB(3.8,GRPIEN,1,MEM)) Q:'MEM S XMY($P(^XMB(3.8,GRPIEN,1,MEM,0),U))=""
;Set up XMY for MEMBERS REMOTE
S MEM=0 F S MEM=$O(^XMB(3.8,GRPIEN,6,MEM)) Q:'MEM S XMY($P(^XMB(3.8,GRPIEN,6,MEM,0),U))=""
Q:'$D(XMY)
S XMDUZ=GRP
D XMZ^XMA2 ; call Create Message Module
D EN1^XMD
Q ;
;
RESP(GMRCAC,GMRCMID,GMRCOC,GMRCDA,GMRCERR,GMRCMSG) ;
;
; Send ACK or NAK to Cerner followed by rejection comment. P205 wtc 8/15/24
;
; Input:
; GMRCAC = acknowledgement code (AA or AR)
; GMRCMID = message id from original msg
; GMRCOC = order control from original msg ORC
; GMRCDA = ien of consult being worked on
; GMRCERR = only defined if an error is found
; GMRCMSG = name of array where incoming HL7 stored
;
N HLA S HLA("HLA",1)=$$MSA^GMRCISEG(GMRCAC,GMRCMID,$G(GMRCERR))
;
; Generate PID segment for Cerner orders. Insert EDIPI and patient account number. p184
;
N DFN,PID,EDIPI,ICN,PTACCTNO,FS,CS,REPTTN,SEGNUM,PTACCTNO,GMRCRSLT ;
S SEGNUM=1 ;
I $G(GMRCDA) D ;
. S DFN=$P(^GMR(123,GMRCDA,0),U,2),PTACCTNO=$P($G(^GMR(123,GMRCDA,"CERNER")),U,3) ;
. I PTACCTNO'="" D ;
.. S HLECH=HL("ECH"),PID=$$EN^VAFCPID(DFN,"1,2,3,7,8,19"),PID=$$ADD2PID^GMRCIUTL(PID,DFN,PTACCTNO) ;
.. S SEGNUM=SEGNUM+1,HLA("HLA",SEGNUM)=PID ;
;
I $D(GMRCOC) D
. I GMRCOC="NW" S SEGNUM=SEGNUM+1,HLA("HLA",SEGNUM)=$$ORCRESP^GMRCISG1(GMRCDA,"OK","IP")
;
; Generate OBR segment for Cerner orders. p184
;
I $G(GMRCDA) S SEGNUM=SEGNUM+1,HLA("HLA",SEGNUM)=$$OBR^GMRCISG1(GMRCDA),HLA("HLA",SEGNUM)=$$ADD2OBR^GMRCIUTL(HLA("HLA",SEGNUM),GMRCDA) ;
;
; Send ACK/NAK to Cerner.
;
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT) ;-(
;
Q:GMRCAC="AA" ;
;
; Send rejection comment along with original order message.
;
N HL,HLL,HLP,ERRTEXT,OBR,IDX,STA,I ;
;
D INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
;
K ^TMP("GMRCIUT1",$J) M ^TMP("GMRCIUT1",$J)=@GMRCMSG ;
;
K ^TMP("HLS",$J) S SEGNUM=1,^TMP("HLS",$J,SEGNUM)="PID|"_^TMP("GMRCIUT1",$J,"PID") ;
S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="ORC|"_^TMP("GMRCIUT1",$J,"ORC") ;
;
; Change order control and status to "add comment" (IP/IP). WTC 10/21/24
;
S $P(^TMP("HLS",$J,SEGNUM),"|",2)="IP",$P(^TMP("HLS",$J,SEGNUM),"|",6)="IP" ;
;
S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBR|"_^TMP("GMRCIUT1",$J,"OBR"),OBR="OBR|"_^TMP("GMRCIUT1",$J,"OBR") ;
;
S IDX=0 F S IDX=$O(^TMP("GMRCIUT1",$J,"OBX",1,IDX)) Q:'IDX S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBX|"_^TMP("GMRCIUT1",$J,"OBX",1,IDX) ;
;
S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBX|3|TX|^COMMENTS^|1| ||||||P" ;
S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBX|3|TX|^COMMENTS^|2|Activity Type: Order Rejected||||||P" ;
S ERRTEXT="ERR"_GMRCERR_"^GMRCIUTL" ;
S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBX|3|TX|^COMMENTS^|3|Rejection Reason: "_GMRCERR_" - "_$P($T(@ERRTEXT),";",2)_"||||||P" ;
S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBX|3|TX|^COMMENTS^|4|Entered At Location: "_$P($$SITE^VASITE(),U,2)_"||||||P" ;
S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBX|3|TX|^COMMENTS^|5|"_$$FMTE^XLFDT($$NOW^XLFDT())_"||||||P" ;
;
S IDX=0 F I=6:1 S IDX=$O(^TMP("GMRCIUT1",$J,"OBX",3,IDX)) Q:'IDX S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBX|3|TX|^COMMENTS^|"_I_"|"_^TMP("GMRCIUT1",$J,"OBX",3,IDX) ;
;
S IDX=0 F S IDX=$O(^TMP("GMRCIUT1",$J,"OBX",5,IDX)) Q:'IDX S SEGNUM=SEGNUM+1,^TMP("HLS",$J,SEGNUM)="OBX|"_^TMP("GMRCIUT1",$J,"OBX",5,IDX) ;
;
S STA=$P($P(OBR,"|",3),"^",2) ;
S HLL("LINKS",1)="GMRC IFC SUBSC^"_$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)_U_STA ;
S HLP("SUBSCRIBER")="^^^^"_$P(HLL("LINKS",1),U,3) ;
D GENERATE^HLMA("GMRC IFC ORM EVENT","GM",1,,,.HLP) ;
;
; Save message in HL7 repository.
;
N ERR ;
K ^TMP("GMRCIUT1",$J) F IDX=1:1 Q:'$D(^TMP("HLS",$J,IDX)) S ^TMP("GMRCIUT1",$J,IDX,0)=^TMP("HLS",$J,IDX) ;
S ERR=$$SAVEHL7X^EHMHL7("GMRCIUT1","IFC","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"CERNER-"_$P($P(OBR,"|",3),"^",2),"|","^",$E(HL("ECH"),2)) ;
;
K ^TMP("GMRCIUT1",$J) ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCIUT1 7867 printed Sep 23, 2025@19:22:14 Page 2
GMRCIUT1 ;SLC/JFR - UTILITIES FOR INTER-FACILITY CONSULTS ; Jan 27, 2025@06:04:10
+1 ;;3.0;CONSULT/REQUEST TRACKING;**189,205**;DEC 27, 1997;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;don't start at the top
QUIT
+5 ;
CHKPROXY(GMRCDA,GMRCDFN,STA,DONOTLOG) ;
+1 ;
+2 ; GMRCDA = Consult, pointer to #123
+3 ; GMRCDFN = Patient, pointer to #2
+4 ; STA = Routing station number
+5 ; DONOTLOG = Flag to prevent logging in IFC Message Log (#123.6). 1=DO NOT LOG. [OPTIONAL]
+6 ;
+7 ; Checks success/failure of proxy add. Returns 1 if all is OK and IFC can be sent, 0^REASON if not.
+8 ;
+9 ;pull patient Correlation list
+10 ;
+11 ;
NEW DGKEY,DGOUT,CNT,IDS,CERNERID,CONSULTDFN,RTNCODE,EDIPI
+12 ;
+13 SET DGKEY=GMRCDFN_U_"PI"_U_"USVHA"_U_$PIECE($$SITE^VASITE,"^",3)
+14 DO TFL^VAFCTFU2(.DGOUT,DGKEY)
+15 ;
+16 ;
SET CONSULTDFN=""
SET CERNERID=""
+17 ;
SET CNT=0
FOR
SET CNT=$ORDER(DGOUT(CNT))
if 'CNT
QUIT
SET IDS=$GET(DGOUT(CNT))
Begin DoDot:1
+18 ;
IF $PIECE(IDS,"^",4)="200CRNR"
IF $PIECE(IDS,"^",2)="PI"
SET CERNERID=IDS
+19 ;
IF $PIECE(IDS,"^",4)=STA
IF $PIECE(IDS,"^",2)="PI"
IF $PIECE(IDS,"^",5)="A"!($PIECE(IDS,"^",5)="C")
SET CONSULTDFN=IDS
End DoDot:1
+20 ;
+21 ; Destination site is converted.
+22 ;
+23 ;
IF $$CRNRSITE^VAFCCRNR(STA)=1
Begin DoDot:1
+24 ;
IF CERNERID'=""
IF CONSULTDFN'=""
SET RTNCODE=1
QUIT
+25 ;
+26 ;
IF CERNERID=""
SET RTNCODE="0^CERNER INCOMPLETE"
QUIT
+27 ;
+28 ;
IF CONSULTDFN=""
Begin DoDot:2
+29 ;
+30 ; Call proxy add for converted VistA.
+31 ;
+32 ;
SET EDIPI=$$EDIPI^GMRCIUTL(GMRCDFN)
+33 ; ICR 7421
SET RTNCODE=$$ADD^DGPROSAD(EDIPI_"~USDOD~NI~200DOD",STA)
+34 ; Proxy add failed.
IF RTNCODE<0
Begin DoDot:3
+35 ;
IF '$GET(DONOTLOG)
DO LOGMSG^GMRCIUTL(GMRCDA,1,"",205)
+36 ; P189 WTC 6/24/24
DO FAILPRXY("",EDIPI,GMRCDA,"","","",STA,$PIECE(RTNCODE,U,2))
+37 ;
SET RTNCODE="0^CONVERTED VISTA INCOMPLETE"
End DoDot:3
+38 ;
if $GET(DONOTLOG)
QUIT
+39 ;
+40 ; Suppress 201 error if IFC already has a 203 error in the message log. wtc 11.22.23 p189
+41 ;
+42 ;
NEW ACTIEN,SUPPRESS,LOGIEN
SET SUPPRESS=0
SET ACTIEN=0
FOR
SET ACTIEN=$ORDER(^GMR(123.6,"AC",GMRCDA,ACTIEN))
if 'ACTIEN
QUIT
Begin DoDot:3
+43 ;
SET LOGIEN=0
FOR
SET LOGIEN=$ORDER(^GMR(123.6,"AC",GMRCDA,ACTIEN,1,LOGIEN))
if 'LOGIEN
QUIT
IF $PIECE($GET(^GMR(123.6,LOGIEN,0)),U,8)=203
SET SUPPRESS=1
QUIT
End DoDot:3
if SUPPRESS
QUIT
+44 ;
+45 ;
IF 'SUPPRESS
DO LOGMSG^GMRCIUTL(GMRCDA,1,"",201)
End DoDot:2
QUIT
End DoDot:1
QUIT RTNCODE
+46 ;
+47 ; Destination site is non-converted.
+48 ;
+49 ;
IF $$CRNRSITE^VAFCCRNR(STA)'=1
Begin DoDot:1
+50 ;
IF CONSULTDFN'=""
SET RTNCODE=1
QUIT
+51 ;
+52 ;
SET RTNCODE="0^NON-CONVERTED VISTA INCOMPLETE"
+53 ;
DO LOGMSG^GMRCIUTL(GMRCDA,1,"",201)
End DoDot:1
QUIT RTNCODE
+54 ;
+55 ;
QUIT "0^UNKNOWN"
+56 ;
FAILPRXY(MSGID,EDIPI,GMRCDA,CRNRORDR,ORDRDESC,ORDRDATE,STA,REASON) ;
+1 ;
+2 ; Send MailMan message when proxy add fails.
+3 ;
+4 ; MSGID = HL7 Message ID (MSH-10) [OPTIONAL]
+5 ; EDIPI = Patient's EDIPI [OPTIONAL]
+6 ; GMRCDA = Consult IEN (pointer to #123) [OPTIONAL]
+7 ; CRNRORDR = Cerner order number [OPTIONAL]
+8 ; ORDRDESC = Ordering description [OPTIONAL]
+9 ; ORDRDATE = Ordering date in HL7 format [OPTIONAL]
+10 ; STA = Station where proxy add attempted [OPTIONAL]
+11 ; REASON = Proxy add failure reason [REQUIRED]
+12 ;
+13 ;
if $GET(REASON)=""
QUIT
+14 ;
+15 ;
NEW XMSUB,XMDUZ,XMTEXT,XMY,GRPIEN,MEM,GRP,N
+16 ;
SET GRP="IFC PATIENT ERROR MESSAGES"
+17 ;
SET XMSUB="Failed IFC transaction: Proxy Add Failed"
SET XMTEXT="XMTEXT("
+18 ;
SET N=0
+19 ;
IF $GET(MSGID)'=""
SET N=N+1
SET XMTEXT(N)="Message ID: "_MSGID
+20 ;
IF $GET(EDIPI)'=""
SET N=N+1
SET XMTEXT(N)="EDIPI: "_EDIPI
+21 ;
IF $GET(GMRCDA)'=""
SET N=N+1
SET XMTEXT(N)="Consult Number: "_GMRCDA
+22 ;
IF $GET(CRNRORDR)'=""
SET N=N+1
SET XMTEXT(N)="Cerner Order Number: "_CRNRORDR
+23 ;
IF $GET(ORDRDESC)'=""
SET N=N+1
SET XMTEXT(N)="Order Description: "_ORDRDESC
+24 ;
IF $GET(ORDRDATE)'=""
SET N=N+1
SET XMTEXT(N)="Order Date: "_$$FMTE^XLFDT($$HL7TFM^XLFDT(ORDRDATE))
+25 ;
IF $GET(STA)'=""
SET N=N+1
SET XMTEXT(N)="Station where proxy add attempted: "_STA
+26 ;
SET N=N+1
SET XMTEXT(N)="Failure Reason: "_REASON
+27 SET GRPIEN=$ORDER(^XMB(3.8,"B",GRP,""))
if 'GRPIEN
QUIT
+28 ;Set up XMY for MEMBERS
+29 SET MEM=0
FOR
SET MEM=$ORDER(^XMB(3.8,GRPIEN,1,MEM))
if 'MEM
QUIT
SET XMY($PIECE(^XMB(3.8,GRPIEN,1,MEM,0),U))=""
+30 ;Set up XMY for MEMBERS REMOTE
+31 SET MEM=0
FOR
SET MEM=$ORDER(^XMB(3.8,GRPIEN,6,MEM))
if 'MEM
QUIT
SET XMY($PIECE(^XMB(3.8,GRPIEN,6,MEM,0),U))=""
+32 if '$DATA(XMY)
QUIT
+33 SET XMDUZ=GRP
+34 ; call Create Message Module
DO XMZ^XMA2
+35 DO EN1^XMD
+36 ;
QUIT
+37 ;
RESP(GMRCAC,GMRCMID,GMRCOC,GMRCDA,GMRCERR,GMRCMSG) ;
+1 ;
+2 ; Send ACK or NAK to Cerner followed by rejection comment. P205 wtc 8/15/24
+3 ;
+4 ; Input:
+5 ; GMRCAC = acknowledgement code (AA or AR)
+6 ; GMRCMID = message id from original msg
+7 ; GMRCOC = order control from original msg ORC
+8 ; GMRCDA = ien of consult being worked on
+9 ; GMRCERR = only defined if an error is found
+10 ; GMRCMSG = name of array where incoming HL7 stored
+11 ;
+12 NEW HLA
SET HLA("HLA",1)=$$MSA^GMRCISEG(GMRCAC,GMRCMID,$GET(GMRCERR))
+13 ;
+14 ; Generate PID segment for Cerner orders. Insert EDIPI and patient account number. p184
+15 ;
+16 ;
NEW DFN,PID,EDIPI,ICN,PTACCTNO,FS,CS,REPTTN,SEGNUM,PTACCTNO,GMRCRSLT
+17 ;
SET SEGNUM=1
+18 ;
IF $GET(GMRCDA)
Begin DoDot:1
+19 ;
SET DFN=$PIECE(^GMR(123,GMRCDA,0),U,2)
SET PTACCTNO=$PIECE($GET(^GMR(123,GMRCDA,"CERNER")),U,3)
+20 ;
IF PTACCTNO'=""
Begin DoDot:2
+21 ;
SET HLECH=HL("ECH")
SET PID=$$EN^VAFCPID(DFN,"1,2,3,7,8,19")
SET PID=$$ADD2PID^GMRCIUTL(PID,DFN,PTACCTNO)
+22 ;
SET SEGNUM=SEGNUM+1
SET HLA("HLA",SEGNUM)=PID
End DoDot:2
End DoDot:1
+23 ;
+24 IF $DATA(GMRCOC)
Begin DoDot:1
+25 IF GMRCOC="NW"
SET SEGNUM=SEGNUM+1
SET HLA("HLA",SEGNUM)=$$ORCRESP^GMRCISG1(GMRCDA,"OK","IP")
End DoDot:1
+26 ;
+27 ; Generate OBR segment for Cerner orders. p184
+28 ;
+29 ;
IF $GET(GMRCDA)
SET SEGNUM=SEGNUM+1
SET HLA("HLA",SEGNUM)=$$OBR^GMRCISG1(GMRCDA)
SET HLA("HLA",SEGNUM)=$$ADD2OBR^GMRCIUTL(HLA("HLA",SEGNUM),GMRCDA)
+30 ;
+31 ; Send ACK/NAK to Cerner.
+32 ;
+33 ;-(
DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
+34 ;
+35 ;
if GMRCAC="AA"
QUIT
+36 ;
+37 ; Send rejection comment along with original order message.
+38 ;
+39 ;
NEW HL,HLL,HLP,ERRTEXT,OBR,IDX,STA,I
+40 ;
+41 DO INIT^HLFNC2("GMRC IFC ORM EVENT",.HL)
+42 ;
+43 ;
KILL ^TMP("GMRCIUT1",$JOB)
MERGE ^TMP("GMRCIUT1",$JOB)=@GMRCMSG
+44 ;
+45 ;
KILL ^TMP("HLS",$JOB)
SET SEGNUM=1
SET ^TMP("HLS",$JOB,SEGNUM)="PID|"_^TMP("GMRCIUT1",$JOB,"PID")
+46 ;
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="ORC|"_^TMP("GMRCIUT1",$JOB,"ORC")
+47 ;
+48 ; Change order control and status to "add comment" (IP/IP). WTC 10/21/24
+49 ;
+50 ;
SET $PIECE(^TMP("HLS",$JOB,SEGNUM),"|",2)="IP"
SET $PIECE(^TMP("HLS",$JOB,SEGNUM),"|",6)="IP"
+51 ;
+52 ;
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBR|"_^TMP("GMRCIUT1",$JOB,"OBR")
SET OBR="OBR|"_^TMP("GMRCIUT1",$JOB,"OBR")
+53 ;
+54 ;
SET IDX=0
FOR
SET IDX=$ORDER(^TMP("GMRCIUT1",$JOB,"OBX",1,IDX))
if 'IDX
QUIT
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBX|"_^TMP("GMRCIUT1",$JOB,"OBX",1,IDX)
+55 ;
+56 ;
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBX|3|TX|^COMMENTS^|1| ||||||P"
+57 ;
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBX|3|TX|^COMMENTS^|2|Activity Type: Order Rejected||||||P"
+58 ;
SET ERRTEXT="ERR"_GMRCERR_"^GMRCIUTL"
+59 ;
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBX|3|TX|^COMMENTS^|3|Rejection Reason: "_GMRCERR_" - "_$PIECE($TEXT(@ERRTEXT),";",2)_"||||||P"
+60 ;
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBX|3|TX|^COMMENTS^|4|Entered At Location: "_$PIECE($$SITE^VASITE(),U,2)_"||||||P"
+61 ;
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBX|3|TX|^COMMENTS^|5|"_$$FMTE^XLFDT($$NOW^XLFDT())_"||||||P"
+62 ;
+63 ;
SET IDX=0
FOR I=6:1
SET IDX=$ORDER(^TMP("GMRCIUT1",$JOB,"OBX",3,IDX))
if 'IDX
QUIT
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBX|3|TX|^COMMENTS^|"_I_"|"_^TMP("GMRCIUT1",$JOB,"OBX",3,IDX)
+64 ;
+65 ;
SET IDX=0
FOR
SET IDX=$ORDER(^TMP("GMRCIUT1",$JOB,"OBX",5,IDX))
if 'IDX
QUIT
SET SEGNUM=SEGNUM+1
SET ^TMP("HLS",$JOB,SEGNUM)="OBX|"_^TMP("GMRCIUT1",$JOB,"OBX",5,IDX)
+66 ;
+67 ;
SET STA=$PIECE($PIECE(OBR,"|",3),"^",2)
+68 ;
SET HLL("LINKS",1)="GMRC IFC SUBSC^"_$$GET^XPAR("SYS","GMRC IFC REGIONAL ROUTER",1)_U_STA
+69 ;
SET HLP("SUBSCRIBER")="^^^^"_$PIECE(HLL("LINKS",1),U,3)
+70 ;
DO GENERATE^HLMA("GMRC IFC ORM EVENT","GM",1,,,.HLP)
+71 ;
+72 ; Save message in HL7 repository.
+73 ;
+74 ;
NEW ERR
+75 ;
KILL ^TMP("GMRCIUT1",$JOB)
FOR IDX=1:1
if '$DATA(^TMP("HLS",$JOB,IDX))
QUIT
SET ^TMP("GMRCIUT1",$JOB,IDX,0)=^TMP("HLS",$JOB,IDX)
+76 ;
SET ERR=$$SAVEHL7X^EHMHL7("GMRCIUT1","IFC","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),"CERNER-"_$PIECE($PIECE(OBR,"|",3),"^",2),"|","^",$EXTRACT(HL("ECH"),2))
+77 ;
+78 ;
KILL ^TMP("GMRCIUT1",$JOB)
+79 QUIT
+80 ;
