GMRCISG1 ;SLC/JFR - BUILD IFC HL7 SEGMENTS CONT'D ;03/24/14 13:27
;;3.0;CONSULT/REQUEST TRACKING;**22,66,73,154**;DEC 27, 1997;Build 135
;#2171 XUAF4, #10103 XLFDT, #10106 HLFNC, #10112 VASITE, #2541 $$KSP^XUPARAM, #2056(GET1^DIQ)
;
Q ;can't start here
ORCRESP(GMRCO,GMRCOC,GMRCOS) ;build ORC for app ACK msgs
; Input:
; GMRCO = ien from file 123 of entry responding to
; GMRCOC = order control to put into segment
; GMRCOS = HL7 encoded order status to put in message
;
; Output:
; ORC segment to use in response message
;
N GMRCPCS,SITE
S GMRCPCS(1)=GMRCOC
S GMRCPCS(2)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))_"^GMRCIFR"
S GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFC"
S GMRCPCS(5)=$G(GMRCOS)
S GMRCPCS(17)=$$STA^XUAF4($$KSP^XUPARAM("INST"))
Q $$BUILD^GMRCISEG("ORC",.GMRCPCS)
;
NWORC(GMRCO) ; build ORC seg for a new order
; Input:
; GMRCO = ien from file 123 of order to send remotely
;
; Output:
; ORC segment to send with a new order to remote facility
;
N GMRCPCS,SITE,GMRCPHN,GMRCPAG
S GMRCPCS(1)="NW"
S GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFR"
;BL;Check if site is converted and ensure ORC3.2 is set to receiving facility
;I $$CNVTD^GMRCIEVT($P($G(^GMR(123,GMRCO,0)),U,23)) D
I $$CNVTD^GMRCIEVT(GMRCO) D
. S GMRCPCS(3)=U_$$STA^XUAF4($P(^GMR(123,GMRCO,0),U,23))_"^GMRCIFC"
S $P(GMRCPCS(7),U,4)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,0),U,24)) ;wat/66
S $P(GMRCPCS(7),U,6)=$$URG^GMRCIUTL(GMRCO)
S GMRCPCS(9)=$$FMTHL7^XLFDT(+^GMR(123,GMRCO,0))
S GMRCPCS(10)=$$HLNAME^GMRCIUTL($P($G(^GMR(123,GMRCO,40,1,0)),U,5))
S GMRCPCS(12)=$$HLNAME^GMRCIUTL($P(^GMR(123,GMRCO,0),U,14))
S GMRCPHN=$$GET1^DIQ(200,$P(^GMR(123,GMRCO,0),U,14),.132)
S GMRCPAG=$$GET1^DIQ(200,$P(^GMR(123,GMRCO,0),U,14),.138)
S GMRCPCS(14)=$$HLPHONE^HLFNC(GMRCPHN,GMRCPAG)
S GMRCPCS(15)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,0),U,7))
I $O(^GMR(123,GMRCO,40,1)) D
. N I,ACTV S I=1
. F S I=$O(^GMR(123,GMRCO,40,I)) Q:'I S ACTV=$P(^(I,0),U,2) D
.. I ACTV'=25 Q
.. S GMRCPCS(16)="FI^FORWARD TO IFC^99GMRC"
S SITE=$$SITE^VASITE
I +SITE S GMRCPCS(17)=$P(SITE,U,3)_U_$P(SITE,U,2) ;use loc instead? ;-(
Q $$BUILD^GMRCISEG("ORC",.GMRCPCS)
OBXPD(GMRCO) ; create OBX segment for the prov. dx
; Input:
; GMRCO = ien from file 123 of order to send remotely
;
; Output:
; OBX segment containing the Provisional Diagnosis
;
Q:'$L($G(^GMR(123,GMRCO,30))) ""
N GMRCPCS,GMRCCODE,GMRCSYS
S GMRCPCS(1)=2,GMRCPCS(2)=$S($L($G(^GMR(123,GMRCO,30.1))):"CE",1:"TX")
S GMRCPCS(3)="^PROVISIONAL DIAGNOSIS^",GMRCPCS(4)=1
S GMRCPCS(11)="O"
I $L($G(^GMR(123,GMRCO,30.1))) D Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
. ;coded diagnosis
. S GMRCCODE=$P(^GMR(123,GMRCO,30.1),U,1) ;WAT/73
. S GMRCSYS=$P(^GMR(123,GMRCO,30.1),U,3) S GMRCSYS=$S($G(GMRCSYS)="ICD":"I9C",$G(GMRCSYS)="10D":"I10",1:"") ;WAT/73
. ;GMRCPCS(5) keep ICD code as part of dx text for correct dx display in 513 and Details at sites not testing patch 73
. S GMRCPCS(5)=$G(GMRCCODE)_U_$G(^(30))_" ("_$G(GMRCCODE)_")"_U_GMRCSYS
. S GMRCPCS(14)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,30.1),U,2)) ;WAT/73
S GMRCPCS(5)=U_$G(^GMR(123,GMRCO,30))_U ;free text dx
Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
;
OBR(GMRCO,GMRCACT) ; build an OBR seg for new order or resubmit
; Input:
; GMRCO = ien from file 123
; GMRCACT = ien from 40 multiple of action (only on resubmit or fwd)
;
; Output:
; OBR segment
;
N GMRCPCS,GMRCROL
S GMRCPCS(1)=1
S GMRCROL=$P(^GMR(123,GMRCO,12),U,5)
I GMRCROL="P" D
. S GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFR"
I $D(GMRCACT) D ; resubmit sends filler # too
. I GMRCROL="P" D
.. S GMRCPCS(3)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))
.. S GMRCPCS(3)=GMRCPCS(3)_U_"GMRCIFC"
. I GMRCROL="F" D
.. S GMRCPCS(2)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))
.. S GMRCPCS(2)=GMRCPCS(2)_U_"GMRCIFR"
.. S GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFC"
I $D(GMRCACT),$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=17 D
. ;FWD uses txt of current svc
. N SITE,SERVNM,SERV
. S SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))_"VA1235"
. I GMRCROL="F" S SERV=$P(^GMR(123,GMRCO,0),U,5)
. I GMRCROL="P" S SERV=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,6)
. S SERVNM=$S(+SERV:$P(^GMR(123.5,SERV,0),U),1:"")
. S GMRCPCS(4)=SERV_U_SERVNM_U_SITE
I $D(GMRCACT),$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=25 D
. ;FWD to IFC uses the FORWARDED FROM service name
. N SITE,SERVNM,SERV
. S SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))_"VA1235"
. S SERV=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,6)
. I '+SERV Q
. S SERVNM=$P(^GMR(123.5,SERV,0),U)
. S GMRCPCS(4)=SERV_U_SERVNM_U_SITE
I '$D(GMRCPCS(4)) D
. S GMRCPCS(4)=$$CODEOI^GMRCIUTL(GMRCO) ;get remote service or proc
I $D(GMRCACT) D ;resubmit or fwd so use activity fields for msg
. S GMRCPCS(6)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,40,GMRCACT,0),U,3))
. S GMRCPCS(16)=$$HLNAME^GMRCIUTL($P(^GMR(123,GMRCO,40,GMRCACT,0),U,4))
I '$D(GMRCACT) D ; new order being sent
. S GMRCPCS(6)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,0),U,7))
. S GMRCPCS(16)=$$HLNAME^GMRCIUTL($P(^GMR(123,GMRCO,0),U,14))
S GMRCPCS(18)=$P(^GMR(123,GMRCO,0),U,18)
Q $$BUILD^GMRCISEG("OBR",.GMRCPCS)
;
ORCTST() ;build ORC for testing imp.
;Input:
;
;Output:
; ORC segment used to test IFC implementation
;
N GMRCPCS,SITE,GMRCRP
S GMRCPCS(1)="NW"
S GMRCPCS(2)="TST1234"_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFR"
S GMRCPCS(9)=$$FMTHL7^XLFDT($$NOW^XLFDT)
S GMRCPCS(10)="PUBLIC^JOHN^Q"
S GMRCPCS(16)="T^TESTING^99GMRC"
Q $$BUILD^GMRCISEG("ORC",.GMRCPCS)
;
;
OBRTST(GMRCOI,GMRCTYP) ; build OBR seg for testing imp.
; Input:
; GMRCOI = ien from file 123.5 or 123.3
; GMRCTYP = "P" or "C" (procedure or consult service)
;
; Output:
; OBR segment used to test implementation
;
N GMRCPCS,SITE
S SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))
S GMRCPCS(1)=1
S GMRCPCS(2)="TST1234"_U_SITE_"^GMRCIFR"
I GMRCTYP="C" D
. N SERV
. S SERV=$P(^GMR(123.5,GMRCOI,"IFC"),U,2)
. S GMRCPCS(4)=GMRCOI_U_SERV_U_SITE_"VA1235"
I GMRCTYP="P" D
. N PROC
. S PROC=$P(^GMR(123.3,GMRCOI,"IFC"),U,2)
. S GMRCPCS(4)=GMRCOI_U_PROC_U_SITE_"VA1233"
Q $$BUILD^GMRCISEG("OBR",.GMRCPCS)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCISG1 6352 printed Sep 23, 2025@19:22:10 Page 2
GMRCISG1 ;SLC/JFR - BUILD IFC HL7 SEGMENTS CONT'D ;03/24/14 13:27
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,66,73,154**;DEC 27, 1997;Build 135
+2 ;#2171 XUAF4, #10103 XLFDT, #10106 HLFNC, #10112 VASITE, #2541 $$KSP^XUPARAM, #2056(GET1^DIQ)
+3 ;
+4 ;can't start here
QUIT
ORCRESP(GMRCO,GMRCOC,GMRCOS) ;build ORC for app ACK msgs
+1 ; Input:
+2 ; GMRCO = ien from file 123 of entry responding to
+3 ; GMRCOC = order control to put into segment
+4 ; GMRCOS = HL7 encoded order status to put in message
+5 ;
+6 ; Output:
+7 ; ORC segment to use in response message
+8 ;
+9 NEW GMRCPCS,SITE
+10 SET GMRCPCS(1)=GMRCOC
+11 SET GMRCPCS(2)=$PIECE(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($PIECE(^(0),U,23))_"^GMRCIFR"
+12 SET GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFC"
+13 SET GMRCPCS(5)=$GET(GMRCOS)
+14 SET GMRCPCS(17)=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+15 QUIT $$BUILD^GMRCISEG("ORC",.GMRCPCS)
+16 ;
NWORC(GMRCO) ; build ORC seg for a new order
+1 ; Input:
+2 ; GMRCO = ien from file 123 of order to send remotely
+3 ;
+4 ; Output:
+5 ; ORC segment to send with a new order to remote facility
+6 ;
+7 NEW GMRCPCS,SITE,GMRCPHN,GMRCPAG
+8 SET GMRCPCS(1)="NW"
+9 SET GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFR"
+10 ;BL;Check if site is converted and ensure ORC3.2 is set to receiving facility
+11 ;I $$CNVTD^GMRCIEVT($P($G(^GMR(123,GMRCO,0)),U,23)) D
+12 IF $$CNVTD^GMRCIEVT(GMRCO)
Begin DoDot:1
+13 SET GMRCPCS(3)=U_$$STA^XUAF4($PIECE(^GMR(123,GMRCO,0),U,23))_"^GMRCIFC"
End DoDot:1
+14 ;wat/66
SET $PIECE(GMRCPCS(7),U,4)=$$FMTHL7^XLFDT($PIECE(^GMR(123,GMRCO,0),U,24))
+15 SET $PIECE(GMRCPCS(7),U,6)=$$URG^GMRCIUTL(GMRCO)
+16 SET GMRCPCS(9)=$$FMTHL7^XLFDT(+^GMR(123,GMRCO,0))
+17 SET GMRCPCS(10)=$$HLNAME^GMRCIUTL($PIECE($GET(^GMR(123,GMRCO,40,1,0)),U,5))
+18 SET GMRCPCS(12)=$$HLNAME^GMRCIUTL($PIECE(^GMR(123,GMRCO,0),U,14))
+19 SET GMRCPHN=$$GET1^DIQ(200,$PIECE(^GMR(123,GMRCO,0),U,14),.132)
+20 SET GMRCPAG=$$GET1^DIQ(200,$PIECE(^GMR(123,GMRCO,0),U,14),.138)
+21 SET GMRCPCS(14)=$$HLPHONE^HLFNC(GMRCPHN,GMRCPAG)
+22 SET GMRCPCS(15)=$$FMTHL7^XLFDT($PIECE(^GMR(123,GMRCO,0),U,7))
+23 IF $ORDER(^GMR(123,GMRCO,40,1))
Begin DoDot:1
+24 NEW I,ACTV
SET I=1
+25 FOR
SET I=$ORDER(^GMR(123,GMRCO,40,I))
if 'I
QUIT
SET ACTV=$PIECE(^(I,0),U,2)
Begin DoDot:2
+26 IF ACTV'=25
QUIT
+27 SET GMRCPCS(16)="FI^FORWARD TO IFC^99GMRC"
End DoDot:2
End DoDot:1
+28 SET SITE=$$SITE^VASITE
+29 ;use loc instead? ;-(
IF +SITE
SET GMRCPCS(17)=$PIECE(SITE,U,3)_U_$PIECE(SITE,U,2)
+30 QUIT $$BUILD^GMRCISEG("ORC",.GMRCPCS)
OBXPD(GMRCO) ; create OBX segment for the prov. dx
+1 ; Input:
+2 ; GMRCO = ien from file 123 of order to send remotely
+3 ;
+4 ; Output:
+5 ; OBX segment containing the Provisional Diagnosis
+6 ;
+7 if '$LENGTH($GET(^GMR(123,GMRCO,30)))
QUIT ""
+8 NEW GMRCPCS,GMRCCODE,GMRCSYS
+9 SET GMRCPCS(1)=2
SET GMRCPCS(2)=$SELECT($LENGTH($GET(^GMR(123,GMRCO,30.1))):"CE",1:"TX")
+10 SET GMRCPCS(3)="^PROVISIONAL DIAGNOSIS^"
SET GMRCPCS(4)=1
+11 SET GMRCPCS(11)="O"
+12 IF $LENGTH($GET(^GMR(123,GMRCO,30.1)))
Begin DoDot:1
+13 ;coded diagnosis
+14 ;WAT/73
SET GMRCCODE=$PIECE(^GMR(123,GMRCO,30.1),U,1)
+15 ;WAT/73
SET GMRCSYS=$PIECE(^GMR(123,GMRCO,30.1),U,3)
SET GMRCSYS=$SELECT($GET(GMRCSYS)="ICD":"I9C",$GET(GMRCSYS)="10D":"I10",1:"")
+16 ;GMRCPCS(5) keep ICD code as part of dx text for correct dx display in 513 and Details at sites not testing patch 73
+17 SET GMRCPCS(5)=$GET(GMRCCODE)_U_$GET(^(30))_" ("_$GET(GMRCCODE)_")"_U_GMRCSYS
+18 ;WAT/73
SET GMRCPCS(14)=$$FMTHL7^XLFDT($PIECE(^GMR(123,GMRCO,30.1),U,2))
End DoDot:1
QUIT $$BUILD^GMRCISEG("OBX",.GMRCPCS)
+19 ;free text dx
SET GMRCPCS(5)=U_$GET(^GMR(123,GMRCO,30))_U
+20 QUIT $$BUILD^GMRCISEG("OBX",.GMRCPCS)
+21 ;
OBR(GMRCO,GMRCACT) ; build an OBR seg for new order or resubmit
+1 ; Input:
+2 ; GMRCO = ien from file 123
+3 ; GMRCACT = ien from 40 multiple of action (only on resubmit or fwd)
+4 ;
+5 ; Output:
+6 ; OBR segment
+7 ;
+8 NEW GMRCPCS,GMRCROL
+9 SET GMRCPCS(1)=1
+10 SET GMRCROL=$PIECE(^GMR(123,GMRCO,12),U,5)
+11 IF GMRCROL="P"
Begin DoDot:1
+12 SET GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFR"
End DoDot:1
+13 ; resubmit sends filler # too
IF $DATA(GMRCACT)
Begin DoDot:1
+14 IF GMRCROL="P"
Begin DoDot:2
+15 SET GMRCPCS(3)=$PIECE(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($PIECE(^(0),U,23))
+16 SET GMRCPCS(3)=GMRCPCS(3)_U_"GMRCIFC"
End DoDot:2
+17 IF GMRCROL="F"
Begin DoDot:2
+18 SET GMRCPCS(2)=$PIECE(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($PIECE(^(0),U,23))
+19 SET GMRCPCS(2)=GMRCPCS(2)_U_"GMRCIFR"
+20 SET GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_U_"GMRCIFC"
End DoDot:2
End DoDot:1
+21 IF $DATA(GMRCACT)
IF $PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=17
Begin DoDot:1
+22 ;FWD uses txt of current svc
+23 NEW SITE,SERVNM,SERV
+24 SET SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))_"VA1235"
+25 IF GMRCROL="F"
SET SERV=$PIECE(^GMR(123,GMRCO,0),U,5)
+26 IF GMRCROL="P"
SET SERV=$PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,6)
+27 SET SERVNM=$SELECT(+SERV:$PIECE(^GMR(123.5,SERV,0),U),1:"")
+28 SET GMRCPCS(4)=SERV_U_SERVNM_U_SITE
End DoDot:1
+29 IF $DATA(GMRCACT)
IF $PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=25
Begin DoDot:1
+30 ;FWD to IFC uses the FORWARDED FROM service name
+31 NEW SITE,SERVNM,SERV
+32 SET SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))_"VA1235"
+33 SET SERV=$PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,6)
+34 IF '+SERV
QUIT
+35 SET SERVNM=$PIECE(^GMR(123.5,SERV,0),U)
+36 SET GMRCPCS(4)=SERV_U_SERVNM_U_SITE
End DoDot:1
+37 IF '$DATA(GMRCPCS(4))
Begin DoDot:1
+38 ;get remote service or proc
SET GMRCPCS(4)=$$CODEOI^GMRCIUTL(GMRCO)
End DoDot:1
+39 ;resubmit or fwd so use activity fields for msg
IF $DATA(GMRCACT)
Begin DoDot:1
+40 SET GMRCPCS(6)=$$FMTHL7^XLFDT($PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,3))
+41 SET GMRCPCS(16)=$$HLNAME^GMRCIUTL($PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,4))
End DoDot:1
+42 ; new order being sent
IF '$DATA(GMRCACT)
Begin DoDot:1
+43 SET GMRCPCS(6)=$$FMTHL7^XLFDT($PIECE(^GMR(123,GMRCO,0),U,7))
+44 SET GMRCPCS(16)=$$HLNAME^GMRCIUTL($PIECE(^GMR(123,GMRCO,0),U,14))
End DoDot:1
+45 SET GMRCPCS(18)=$PIECE(^GMR(123,GMRCO,0),U,18)
+46 QUIT $$BUILD^GMRCISEG("OBR",.GMRCPCS)
+47 ;
ORCTST() ;build ORC for testing imp.
+1 ;Input:
+2 ;
+3 ;Output:
+4 ; ORC segment used to test IFC implementation
+5 ;
+6 NEW GMRCPCS,SITE,GMRCRP
+7 SET GMRCPCS(1)="NW"
+8 SET GMRCPCS(2)="TST1234"_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFR"
+9 SET GMRCPCS(9)=$$FMTHL7^XLFDT($$NOW^XLFDT)
+10 SET GMRCPCS(10)="PUBLIC^JOHN^Q"
+11 SET GMRCPCS(16)="T^TESTING^99GMRC"
+12 QUIT $$BUILD^GMRCISEG("ORC",.GMRCPCS)
+13 ;
+14 ;
OBRTST(GMRCOI,GMRCTYP) ; build OBR seg for testing imp.
+1 ; Input:
+2 ; GMRCOI = ien from file 123.5 or 123.3
+3 ; GMRCTYP = "P" or "C" (procedure or consult service)
+4 ;
+5 ; Output:
+6 ; OBR segment used to test implementation
+7 ;
+8 NEW GMRCPCS,SITE
+9 SET SITE=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+10 SET GMRCPCS(1)=1
+11 SET GMRCPCS(2)="TST1234"_U_SITE_"^GMRCIFR"
+12 IF GMRCTYP="C"
Begin DoDot:1
+13 NEW SERV
+14 SET SERV=$PIECE(^GMR(123.5,GMRCOI,"IFC"),U,2)
+15 SET GMRCPCS(4)=GMRCOI_U_SERV_U_SITE_"VA1235"
End DoDot:1
+16 IF GMRCTYP="P"
Begin DoDot:1
+17 NEW PROC
+18 SET PROC=$PIECE(^GMR(123.3,GMRCOI,"IFC"),U,2)
+19 SET GMRCPCS(4)=GMRCOI_U_PROC_U_SITE_"VA1233"
End DoDot:1
+20 QUIT $$BUILD^GMRCISEG("OBR",.GMRCPCS)
+21 ;
