- GMRCISEG ;SLC/JFR - CREATE IFC HL7 SEGMENTS ; Jul 23, 2024@10:17:34
- ;;3.0;CONSULT/REQUEST TRACKING;**22,66,154,202,189**;DEC 27, 1997;Build 54
- ; $$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 OBX11
- 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
- ;
- ; OBX-11 is comment status. It's "F" for Admin Complete actions, "P" otherwise except if entered post-complete then "C".
- ;
- S OBX11=$S(ACTVT=10:"F",1:"P") ;F if an admin comp. else "P"
- ;
- ; Change status to changed (C) if comments added post-complete on IFC involving Cerner.
- ;
- I $$CNVTD^GMRCIEVT(GMRCO) D ;
- . N GMRCACT1 S GMRCACT1=GMRCACT-.000001 F S GMRCACT1=$O(^GMR(123,GMRCO,40,GMRCACT1),-1) Q:'GMRCACT1 I $P(^(GMRCACT1,0),U,2)=10 S OBX11="C" Q ; WTC p189
- ;
- 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)=OBX11 ; P189 WTC 6/29/2023
- . 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 9656 printed Mar 13, 2025@20:50:47 Page 2
- GMRCISEG ;SLC/JFR - CREATE IFC HL7 SEGMENTS ; Jul 23, 2024@10:17:34
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**22,66,154,202,189**;DEC 27, 1997;Build 54
- +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 OBX11
- 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
- +28 ;
- +29 ; OBX-11 is comment status. It's "F" for Admin Complete actions, "P" otherwise except if entered post-complete then "C".
- +30 ;
- +31 ;F if an admin comp. else "P"
- SET OBX11=$SELECT(ACTVT=10:"F",1:"P")
- +32 ;
- +33 ; Change status to changed (C) if comments added post-complete on IFC involving Cerner.
- +34 ;
- +35 ;
- IF $$CNVTD^GMRCIEVT(GMRCO)
- Begin DoDot:1
- +36 ; WTC p189
- NEW GMRCACT1
- SET GMRCACT1=GMRCACT-.000001
- FOR
- SET GMRCACT1=$ORDER(^GMR(123,GMRCO,40,GMRCACT1),-1)
- if 'GMRCACT1
- QUIT
- IF $PIECE(^(GMRCACT1,0),U,2)=10
- SET OBX11="C"
- QUIT
- End DoDot:1
- +37 ;
- +38 IF $GET(PROSTHCS)&((ACTVT=20)!(ACTVT=10))
- DO OBXPOST
- QUIT
- +39 ;END GMRC*202
- +40 ;
- +41 FOR
- SET CMT=$ORDER(^GMR(123,GMRCO,40,GMRCACT,1,CMT))
- if 'CMT
- QUIT
- Begin DoDot:1
- +42 SET GMRCPCS(1)=3
- SET GMRCPCS(2)="TX"
- +43 ;MKN GMRC*3.0*154 Encode any special characters
- SET GMRCPCS(3)="^COMMENTS^"
- SET GMRCPCS(4)=CMT
- +44 ;MKN GMRC*3.0*154 Encode any special characters
- SET GMRCPCS(5)=$$ENCODE^GMRCHL7E($GET(^GMR(123,GMRCO,40,GMRCACT,1,CMT,0)),.TCH)
- +45 ; P189 WTC 6/29/2023
- SET GMRCPCS(11)=OBX11
- +46 SET ^TMP("GMRCWP",$JOB,CMT)=$$BUILD^GMRCISEG("OBX",.GMRCPCS)
- End DoDot:1
- +47 ;
- +48 MERGE @GMRCSEG=^TMP("GMRCWP",$JOB)
- +49 KILL ^TMP("GMRCWP",$JOB)
- +50 QUIT
- +51 ;
- 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)
- +13 ;
- 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
