GMRCISEG ;SLC/JFR - CREATE IFC HL7 SEGMENTS ;08/16/10 08:30
;;3.0;CONSULT/REQUEST TRACKING;**22,66,154,202**;DEC 27, 1997;Build 5
; $$GET1^DIQ ORC+28,ORC+29,OBXTZ+11
;#2171 XUAF4, #10103 XLFDT, #10106 HLFNC, #3042 MCAPI, #10112 VASITE, #2541 $$KSP^XUPARAM
;
Q ;don't enter at top
BUILD(SEG,PCS) ;create any segment from array in PCS using |^&/~
; SEG = ORC,OBR,etc.
; PCS = array of data elements to be combined into the segement
; array is numbered by the "|" piece
N ARR,SEGMNT
S ARR=0,SEGMNT=""
F S ARR=$O(PCS(ARR)) Q:'ARR D
. S $P(SEGMNT,"|",ARR)=PCS(ARR)
. Q
Q SEG_"|"_SEGMNT
ORC(GMRCO,GMRCOC,GMRCOS,GMRCACT) ;build ORC for all but new orders
;Input:
; GMRCO = ien from file 123
; GMRCOC = order control
; GMRCOS = order status
; GMRCACT = ien in 40 multiple of particular action
;
;Output:
; ORC segment
;
I '$D(GMRCO)!('$D(GMRCOC))!('$D(GMRCACT)) Q "ERROR"
N GMRCPCS,SITE,GMRCRP
S GMRCPCS(1)=GMRCOC
I $P($G(^GMR(123,GMRCO,12)),U,5)="P" D
. S GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFR"
. S GMRCPCS(3)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))
. S GMRCPCS(3)=GMRCPCS(3)_"^GMRCIFC"
I $P($G(^GMR(123,GMRCO,12)),U,5)="F" D
. S GMRCPCS(2)=$P(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($P(^(0),U,23))
. S GMRCPCS(2)=GMRCPCS(2)_"^GMRCIFR"
. S GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFC"
S GMRCPCS(5)=$S($D(GMRCOS):GMRCOS,1:"")
I GMRCOC["X" D
.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($P(^GMR(123,GMRCO,40,GMRCACT,0),U,1))
S GMRCPCS(10)=$$HLNAME^GMRCIUTL($P(^GMR(123,GMRCO,40,GMRCACT,0),U,5))
S GMRCRP=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,4) I +GMRCRP D
. S GMRCPCS(12)=$$HLNAME^GMRCIUTL(GMRCRP)
. N GMRCPHN,GMRCPAG
. S GMRCPHN=$$GET1^DIQ(200,GMRCRP,.132)
. S GMRCPAG=$$GET1^DIQ(200,GMRCRP,.138)
. S GMRCPCS(14)=$$HLPHONE^HLFNC(GMRCPHN,GMRCPAG)
S GMRCPCS(15)=$$FMTHL7^XLFDT($P(^GMR(123,GMRCO,40,GMRCACT,0),U,3))
I GMRCOC["X"!(GMRCOC="SC")!(GMRCOC="RE") D
. I GMRCOC="XX" D Q
.. I $P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=25 D Q
... S GMRCPCS(16)="FI^FORWARD TO IFC^99GMRC"
.. S GMRCPCS(16)="F^FORWARD^99GMRC"
. I GMRCOC="XO" S GMRCPCS(16)="E^EDIT-RESUBMIT^99GMRC" Q
. I GMRCOC="SC" D Q
.. I GMRCOS="IP" S GMRCPCS(16)="R^RECEIVE^99GMRC"
.. I GMRCOS="SC" S GMRCPCS(16)="SC^SCHEDULE^99GMRC"
. I GMRCOC="RE" D
.. N ACTVT S ACTVT=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
.. I ACTVT=12 S GMRCPCS(16)="D^DISASSOCIATE RESULT^99GMRC"
.. I ACTVT=13 S GMRCPCS(16)="A^ADDENDUM^99GMRC"
.. I ACTVT=4 S GMRCPCS(16)="S^SIGNIFICANT FINDING^99GMRC"
. Q
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)
;
OBXWP(GMRCO,GMRCOC,GMRCACT,GMRCSEG) ; return a WP field in OBX segs
; Input:
; GMRCO =
; GMRCOC =
; GMRCACT = activity in 40 mult triggering msg
; GMRCSEG = GLOBAL array to return results in
;
; Output:
; ARRAY(1)=OBX|1|TX|coding scheme|1|text||||||obs result status
; ARRAY(2)=OBX|1|TX|coding scheme|2|text||||||obs result status
;
K ^TMP("GMRCWP",$J)
N GMRCPCS,TCH,OBX11 ; P202 ADD IBX11
D SETTCH2^GMRCIMSG() ;MKN GMRC*3.0*154 Get TCH array
I GMRCOC="NW"!(GMRCOC="XO") D Q
. N SUBS S SUBS=0
. F S SUBS=$O(^GMR(123,GMRCO,20,SUBS)) Q:'SUBS D
.. S GMRCPCS(1)=1,GMRCPCS(2)="TX"
.. S GMRCPCS(3)="2000.02^REASON FOR REQUEST^AS4",GMRCPCS(4)=SUBS
.. S GMRCPCS(5)=$$ENCODE^GMRCHL7E($G(^GMR(123,GMRCO,20,SUBS,0)),.TCH),GMRCPCS(11)="O" ;MKN GMRC*3.0*154 Encode any special characters
.. S ^TMP("GMRCWP",$J,SUBS)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
. M @GMRCSEG=^TMP("GMRCWP",$J)
. K ^TMP("GMRCWP",$J)
. Q
I '$D(GMRCACT)!('$D(^GMR(123,GMRCO,40,GMRCACT,1))) Q
N CMT,ACTVT
S CMT=0,ACTVT=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
;GMRC*202 - new OBX workflow for POST OTHER (ADDED COMMENT - ACTVT =20) or POST COMPLETE (COMPLETE/UPDATE - ACTVT=10) actions for prosthetics
S OBX11=$S(ACTVT=10:"F",1:"P") ;F if an admin comp. else "P"
I $G(PROSTHCS)&((ACTVT=20)!(ACTVT=10)) D OBXPOST Q
;END GMRC*202
F S CMT=$O(^GMR(123,GMRCO,40,GMRCACT,1,CMT)) Q:'CMT D
. S GMRCPCS(1)=3,GMRCPCS(2)="TX"
. S GMRCPCS(3)="^COMMENTS^",GMRCPCS(4)=CMT ;MKN GMRC*3.0*154 Encode any special characters
. S GMRCPCS(5)=$$ENCODE^GMRCHL7E($G(^GMR(123,GMRCO,40,GMRCACT,1,CMT,0)),.TCH) ;MKN GMRC*3.0*154 Encode any special characters
. S GMRCPCS(11)=$S(ACTVT=10:"F",1:"P") ;F if an admin comp. else "P"
. S ^TMP("GMRCWP",$J,CMT)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
M @GMRCSEG=^TMP("GMRCWP",$J)
K ^TMP("GMRCWP",$J)
Q
;
OBXRSLT(GMRCO,GMRCACT) ; build an OBX segment to send a TIU doc reference
; Input:
; GMRCO = ien from file 123
; GMRCACT = activity entry in 40 multiple
;
; Output:
; OBX segment
; e.g. OBX|4|RP|^TIU DOC^VA8925||41320^TIU^660||||||||F
;
Q:'$D(^GMR(123,GMRCO,40,GMRCACT)) ""
N GMRCPCS,RSLT,GMRCACTV
S GMRCPCS(1)=4,GMRCPCS(2)="RP"
S GMRCPCS(4)=1
S GMRCACTV=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
S RSLT=$P(^GMR(123,GMRCO,40,GMRCACT,0),U,9)
I RSLT["TIU" D
. S GMRCPCS(3)="^TIU DOC^VA8925"
. S GMRCPCS(5)=+RSLT_"^TIU DOCUMENT^"_$$STA^XUAF4($$KSP^XUPARAM("INST"))
I RSLT["MCAR" D
. N MCPRNM S MCPRNM=$P($$SINGLE^MCAPI(RSLT),U)
. S GMRCPCS(3)="^MED RSLT^VA"_+$P(RSLT,"MCAR(",2)
. S GMRCPCS(5)=+RSLT_U_MCPRNM_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))
S GMRCPCS(11)=$S(GMRCACTV=9:"S",GMRCACTV=12:"D",1:"F")
Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
;
NTE(GMRCO,GMRCACT,GMRCAR) ;format an NTE seg with DC comment
; Input:
; GMRCO = ien from file 123
; GMRCACT = activity entry in 40 multiple
; GMRCAR = array in which to pass back NTE segs
;
; Output:
; array of NTE segments containing the comment
; e.g. NTE|1|L|cancelled by requestor
;
Q:'$D(^GMR(123,GMRCO,40,GMRCACT,1))
N CMT,GMRCPCS,TCH S CMT=0
D SETTCH2^GMRCIMSG() ;MKN GMRC*3.0*154 Get TCH array
F S CMT=$O(^GMR(123,GMRCO,40,GMRCACT,1,CMT)) Q:'CMT D
. S GMRCPCS(1)=CMT,GMRCPCS(2)="L"
. S GMRCPCS(3)=$$ENCODE^GMRCHL7E($G(^GMR(123,GMRCO,40,GMRCACT,1,CMT,0)),.TCH) ;MKN GMRC*3.0*154 Encode any special characters
. S GMRCAR(CMT)=$$BUILD^GMRCISEG("NTE",.GMRCPCS)
Q
;
MSA(GMRCAC,GMRCMSG,GMRCERR) ; build MSA for response to placer activity
; Input:
; GMRCAC = acknowledgment code (AA or AR)
; GMRCMSG = message number from incoming msg being responded to
; GMRCERR = error message if can't accept the activity
;
; Output:
; MSA segment to include with ACK or NAK
;
N GMRCPCS
S GMRCPCS(1)=GMRCAC
S GMRCPCS(2)=GMRCMSG
S GMRCPCS(3)=$G(GMRCERR)
Q $$BUILD^GMRCISEG("MSA",.GMRCPCS)
;
OBXTZ() ;build and return an OBX with the current TIME ZONE encoded
;Input:
; none
;
;Output:
; OBX segment in the format:
; OBX|5|CE|^TIME ZONE^VA4.4|1|MST||||||0
N GMRCPCS
S GMRCPCS(1)=5,GMRCPCS(2)="CE" ;WAT/66
S GMRCPCS(3)="^TIME ZONE^VA4.4",GMRCPCS(4)=1
S GMRCPCS(5)=$$GET1^DIQ(4.3,1,1)
Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
;
OBXSF(GMRCO) ; build OBX seg for Sig. Find.
; Input:
; GMRCO = ien from file 123
;
; Output:
; OBX segment in format:
; OBX|6|TX|^SIG FINDINGS^|1|S||||||O
;
I '$L($P(^GMR(123,GMRCO,0),U,19)) Q ""
N GMRCPCS
S GMRCPCS(1)=6,GMRCPCS(2)="TX",GMRCPCS(3)="^SIG FINDINGS^"
S GMRCPCS(4)=1,GMRCPCS(5)=$P(^GMR(123,GMRCO,0),U,19),GMRCPCS(11)="O"
Q $$BUILD^GMRCISEG("OBX",.GMRCPCS)
OBXPOST ;build OBX for Post Other or Post Complete Actions
;
;GMRC*2.0*202
;For Post Other or Post Complete for Prosthetics orders add additional details to
;the comments - including "Entered" by and the "Order Details"
N GMRCSUBS,GMRCPCS,GMRCCMT,GMRCCMT1
S GMRCSUBS=0,GMRCCMT=0,GMRCCMT1=0
S GMRCPCS(1)=3,GMRCPCS(2)="TX",GMRCPCS(3)="^COMMENTS^"
S GMRCPCS(11)=OBX11 ;OBX11 added as part of GMRC*189 to capture new "C" action
;loop through the (#40) REQUEST PROCESSING ACTIVITY to build the comments
F S GMRCCMT=$O(^GMR(123,GMRCO,40,GMRCACT,1,GMRCCMT)) Q:'GMRCCMT D
. S GMRCCMT1=GMRCCMT1+1
. S GMRCPCS(4)=GMRCCMT1
. S GMRCPCS(5)=$$ENCODE^GMRCHL7E($G(^GMR(123,GMRCO,40,GMRCACT,1,GMRCCMT,0)),.TCH)
. S ^TMP("GMRCWP",$J,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
S GMRCCMT1=GMRCCMT1+1,GMRCPCS(4)=GMRCCMT1 S GMRCPCS(5)="ENTERED BY: "_$$GET1^DIQ(200,$P(^GMR(123,GMRCO,40,GMRCACT,0),"^",5),.01)
S ^TMP("GMRCWP",$J,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
S GMRCCMT1=GMRCCMT1+1,GMRCPCS(4)=GMRCCMT1 S GMRCPCS(5)="DATE ENTERED: "_$$FMTE^XLFDT($P(^GMR(123,GMRCO,40,GMRCACT,0),"^",1))
S ^TMP("GMRCWP",$J,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
S GMRCCMT1=GMRCCMT1+1,GMRCPCS(4)=GMRCCMT1 S GMRCPCS(5)=" "
S ^TMP("GMRCWP",$J,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
;loop through (#20) REASON FOR REQUEST and append to bottom of "COMMENTS"
F S GMRCSUBS=$O(^GMR(123,GMRCO,20,GMRCSUBS)) Q:'GMRCSUBS D
. S GMRCCMT1=GMRCCMT1+1
. S GMRCPCS(4)=GMRCCMT1
. S GMRCPCS(5)=$$ENCODE^GMRCHL7E($G(^GMR(123,GMRCO,20,GMRCSUBS,0)),.TCH)
. S ^TMP("GMRCWP",$J,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
;details move to end
M @GMRCSEG=^TMP("GMRCWP",$J)
K ^TMP("GMRCWP",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCISEG 9249 printed Nov 22, 2024@16:56:19 Page 2
GMRCISEG ;SLC/JFR - CREATE IFC HL7 SEGMENTS ;08/16/10 08:30
+1 ;;3.0;CONSULT/REQUEST TRACKING;**22,66,154,202**;DEC 27, 1997;Build 5
+2 ; $$GET1^DIQ ORC+28,ORC+29,OBXTZ+11
+3 ;#2171 XUAF4, #10103 XLFDT, #10106 HLFNC, #3042 MCAPI, #10112 VASITE, #2541 $$KSP^XUPARAM
+4 ;
+5 ;don't enter at top
QUIT
BUILD(SEG,PCS) ;create any segment from array in PCS using |^&/~
+1 ; SEG = ORC,OBR,etc.
+2 ; PCS = array of data elements to be combined into the segement
+3 ; array is numbered by the "|" piece
+4 NEW ARR,SEGMNT
+5 SET ARR=0
SET SEGMNT=""
+6 FOR
SET ARR=$ORDER(PCS(ARR))
if 'ARR
QUIT
Begin DoDot:1
+7 SET $PIECE(SEGMNT,"|",ARR)=PCS(ARR)
+8 QUIT
End DoDot:1
+9 QUIT SEG_"|"_SEGMNT
ORC(GMRCO,GMRCOC,GMRCOS,GMRCACT) ;build ORC for all but new orders
+1 ;Input:
+2 ; GMRCO = ien from file 123
+3 ; GMRCOC = order control
+4 ; GMRCOS = order status
+5 ; GMRCACT = ien in 40 multiple of particular action
+6 ;
+7 ;Output:
+8 ; ORC segment
+9 ;
+10 IF '$DATA(GMRCO)!('$DATA(GMRCOC))!('$DATA(GMRCACT))
QUIT "ERROR"
+11 NEW GMRCPCS,SITE,GMRCRP
+12 SET GMRCPCS(1)=GMRCOC
+13 IF $PIECE($GET(^GMR(123,GMRCO,12)),U,5)="P"
Begin DoDot:1
+14 SET GMRCPCS(2)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFR"
+15 SET GMRCPCS(3)=$PIECE(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($PIECE(^(0),U,23))
+16 SET GMRCPCS(3)=GMRCPCS(3)_"^GMRCIFC"
End DoDot:1
+17 IF $PIECE($GET(^GMR(123,GMRCO,12)),U,5)="F"
Begin DoDot:1
+18 SET GMRCPCS(2)=$PIECE(^GMR(123,GMRCO,0),U,22)_U_$$STA^XUAF4($PIECE(^(0),U,23))
+19 SET GMRCPCS(2)=GMRCPCS(2)_"^GMRCIFR"
+20 SET GMRCPCS(3)=GMRCO_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))_"^GMRCIFC"
End DoDot:1
+21 SET GMRCPCS(5)=$SELECT($DATA(GMRCOS):GMRCOS,1:"")
+22 IF GMRCOC["X"
Begin DoDot:1
+23 ;wat/66
SET $PIECE(GMRCPCS(7),U,4)=$$FMTHL7^XLFDT($PIECE(^GMR(123,GMRCO,0),U,24))
+24 SET $PIECE(GMRCPCS(7),U,6)=$$URG^GMRCIUTL(GMRCO)
End DoDot:1
+25 SET GMRCPCS(9)=$$FMTHL7^XLFDT($PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,1))
+26 SET GMRCPCS(10)=$$HLNAME^GMRCIUTL($PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,5))
+27 SET GMRCRP=$PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,4)
IF +GMRCRP
Begin DoDot:1
+28 SET GMRCPCS(12)=$$HLNAME^GMRCIUTL(GMRCRP)
+29 NEW GMRCPHN,GMRCPAG
+30 SET GMRCPHN=$$GET1^DIQ(200,GMRCRP,.132)
+31 SET GMRCPAG=$$GET1^DIQ(200,GMRCRP,.138)
+32 SET GMRCPCS(14)=$$HLPHONE^HLFNC(GMRCPHN,GMRCPAG)
End DoDot:1
+33 SET GMRCPCS(15)=$$FMTHL7^XLFDT($PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,3))
+34 IF GMRCOC["X"!(GMRCOC="SC")!(GMRCOC="RE")
Begin DoDot:1
+35 IF GMRCOC="XX"
Begin DoDot:2
+36 IF $PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,2)=25
Begin DoDot:3
+37 SET GMRCPCS(16)="FI^FORWARD TO IFC^99GMRC"
End DoDot:3
QUIT
+38 SET GMRCPCS(16)="F^FORWARD^99GMRC"
End DoDot:2
QUIT
+39 IF GMRCOC="XO"
SET GMRCPCS(16)="E^EDIT-RESUBMIT^99GMRC"
QUIT
+40 IF GMRCOC="SC"
Begin DoDot:2
+41 IF GMRCOS="IP"
SET GMRCPCS(16)="R^RECEIVE^99GMRC"
+42 IF GMRCOS="SC"
SET GMRCPCS(16)="SC^SCHEDULE^99GMRC"
End DoDot:2
QUIT
+43 IF GMRCOC="RE"
Begin DoDot:2
+44 NEW ACTVT
SET ACTVT=$PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
+45 IF ACTVT=12
SET GMRCPCS(16)="D^DISASSOCIATE RESULT^99GMRC"
+46 IF ACTVT=13
SET GMRCPCS(16)="A^ADDENDUM^99GMRC"
+47 IF ACTVT=4
SET GMRCPCS(16)="S^SIGNIFICANT FINDING^99GMRC"
End DoDot:2
+48 QUIT
End DoDot:1
+49 SET SITE=$$SITE^VASITE
+50 ;use loc instead? ;-(
IF +SITE
SET GMRCPCS(17)=$PIECE(SITE,U,3)_U_$PIECE(SITE,U,2)
+51 QUIT $$BUILD^GMRCISEG("ORC",.GMRCPCS)
+52 ;
OBXWP(GMRCO,GMRCOC,GMRCACT,GMRCSEG) ; return a WP field in OBX segs
+1 ; Input:
+2 ; GMRCO =
+3 ; GMRCOC =
+4 ; GMRCACT = activity in 40 mult triggering msg
+5 ; GMRCSEG = GLOBAL array to return results in
+6 ;
+7 ; Output:
+8 ; ARRAY(1)=OBX|1|TX|coding scheme|1|text||||||obs result status
+9 ; ARRAY(2)=OBX|1|TX|coding scheme|2|text||||||obs result status
+10 ;
+11 KILL ^TMP("GMRCWP",$JOB)
+12 ; P202 ADD IBX11
NEW GMRCPCS,TCH,OBX11
+13 ;MKN GMRC*3.0*154 Get TCH array
DO SETTCH2^GMRCIMSG()
+14 IF GMRCOC="NW"!(GMRCOC="XO")
Begin DoDot:1
+15 NEW SUBS
SET SUBS=0
+16 FOR
SET SUBS=$ORDER(^GMR(123,GMRCO,20,SUBS))
if 'SUBS
QUIT
Begin DoDot:2
+17 SET GMRCPCS(1)=1
SET GMRCPCS(2)="TX"
+18 SET GMRCPCS(3)="2000.02^REASON FOR REQUEST^AS4"
SET GMRCPCS(4)=SUBS
+19 ;MKN GMRC*3.0*154 Encode any special characters
SET GMRCPCS(5)=$$ENCODE^GMRCHL7E($GET(^GMR(123,GMRCO,20,SUBS,0)),.TCH)
SET GMRCPCS(11)="O"
+20 SET ^TMP("GMRCWP",$JOB,SUBS)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
End DoDot:2
+21 MERGE @GMRCSEG=^TMP("GMRCWP",$JOB)
+22 KILL ^TMP("GMRCWP",$JOB)
+23 QUIT
End DoDot:1
QUIT
+24 IF '$DATA(GMRCACT)!('$DATA(^GMR(123,GMRCO,40,GMRCACT,1)))
QUIT
+25 NEW CMT,ACTVT
+26 SET CMT=0
SET ACTVT=$PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
+27 ;GMRC*202 - new OBX workflow for POST OTHER (ADDED COMMENT - ACTVT =20) or POST COMPLETE (COMPLETE/UPDATE - ACTVT=10) actions for prosthetics
+28 ;F if an admin comp. else "P"
SET OBX11=$SELECT(ACTVT=10:"F",1:"P")
+29 IF $GET(PROSTHCS)&((ACTVT=20)!(ACTVT=10))
DO OBXPOST
QUIT
+30 ;END GMRC*202
+31 FOR
SET CMT=$ORDER(^GMR(123,GMRCO,40,GMRCACT,1,CMT))
if 'CMT
QUIT
Begin DoDot:1
+32 SET GMRCPCS(1)=3
SET GMRCPCS(2)="TX"
+33 ;MKN GMRC*3.0*154 Encode any special characters
SET GMRCPCS(3)="^COMMENTS^"
SET GMRCPCS(4)=CMT
+34 ;MKN GMRC*3.0*154 Encode any special characters
SET GMRCPCS(5)=$$ENCODE^GMRCHL7E($GET(^GMR(123,GMRCO,40,GMRCACT,1,CMT,0)),.TCH)
+35 ;F if an admin comp. else "P"
SET GMRCPCS(11)=$SELECT(ACTVT=10:"F",1:"P")
+36 SET ^TMP("GMRCWP",$JOB,CMT)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
End DoDot:1
+37 MERGE @GMRCSEG=^TMP("GMRCWP",$JOB)
+38 KILL ^TMP("GMRCWP",$JOB)
+39 QUIT
+40 ;
OBXRSLT(GMRCO,GMRCACT) ; build an OBX segment to send a TIU doc reference
+1 ; Input:
+2 ; GMRCO = ien from file 123
+3 ; GMRCACT = activity entry in 40 multiple
+4 ;
+5 ; Output:
+6 ; OBX segment
+7 ; e.g. OBX|4|RP|^TIU DOC^VA8925||41320^TIU^660||||||||F
+8 ;
+9 if '$DATA(^GMR(123,GMRCO,40,GMRCACT))
QUIT ""
+10 NEW GMRCPCS,RSLT,GMRCACTV
+11 SET GMRCPCS(1)=4
SET GMRCPCS(2)="RP"
+12 SET GMRCPCS(4)=1
+13 SET GMRCACTV=$PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,2)
+14 SET RSLT=$PIECE(^GMR(123,GMRCO,40,GMRCACT,0),U,9)
+15 IF RSLT["TIU"
Begin DoDot:1
+16 SET GMRCPCS(3)="^TIU DOC^VA8925"
+17 SET GMRCPCS(5)=+RSLT_"^TIU DOCUMENT^"_$$STA^XUAF4($$KSP^XUPARAM("INST"))
End DoDot:1
+18 IF RSLT["MCAR"
Begin DoDot:1
+19 NEW MCPRNM
SET MCPRNM=$PIECE($$SINGLE^MCAPI(RSLT),U)
+20 SET GMRCPCS(3)="^MED RSLT^VA"_+$PIECE(RSLT,"MCAR(",2)
+21 SET GMRCPCS(5)=+RSLT_U_MCPRNM_U_$$STA^XUAF4($$KSP^XUPARAM("INST"))
End DoDot:1
+22 SET GMRCPCS(11)=$SELECT(GMRCACTV=9:"S",GMRCACTV=12:"D",1:"F")
+23 QUIT $$BUILD^GMRCISEG("OBX",.GMRCPCS)
+24 ;
NTE(GMRCO,GMRCACT,GMRCAR) ;format an NTE seg with DC comment
+1 ; Input:
+2 ; GMRCO = ien from file 123
+3 ; GMRCACT = activity entry in 40 multiple
+4 ; GMRCAR = array in which to pass back NTE segs
+5 ;
+6 ; Output:
+7 ; array of NTE segments containing the comment
+8 ; e.g. NTE|1|L|cancelled by requestor
+9 ;
+10 if '$DATA(^GMR(123,GMRCO,40,GMRCACT,1))
QUIT
+11 NEW CMT,GMRCPCS,TCH
SET CMT=0
+12 ;MKN GMRC*3.0*154 Get TCH array
DO SETTCH2^GMRCIMSG()
+13 FOR
SET CMT=$ORDER(^GMR(123,GMRCO,40,GMRCACT,1,CMT))
if 'CMT
QUIT
Begin DoDot:1
+14 SET GMRCPCS(1)=CMT
SET GMRCPCS(2)="L"
+15 ;MKN GMRC*3.0*154 Encode any special characters
SET GMRCPCS(3)=$$ENCODE^GMRCHL7E($GET(^GMR(123,GMRCO,40,GMRCACT,1,CMT,0)),.TCH)
+16 SET GMRCAR(CMT)=$$BUILD^GMRCISEG("NTE",.GMRCPCS)
End DoDot:1
+17 QUIT
+18 ;
MSA(GMRCAC,GMRCMSG,GMRCERR) ; build MSA for response to placer activity
+1 ; Input:
+2 ; GMRCAC = acknowledgment code (AA or AR)
+3 ; GMRCMSG = message number from incoming msg being responded to
+4 ; GMRCERR = error message if can't accept the activity
+5 ;
+6 ; Output:
+7 ; MSA segment to include with ACK or NAK
+8 ;
+9 NEW GMRCPCS
+10 SET GMRCPCS(1)=GMRCAC
+11 SET GMRCPCS(2)=GMRCMSG
+12 SET GMRCPCS(3)=$GET(GMRCERR)
+13 QUIT $$BUILD^GMRCISEG("MSA",.GMRCPCS)
+14 ;
OBXTZ() ;build and return an OBX with the current TIME ZONE encoded
+1 ;Input:
+2 ; none
+3 ;
+4 ;Output:
+5 ; OBX segment in the format:
+6 ; OBX|5|CE|^TIME ZONE^VA4.4|1|MST||||||0
+7 NEW GMRCPCS
+8 ;WAT/66
SET GMRCPCS(1)=5
SET GMRCPCS(2)="CE"
+9 SET GMRCPCS(3)="^TIME ZONE^VA4.4"
SET GMRCPCS(4)=1
+10 SET GMRCPCS(5)=$$GET1^DIQ(4.3,1,1)
+11 QUIT $$BUILD^GMRCISEG("OBX",.GMRCPCS)
+12 ;
OBXSF(GMRCO) ; build OBX seg for Sig. Find.
+1 ; Input:
+2 ; GMRCO = ien from file 123
+3 ;
+4 ; Output:
+5 ; OBX segment in format:
+6 ; OBX|6|TX|^SIG FINDINGS^|1|S||||||O
+7 ;
+8 IF '$LENGTH($PIECE(^GMR(123,GMRCO,0),U,19))
QUIT ""
+9 NEW GMRCPCS
+10 SET GMRCPCS(1)=6
SET GMRCPCS(2)="TX"
SET GMRCPCS(3)="^SIG FINDINGS^"
+11 SET GMRCPCS(4)=1
SET GMRCPCS(5)=$PIECE(^GMR(123,GMRCO,0),U,19)
SET GMRCPCS(11)="O"
+12 QUIT $$BUILD^GMRCISEG("OBX",.GMRCPCS)
OBXPOST ;build OBX for Post Other or Post Complete Actions
+1 ;
+2 ;GMRC*2.0*202
+3 ;For Post Other or Post Complete for Prosthetics orders add additional details to
+4 ;the comments - including "Entered" by and the "Order Details"
+5 NEW GMRCSUBS,GMRCPCS,GMRCCMT,GMRCCMT1
+6 SET GMRCSUBS=0
SET GMRCCMT=0
SET GMRCCMT1=0
+7 SET GMRCPCS(1)=3
SET GMRCPCS(2)="TX"
SET GMRCPCS(3)="^COMMENTS^"
+8 ;OBX11 added as part of GMRC*189 to capture new "C" action
SET GMRCPCS(11)=OBX11
+9 ;loop through the (#40) REQUEST PROCESSING ACTIVITY to build the comments
+10 FOR
SET GMRCCMT=$ORDER(^GMR(123,GMRCO,40,GMRCACT,1,GMRCCMT))
if 'GMRCCMT
QUIT
Begin DoDot:1
+11 SET GMRCCMT1=GMRCCMT1+1
+12 SET GMRCPCS(4)=GMRCCMT1
+13 SET GMRCPCS(5)=$$ENCODE^GMRCHL7E($GET(^GMR(123,GMRCO,40,GMRCACT,1,GMRCCMT,0)),.TCH)
+14 SET ^TMP("GMRCWP",$JOB,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
End DoDot:1
+15 SET GMRCCMT1=GMRCCMT1+1
SET GMRCPCS(4)=GMRCCMT1
SET GMRCPCS(5)="ENTERED BY: "_$$GET1^DIQ(200,$PIECE(^GMR(123,GMRCO,40,GMRCACT,0),"^",5),.01)
+16 SET ^TMP("GMRCWP",$JOB,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
+17 SET GMRCCMT1=GMRCCMT1+1
SET GMRCPCS(4)=GMRCCMT1
SET GMRCPCS(5)="DATE ENTERED: "_$$FMTE^XLFDT($PIECE(^GMR(123,GMRCO,40,GMRCACT,0),"^",1))
+18 SET ^TMP("GMRCWP",$JOB,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
+19 SET GMRCCMT1=GMRCCMT1+1
SET GMRCPCS(4)=GMRCCMT1
SET GMRCPCS(5)=" "
+20 SET ^TMP("GMRCWP",$JOB,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
+21 ;loop through (#20) REASON FOR REQUEST and append to bottom of "COMMENTS"
+22 FOR
SET GMRCSUBS=$ORDER(^GMR(123,GMRCO,20,GMRCSUBS))
if 'GMRCSUBS
QUIT
Begin DoDot:1
+23 SET GMRCCMT1=GMRCCMT1+1
+24 SET GMRCPCS(4)=GMRCCMT1
+25 SET GMRCPCS(5)=$$ENCODE^GMRCHL7E($GET(^GMR(123,GMRCO,20,GMRCSUBS,0)),.TCH)
+26 SET ^TMP("GMRCWP",$JOB,GMRCCMT1)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
End DoDot:1
+27 ;details move to end
+28 MERGE @GMRCSEG=^TMP("GMRCWP",$JOB)
+29 KILL ^TMP("GMRCWP",$JOB)
+30 QUIT
