- 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 Feb 19, 2025@00:01:23 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