RMPRHL7A ;HINES CIOFO/HNC - Receive HL-7 CPRS Message, parse into components and store in File 668 ;3/13/00
;;3.0;PROSTHETICS;**45,78,83**;Feb 09, 1996;Build 20
;
;Patch #78 - 09/25/03 - TH - Add multiple DG1 and ZCL segments.
;Patch #83 - 03/02/09 - DDA - Add check in OBR to screen out IFCs generated locally.
;
Q
URG(X) ;Return Urgency give Z-code from HL-7 segment; see ORC+9
S X=$S(X="S":"STAT",X="R":"ROUTINE",X="ZT":"TODAY",X="Z24":"WITHIN 24 HOURS",X="Z48":"WITHIN 48 HOURS",X="Z72":"WITHIN 72 HOURS",X="ZW":"WITHIN 1 WEEK",X="ZM":"WITHIN 1 MONTH",X="ZNA":"NEXT AVAILABLE",1:X)
I $E(X,1)="Z" S X=$S(X="ZT":"TODAY",X="ZE":"EMERGENCY",1:"")
Q X
;
ORC(RMPRORC) ;Get fields from ORC segment and set into RMPR variables
S ^TMP("SPS","HL7",2)=RMPRORC
;RMPRTRLC=ORC control code from HL7 Table 119
;RMPRURGI=priority/urgency RMPRPLCR=who entered the order
;RMPRORNP=provider RMPRNATO=nature of order
;RMPRAD=date of request RMPROCR=order request reason
;RMPR RMPRORFN=oe/rr file number
;RMPRO=file 668 IEN - if not a new order
;RMPRS38=order status - taken from Table 38, HL7 standard
I $E(RMPRMSG,1,6)'="ORC|NW" S RMPRQT=1 Q
S RMPRTRLC=$P(RMPRORC,"|",2)
S RMPRORFN=$P(RMPRORC,"|",3)
S RMPRORFN=$P($P(RMPRORFN,"^",1),";",1)
S RMPRAPP=$P($P(RMPRORC,"|",3),"^",2)
S RMPRS38=$P(RMPRORC,"|",6)
S RMPRURGI=$P($P(RMPRORC,"|",8),"^",6)
S RMPRPLCR=$P(RMPRORC,"|",11)
S RMPRORNP=$P(RMPRORC,"|",13)
I $L(RMPRURGI) S RMPRURGI=$$URG(RMPRURGI)
S RMPRO=+$P($P(RMPRORC,"|",4),"^",1)
N RMPRODT S RMPRODT=$P(RMPRORC,"|",16)
S RMPRAD=$$FMDATE^RMPRHL7(RMPRODT)
S RMPROCR=$P(RMPRORC,"|",17)
S RMPRNATO=$P(RMPROCR,"^",5)
Q
OBR(RMPROBR) ;Get fields from OBR segment and set into RMPR variables
;RMPRSS=type of consult, field 9, 1-4 if NO, then not prosthetics
;Must have 99CON in RMPR99C.
;
;RMPRODT=observation date/time
;RMPRPRI=procedure from file ^ORD(101,
;
N RMPR99C
S RMPR99C=$P($P(RMPROBR,"|",5),"^",6)
I RMPR99C'="99CON" S RMPRSS="NO",RMPRQT=1 Q
S RMPRSST=$P($P(RMPROBR,"|",5),"^",4)
S RMPRSS=$P(^GMR(123.5,RMPRSST,0),U,1) D
.;translate to set of codes
.I RMPRSS["PROSTHETICS IFC" S RMPRSS="NO" Q
.I RMPRSS["PROSTHETICS REQUEST" S RMPRSS=1 Q
.I RMPRSS["CONTACT LENS REQUEST" S RMPRSS=3 Q
.I RMPRSS["HOME OXYGEN REQUEST" S RMPRSS=4 Q
.I RMPRSS["EYEGLASS REQUEST" S RMPRSS=2 Q
.;then not prosthetics
.S RMPRSS="NO"
;
I RMPRSS="NO" S RMPRQT=1 Q
;
S RMPRODT=$P(RMPROBR,"|",7)
I RMPRODT]"" S RMPRODT=$$FMDATE^RMPRHL7(RMPRODT)
S RMPRATN=$P(RMPROBR,"|",20)
S RMPRSTDT=$P(RMPROBR,"|",23)
S RMPRSTDT=$$FMDATE^RMPRHL7(RMPRSTDT)
S RMPRS668=$P(RMPROBR,"|",26)
S RMPRINTR=$P(RMPROBR,"|",33)
Q
;
DG1(RMPRDG1) ;Get fields from DG1 and ZCL segments
; RMPRSID = Set ID
; RMPRDIAG = pointer to ICD DIAGNOSIS (#80)
; RMPRCI = Outpat. Classification Type
; RMPRVAL = Value of each SC or EI - 0,1,Null.
S RMPRMSG=MSG(RMPRDG1)
S RMPRSID=$P(RMPRMSG,"|",2)
I $P(RMPRMSG,"|",1)="DG1" D
. S RMPRDIAG=$P($P(RMPRMSG,"|",4),"^",1)
. S RMPRMSG1(RMPRSID,1)=RMPRDIAG
I $P(RMPRMSG,"|",1)="ZCL" D
. S RMPRCI=$P(RMPRMSG,"|",3)
. S RMPRVAL=$P(RMPRMSG,"|",4)
. S RMPRMSG1(RMPRSID,RMPRCI+1)=RMPRVAL
Q
;
ZSV(RMPRZSV) ;Get service from ZSV segment
S RMPRZSS=$P($P(RMPRZSV,"|",2),"^",4)
;Set the service if ZSV provided
I $L($P(RMPRZSV,"|",3)) S RMPROTXT=$P(RMPRZSV,"|",3) ;consult type
Q
;
OBX(RMPROBX) ;Get fields from OBX segment and set into RMPR variables
;RMPRVTYP=Value type from table 668-i.e. TX(text), ST(string data),etc.
;RMPROID=observation id identifying value in seg. 5
;RMPRVAL=observation value coded by segment 3
;RMPRPRDG=provisional diagnosis
;free text or code^free text^I9C
S RMPRMSG=MSG(RMPROBX)
S RMPRVTYP=$P(RMPRMSG,"|",3),RMPROID=$P($P(RMPRMSG,"|",4),"^",2)
S RMPRVAL=$P(RMPROID,"^",3)
I RMPROID="REASON FOR REQUEST" D
.S RMPRRFQ(1)=$P(RMPRMSG,"|",6)
.S LN=0 F S LN=$O(MSG(RMPROBX,LN)) Q:LN="" S RMPRRFQ(LN+1)=MSG(RMPROBX,LN)
.Q
I RMPROID="PROVISIONAL DIAGNOSIS" D Q
. I RMPRVTYP="TX" S RMPRPRDG=$P(RMPRMSG,"|",6) Q
. I RMPRVTYP="CE" D Q
.. N PRDXSEG S PRDXSEG=$P(RMPRMSG,"|",6)
.. S RMPRPRDG=$P(PRDXSEG,"^",2)_" ("_$P(PRDXSEG,"^")_")"
.. S RMPRPRCD=$P(PRDXSEG,"^")
I RMPROID["COMMENT" D
.S RMPRCMT(1)=$P(RMPRMSG,"|",6)
.S LN=0 F S LN=$O(MSG(RMPROBX,NL)) Q:LN="" S RMPRCMT(LN+1)=MSG(RMPROBX,LN)
.Q
K LN
Q
;
EN(MSG) ;Entry point from protocol RMPR RECEIVE
;
;MSG = local array which contains the HL-7 segments
;RMPRFAC=sending facility
;RMPRMTP=message type
N DFN,RMPRACT,RMPRADD,RMPRFAC,RMPRMTP,RMPRPNM,RMPRO,RMPROCR,RMPRORNP
N RMPRORFN,RMPRPLCR,RMPRRB,RMPRSEND,RMPRSTS,RMPRTRLC,RMPRWARD,ORIFN
N RMPRTRLC,RMPRAD,ORC,RMPRSBR,RMPRZSS,RMPRSS,RMPRSST,RMPROTXT
N RMPRMSGO
S RMPRMSG="",RMPRNOD=0,RMPRI=0
F S RMPRNOD=$O(MSG(RMPRNOD)) Q:RMPRNOD="" S RMPRMSG=MSG(RMPRNOD) I $E(RMPRMSG,1,3)="MSH" D Q
.S RMPRSEND=$P(RMPRMSG,"|",3),RMPRFAC=$P(RMPRMSG,"|",4),RMPRMTP=$P(RMPRMSG,"|",9)
.Q
;RMPRQT, stop flag in loop
S RMPRMSG="",RMPRNOD=0,RMPRQT=0,N=0
F S RMPRNOD=$O(MSG(RMPRNOD)) Q:RMPRNOD="" Q:RMPRQT=1 S RMPRMSG=MSG(RMPRNOD) D
.I $E(RMPRMSG,1,3)="PID" D PID^RMPRHL7U(RMPRMSG) Q
.I $E(RMPRMSG,1,3)="PV1" D PV1^RMPRHL7U(RMPRMSG) Q
.;look at ORC|NW for new order
.I $E(RMPRMSG,1,3)="ORC" D ORC(RMPRMSG) Q
.I RMPRQT=1 Q
.I $E(RMPRMSG,1,3)="OBR" D OBR(RMPRMSG) I RMPRSS="NO" S RMPRQT=1 K RMPRSS Q
.I RMPRQT=1 Q
.;Patch #78 - Add multiple DG1 and ZCL segments
.I $E(RMPRMSG,1,3)="DG1"!($E(RMPRMSG,1,3)="ZCL") D DG1(RMPRNOD) Q
.;look at ZSV for Prosthetic (4)
.I $E(RMPRMSG,1,3)="ZSV" D ZSV(RMPRMSG) Q
.I $E(RMPRMSG,1,3)="OBX" D OBX(RMPRNOD) Q
.;I $E(RMPRMSG,1,3)="NTE" D NTE^RMPRHL7U(.MSG,RMPRNOD,RMPRO,RMPRTRLC) Q
.Q
K N
;check for new order, NW, and a prosthetic consult in RMPRSS
I '$D(RMPRTRLC) D EXIT^RMPRHL7U Q
I RMPRTRLC'="NW" D EXIT^RMPRHL7U Q
I '$D(RMPRSS) D EXIT^RMPRHL7U Q
I RMPRSS="NO" D EXIT^RMPRHL7U Q
;
D NEW^RMPRHL7B
;
I '$D(RMPRO) D REJECT^RMPRHL7U(.MSG,"unable to file order"),EXIT^RMPRHL7U Q
;
D RTN(RMPRORFN,.RMPRO)
;
D EXIT^RMPRHL7U
Q
;
RTN(RMPRORN,RMPRO) ;Put ^OR(100, ien for order into ^RMPR(668,
S DA=RMPRO
S DIE="^RMPR(668,",DR="19////^S X=RMPRORN"
L +^RMPR(668,RMPRO) D ^DIE L -^RMPR(668,RMPRO)
K DIE,DR
; set file 123 ien
S RMPRGMRC=$$PKGID^ORX8($P(^RMPR(668,RMPRO,0),U,14))
I RMPRGMRC["GMRC" S $P(^RMPR(668,RMPRO,0),U,15)=+RMPRGMRC
E D REJECT^RMPRHL7U(.MSG),EXIT^RMPRHL7U
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRHL7A 6535 printed Nov 22, 2024@17:44:56 Page 2
RMPRHL7A ;HINES CIOFO/HNC - Receive HL-7 CPRS Message, parse into components and store in File 668 ;3/13/00
+1 ;;3.0;PROSTHETICS;**45,78,83**;Feb 09, 1996;Build 20
+2 ;
+3 ;Patch #78 - 09/25/03 - TH - Add multiple DG1 and ZCL segments.
+4 ;Patch #83 - 03/02/09 - DDA - Add check in OBR to screen out IFCs generated locally.
+5 ;
+6 QUIT
URG(X) ;Return Urgency give Z-code from HL-7 segment; see ORC+9
+1 SET X=$SELECT(X="S":"STAT",X="R":"ROUTINE",X="ZT":"TODAY",X="Z24":"WITHIN 24 HOURS",X="Z48":"WITHIN 48 HOURS",X="Z72":"WITHIN 72 HOURS",X="ZW":"WITHIN 1 WEEK",X="ZM":"WITHIN 1 MONTH",X="ZNA":"NEXT AVAILABLE",1:X)
+2 IF $EXTRACT(X,1)="Z"
SET X=$SELECT(X="ZT":"TODAY",X="ZE":"EMERGENCY",1:"")
+3 QUIT X
+4 ;
ORC(RMPRORC) ;Get fields from ORC segment and set into RMPR variables
+1 SET ^TMP("SPS","HL7",2)=RMPRORC
+2 ;RMPRTRLC=ORC control code from HL7 Table 119
+3 ;RMPRURGI=priority/urgency RMPRPLCR=who entered the order
+4 ;RMPRORNP=provider RMPRNATO=nature of order
+5 ;RMPRAD=date of request RMPROCR=order request reason
+6 ;RMPR RMPRORFN=oe/rr file number
+7 ;RMPRO=file 668 IEN - if not a new order
+8 ;RMPRS38=order status - taken from Table 38, HL7 standard
+9 IF $EXTRACT(RMPRMSG,1,6)'="ORC|NW"
SET RMPRQT=1
QUIT
+10 SET RMPRTRLC=$PIECE(RMPRORC,"|",2)
+11 SET RMPRORFN=$PIECE(RMPRORC,"|",3)
+12 SET RMPRORFN=$PIECE($PIECE(RMPRORFN,"^",1),";",1)
+13 SET RMPRAPP=$PIECE($PIECE(RMPRORC,"|",3),"^",2)
+14 SET RMPRS38=$PIECE(RMPRORC,"|",6)
+15 SET RMPRURGI=$PIECE($PIECE(RMPRORC,"|",8),"^",6)
+16 SET RMPRPLCR=$PIECE(RMPRORC,"|",11)
+17 SET RMPRORNP=$PIECE(RMPRORC,"|",13)
+18 IF $LENGTH(RMPRURGI)
SET RMPRURGI=$$URG(RMPRURGI)
+19 SET RMPRO=+$PIECE($PIECE(RMPRORC,"|",4),"^",1)
+20 NEW RMPRODT
SET RMPRODT=$PIECE(RMPRORC,"|",16)
+21 SET RMPRAD=$$FMDATE^RMPRHL7(RMPRODT)
+22 SET RMPROCR=$PIECE(RMPRORC,"|",17)
+23 SET RMPRNATO=$PIECE(RMPROCR,"^",5)
+24 QUIT
OBR(RMPROBR) ;Get fields from OBR segment and set into RMPR variables
+1 ;RMPRSS=type of consult, field 9, 1-4 if NO, then not prosthetics
+2 ;Must have 99CON in RMPR99C.
+3 ;
+4 ;RMPRODT=observation date/time
+5 ;RMPRPRI=procedure from file ^ORD(101,
+6 ;
+7 NEW RMPR99C
+8 SET RMPR99C=$PIECE($PIECE(RMPROBR,"|",5),"^",6)
+9 IF RMPR99C'="99CON"
SET RMPRSS="NO"
SET RMPRQT=1
QUIT
+10 SET RMPRSST=$PIECE($PIECE(RMPROBR,"|",5),"^",4)
+11 SET RMPRSS=$PIECE(^GMR(123.5,RMPRSST,0),U,1)
Begin DoDot:1
+12 ;translate to set of codes
+13 IF RMPRSS["PROSTHETICS IFC"
SET RMPRSS="NO"
QUIT
+14 IF RMPRSS["PROSTHETICS REQUEST"
SET RMPRSS=1
QUIT
+15 IF RMPRSS["CONTACT LENS REQUEST"
SET RMPRSS=3
QUIT
+16 IF RMPRSS["HOME OXYGEN REQUEST"
SET RMPRSS=4
QUIT
+17 IF RMPRSS["EYEGLASS REQUEST"
SET RMPRSS=2
QUIT
+18 ;then not prosthetics
+19 SET RMPRSS="NO"
End DoDot:1
+20 ;
+21 IF RMPRSS="NO"
SET RMPRQT=1
QUIT
+22 ;
+23 SET RMPRODT=$PIECE(RMPROBR,"|",7)
+24 IF RMPRODT]""
SET RMPRODT=$$FMDATE^RMPRHL7(RMPRODT)
+25 SET RMPRATN=$PIECE(RMPROBR,"|",20)
+26 SET RMPRSTDT=$PIECE(RMPROBR,"|",23)
+27 SET RMPRSTDT=$$FMDATE^RMPRHL7(RMPRSTDT)
+28 SET RMPRS668=$PIECE(RMPROBR,"|",26)
+29 SET RMPRINTR=$PIECE(RMPROBR,"|",33)
+30 QUIT
+31 ;
DG1(RMPRDG1) ;Get fields from DG1 and ZCL segments
+1 ; RMPRSID = Set ID
+2 ; RMPRDIAG = pointer to ICD DIAGNOSIS (#80)
+3 ; RMPRCI = Outpat. Classification Type
+4 ; RMPRVAL = Value of each SC or EI - 0,1,Null.
+5 SET RMPRMSG=MSG(RMPRDG1)
+6 SET RMPRSID=$PIECE(RMPRMSG,"|",2)
+7 IF $PIECE(RMPRMSG,"|",1)="DG1"
Begin DoDot:1
+8 SET RMPRDIAG=$PIECE($PIECE(RMPRMSG,"|",4),"^",1)
+9 SET RMPRMSG1(RMPRSID,1)=RMPRDIAG
End DoDot:1
+10 IF $PIECE(RMPRMSG,"|",1)="ZCL"
Begin DoDot:1
+11 SET RMPRCI=$PIECE(RMPRMSG,"|",3)
+12 SET RMPRVAL=$PIECE(RMPRMSG,"|",4)
+13 SET RMPRMSG1(RMPRSID,RMPRCI+1)=RMPRVAL
End DoDot:1
+14 QUIT
+15 ;
ZSV(RMPRZSV) ;Get service from ZSV segment
+1 SET RMPRZSS=$PIECE($PIECE(RMPRZSV,"|",2),"^",4)
+2 ;Set the service if ZSV provided
+3 ;consult type
IF $LENGTH($PIECE(RMPRZSV,"|",3))
SET RMPROTXT=$PIECE(RMPRZSV,"|",3)
+4 QUIT
+5 ;
OBX(RMPROBX) ;Get fields from OBX segment and set into RMPR variables
+1 ;RMPRVTYP=Value type from table 668-i.e. TX(text), ST(string data),etc.
+2 ;RMPROID=observation id identifying value in seg. 5
+3 ;RMPRVAL=observation value coded by segment 3
+4 ;RMPRPRDG=provisional diagnosis
+5 ;free text or code^free text^I9C
+6 SET RMPRMSG=MSG(RMPROBX)
+7 SET RMPRVTYP=$PIECE(RMPRMSG,"|",3)
SET RMPROID=$PIECE($PIECE(RMPRMSG,"|",4),"^",2)
+8 SET RMPRVAL=$PIECE(RMPROID,"^",3)
+9 IF RMPROID="REASON FOR REQUEST"
Begin DoDot:1
+10 SET RMPRRFQ(1)=$PIECE(RMPRMSG,"|",6)
+11 SET LN=0
FOR
SET LN=$ORDER(MSG(RMPROBX,LN))
if LN=""
QUIT
SET RMPRRFQ(LN+1)=MSG(RMPROBX,LN)
+12 QUIT
End DoDot:1
+13 IF RMPROID="PROVISIONAL DIAGNOSIS"
Begin DoDot:1
+14 IF RMPRVTYP="TX"
SET RMPRPRDG=$PIECE(RMPRMSG,"|",6)
QUIT
+15 IF RMPRVTYP="CE"
Begin DoDot:2
+16 NEW PRDXSEG
SET PRDXSEG=$PIECE(RMPRMSG,"|",6)
+17 SET RMPRPRDG=$PIECE(PRDXSEG,"^",2)_" ("_$PIECE(PRDXSEG,"^")_")"
+18 SET RMPRPRCD=$PIECE(PRDXSEG,"^")
End DoDot:2
QUIT
End DoDot:1
QUIT
+19 IF RMPROID["COMMENT"
Begin DoDot:1
+20 SET RMPRCMT(1)=$PIECE(RMPRMSG,"|",6)
+21 SET LN=0
FOR
SET LN=$ORDER(MSG(RMPROBX,NL))
if LN=""
QUIT
SET RMPRCMT(LN+1)=MSG(RMPROBX,LN)
+22 QUIT
End DoDot:1
+23 KILL LN
+24 QUIT
+25 ;
EN(MSG) ;Entry point from protocol RMPR RECEIVE
+1 ;
+2 ;MSG = local array which contains the HL-7 segments
+3 ;RMPRFAC=sending facility
+4 ;RMPRMTP=message type
+5 NEW DFN,RMPRACT,RMPRADD,RMPRFAC,RMPRMTP,RMPRPNM,RMPRO,RMPROCR,RMPRORNP
+6 NEW RMPRORFN,RMPRPLCR,RMPRRB,RMPRSEND,RMPRSTS,RMPRTRLC,RMPRWARD,ORIFN
+7 NEW RMPRTRLC,RMPRAD,ORC,RMPRSBR,RMPRZSS,RMPRSS,RMPRSST,RMPROTXT
+8 NEW RMPRMSGO
+9 SET RMPRMSG=""
SET RMPRNOD=0
SET RMPRI=0
+10 FOR
SET RMPRNOD=$ORDER(MSG(RMPRNOD))
if RMPRNOD=""
QUIT
SET RMPRMSG=MSG(RMPRNOD)
IF $EXTRACT(RMPRMSG,1,3)="MSH"
Begin DoDot:1
+11 SET RMPRSEND=$PIECE(RMPRMSG,"|",3)
SET RMPRFAC=$PIECE(RMPRMSG,"|",4)
SET RMPRMTP=$PIECE(RMPRMSG,"|",9)
+12 QUIT
End DoDot:1
QUIT
+13 ;RMPRQT, stop flag in loop
+14 SET RMPRMSG=""
SET RMPRNOD=0
SET RMPRQT=0
SET N=0
+15 FOR
SET RMPRNOD=$ORDER(MSG(RMPRNOD))
if RMPRNOD=""
QUIT
if RMPRQT=1
QUIT
SET RMPRMSG=MSG(RMPRNOD)
Begin DoDot:1
+16 IF $EXTRACT(RMPRMSG,1,3)="PID"
DO PID^RMPRHL7U(RMPRMSG)
QUIT
+17 IF $EXTRACT(RMPRMSG,1,3)="PV1"
DO PV1^RMPRHL7U(RMPRMSG)
QUIT
+18 ;look at ORC|NW for new order
+19 IF $EXTRACT(RMPRMSG,1,3)="ORC"
DO ORC(RMPRMSG)
QUIT
+20 IF RMPRQT=1
QUIT
+21 IF $EXTRACT(RMPRMSG,1,3)="OBR"
DO OBR(RMPRMSG)
IF RMPRSS="NO"
SET RMPRQT=1
KILL RMPRSS
QUIT
+22 IF RMPRQT=1
QUIT
+23 ;Patch #78 - Add multiple DG1 and ZCL segments
+24 IF $EXTRACT(RMPRMSG,1,3)="DG1"!($EXTRACT(RMPRMSG,1,3)="ZCL")
DO DG1(RMPRNOD)
QUIT
+25 ;look at ZSV for Prosthetic (4)
+26 IF $EXTRACT(RMPRMSG,1,3)="ZSV"
DO ZSV(RMPRMSG)
QUIT
+27 IF $EXTRACT(RMPRMSG,1,3)="OBX"
DO OBX(RMPRNOD)
QUIT
+28 ;I $E(RMPRMSG,1,3)="NTE" D NTE^RMPRHL7U(.MSG,RMPRNOD,RMPRO,RMPRTRLC) Q
+29 QUIT
End DoDot:1
+30 KILL N
+31 ;check for new order, NW, and a prosthetic consult in RMPRSS
+32 IF '$DATA(RMPRTRLC)
DO EXIT^RMPRHL7U
QUIT
+33 IF RMPRTRLC'="NW"
DO EXIT^RMPRHL7U
QUIT
+34 IF '$DATA(RMPRSS)
DO EXIT^RMPRHL7U
QUIT
+35 IF RMPRSS="NO"
DO EXIT^RMPRHL7U
QUIT
+36 ;
+37 DO NEW^RMPRHL7B
+38 ;
+39 IF '$DATA(RMPRO)
DO REJECT^RMPRHL7U(.MSG,"unable to file order")
DO EXIT^RMPRHL7U
QUIT
+40 ;
+41 DO RTN(RMPRORFN,.RMPRO)
+42 ;
+43 DO EXIT^RMPRHL7U
+44 QUIT
+45 ;
RTN(RMPRORN,RMPRO) ;Put ^OR(100, ien for order into ^RMPR(668,
+1 SET DA=RMPRO
+2 SET DIE="^RMPR(668,"
SET DR="19////^S X=RMPRORN"
+3 LOCK +^RMPR(668,RMPRO)
DO ^DIE
LOCK -^RMPR(668,RMPRO)
+4 KILL DIE,DR
+5 ; set file 123 ien
+6 SET RMPRGMRC=$$PKGID^ORX8($PIECE(^RMPR(668,RMPRO,0),U,14))
+7 IF RMPRGMRC["GMRC"
SET $PIECE(^RMPR(668,RMPRO,0),U,15)=+RMPRGMRC
+8 IF '$TEST
DO REJECT^RMPRHL7U(.MSG)
DO EXIT^RMPRHL7U
+9 QUIT
