Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRHL7A

RMPRHL7A.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;Patch #78 - 09/25/03 - TH - Add multiple DG1 and ZCL segments.
  1. ;Patch #83 - 03/02/09 - DDA - Add check in OBR to screen out IFCs generated locally.
  1. ;
  1. Q
  1. URG(X) ;Return Urgency give Z-code from HL-7 segment; see ORC+9
  1. 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)
  1. I $E(X,1)="Z" S X=$S(X="ZT":"TODAY",X="ZE":"EMERGENCY",1:"")
  1. Q X
  1. ;
  1. ORC(RMPRORC) ;Get fields from ORC segment and set into RMPR variables
  1. S ^TMP("SPS","HL7",2)=RMPRORC
  1. ;RMPRTRLC=ORC control code from HL7 Table 119
  1. ;RMPRURGI=priority/urgency RMPRPLCR=who entered the order
  1. ;RMPRORNP=provider RMPRNATO=nature of order
  1. ;RMPRAD=date of request RMPROCR=order request reason
  1. ;RMPR RMPRORFN=oe/rr file number
  1. ;RMPRO=file 668 IEN - if not a new order
  1. ;RMPRS38=order status - taken from Table 38, HL7 standard
  1. I $E(RMPRMSG,1,6)'="ORC|NW" S RMPRQT=1 Q
  1. S RMPRTRLC=$P(RMPRORC,"|",2)
  1. S RMPRORFN=$P(RMPRORC,"|",3)
  1. S RMPRORFN=$P($P(RMPRORFN,"^",1),";",1)
  1. S RMPRAPP=$P($P(RMPRORC,"|",3),"^",2)
  1. S RMPRS38=$P(RMPRORC,"|",6)
  1. S RMPRURGI=$P($P(RMPRORC,"|",8),"^",6)
  1. S RMPRPLCR=$P(RMPRORC,"|",11)
  1. S RMPRORNP=$P(RMPRORC,"|",13)
  1. I $L(RMPRURGI) S RMPRURGI=$$URG(RMPRURGI)
  1. S RMPRO=+$P($P(RMPRORC,"|",4),"^",1)
  1. N RMPRODT S RMPRODT=$P(RMPRORC,"|",16)
  1. S RMPRAD=$$FMDATE^RMPRHL7(RMPRODT)
  1. S RMPROCR=$P(RMPRORC,"|",17)
  1. S RMPRNATO=$P(RMPROCR,"^",5)
  1. Q
  1. 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
  1. ;Must have 99CON in RMPR99C.
  1. ;
  1. ;RMPRODT=observation date/time
  1. ;RMPRPRI=procedure from file ^ORD(101,
  1. ;
  1. N RMPR99C
  1. S RMPR99C=$P($P(RMPROBR,"|",5),"^",6)
  1. I RMPR99C'="99CON" S RMPRSS="NO",RMPRQT=1 Q
  1. S RMPRSST=$P($P(RMPROBR,"|",5),"^",4)
  1. S RMPRSS=$P(^GMR(123.5,RMPRSST,0),U,1) D
  1. .;translate to set of codes
  1. .I RMPRSS["PROSTHETICS IFC" S RMPRSS="NO" Q
  1. .I RMPRSS["PROSTHETICS REQUEST" S RMPRSS=1 Q
  1. .I RMPRSS["CONTACT LENS REQUEST" S RMPRSS=3 Q
  1. .I RMPRSS["HOME OXYGEN REQUEST" S RMPRSS=4 Q
  1. .I RMPRSS["EYEGLASS REQUEST" S RMPRSS=2 Q
  1. .;then not prosthetics
  1. .S RMPRSS="NO"
  1. ;
  1. I RMPRSS="NO" S RMPRQT=1 Q
  1. ;
  1. S RMPRODT=$P(RMPROBR,"|",7)
  1. I RMPRODT]"" S RMPRODT=$$FMDATE^RMPRHL7(RMPRODT)
  1. S RMPRATN=$P(RMPROBR,"|",20)
  1. S RMPRSTDT=$P(RMPROBR,"|",23)
  1. S RMPRSTDT=$$FMDATE^RMPRHL7(RMPRSTDT)
  1. S RMPRS668=$P(RMPROBR,"|",26)
  1. S RMPRINTR=$P(RMPROBR,"|",33)
  1. Q
  1. ;
  1. DG1(RMPRDG1) ;Get fields from DG1 and ZCL segments
  1. ; RMPRSID = Set ID
  1. ; RMPRDIAG = pointer to ICD DIAGNOSIS (#80)
  1. ; RMPRCI = Outpat. Classification Type
  1. ; RMPRVAL = Value of each SC or EI - 0,1,Null.
  1. S RMPRMSG=MSG(RMPRDG1)
  1. S RMPRSID=$P(RMPRMSG,"|",2)
  1. I $P(RMPRMSG,"|",1)="DG1" D
  1. . S RMPRDIAG=$P($P(RMPRMSG,"|",4),"^",1)
  1. . S RMPRMSG1(RMPRSID,1)=RMPRDIAG
  1. I $P(RMPRMSG,"|",1)="ZCL" D
  1. . S RMPRCI=$P(RMPRMSG,"|",3)
  1. . S RMPRVAL=$P(RMPRMSG,"|",4)
  1. . S RMPRMSG1(RMPRSID,RMPRCI+1)=RMPRVAL
  1. Q
  1. ;
  1. ZSV(RMPRZSV) ;Get service from ZSV segment
  1. S RMPRZSS=$P($P(RMPRZSV,"|",2),"^",4)
  1. ;Set the service if ZSV provided
  1. I $L($P(RMPRZSV,"|",3)) S RMPROTXT=$P(RMPRZSV,"|",3) ;consult type
  1. Q
  1. ;
  1. 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.
  1. ;RMPROID=observation id identifying value in seg. 5
  1. ;RMPRVAL=observation value coded by segment 3
  1. ;RMPRPRDG=provisional diagnosis
  1. ;free text or code^free text^I9C
  1. S RMPRMSG=MSG(RMPROBX)
  1. S RMPRVTYP=$P(RMPRMSG,"|",3),RMPROID=$P($P(RMPRMSG,"|",4),"^",2)
  1. S RMPRVAL=$P(RMPROID,"^",3)
  1. I RMPROID="REASON FOR REQUEST" D
  1. .S RMPRRFQ(1)=$P(RMPRMSG,"|",6)
  1. .S LN=0 F S LN=$O(MSG(RMPROBX,LN)) Q:LN="" S RMPRRFQ(LN+1)=MSG(RMPROBX,LN)
  1. .Q
  1. I RMPROID="PROVISIONAL DIAGNOSIS" D Q
  1. . I RMPRVTYP="TX" S RMPRPRDG=$P(RMPRMSG,"|",6) Q
  1. . I RMPRVTYP="CE" D Q
  1. .. N PRDXSEG S PRDXSEG=$P(RMPRMSG,"|",6)
  1. .. S RMPRPRDG=$P(PRDXSEG,"^",2)_" ("_$P(PRDXSEG,"^")_")"
  1. .. S RMPRPRCD=$P(PRDXSEG,"^")
  1. I RMPROID["COMMENT" D
  1. .S RMPRCMT(1)=$P(RMPRMSG,"|",6)
  1. .S LN=0 F S LN=$O(MSG(RMPROBX,NL)) Q:LN="" S RMPRCMT(LN+1)=MSG(RMPROBX,LN)
  1. .Q
  1. K LN
  1. Q
  1. ;
  1. EN(MSG) ;Entry point from protocol RMPR RECEIVE
  1. ;
  1. ;MSG = local array which contains the HL-7 segments
  1. ;RMPRFAC=sending facility
  1. ;RMPRMTP=message type
  1. N DFN,RMPRACT,RMPRADD,RMPRFAC,RMPRMTP,RMPRPNM,RMPRO,RMPROCR,RMPRORNP
  1. N RMPRORFN,RMPRPLCR,RMPRRB,RMPRSEND,RMPRSTS,RMPRTRLC,RMPRWARD,ORIFN
  1. N RMPRTRLC,RMPRAD,ORC,RMPRSBR,RMPRZSS,RMPRSS,RMPRSST,RMPROTXT
  1. N RMPRMSGO
  1. S RMPRMSG="",RMPRNOD=0,RMPRI=0
  1. F S RMPRNOD=$O(MSG(RMPRNOD)) Q:RMPRNOD="" S RMPRMSG=MSG(RMPRNOD) I $E(RMPRMSG,1,3)="MSH" D Q
  1. .S RMPRSEND=$P(RMPRMSG,"|",3),RMPRFAC=$P(RMPRMSG,"|",4),RMPRMTP=$P(RMPRMSG,"|",9)
  1. .Q
  1. ;RMPRQT, stop flag in loop
  1. S RMPRMSG="",RMPRNOD=0,RMPRQT=0,N=0
  1. F S RMPRNOD=$O(MSG(RMPRNOD)) Q:RMPRNOD="" Q:RMPRQT=1 S RMPRMSG=MSG(RMPRNOD) D
  1. .I $E(RMPRMSG,1,3)="PID" D PID^RMPRHL7U(RMPRMSG) Q
  1. .I $E(RMPRMSG,1,3)="PV1" D PV1^RMPRHL7U(RMPRMSG) Q
  1. .;look at ORC|NW for new order
  1. .I $E(RMPRMSG,1,3)="ORC" D ORC(RMPRMSG) Q
  1. .I RMPRQT=1 Q
  1. .I $E(RMPRMSG,1,3)="OBR" D OBR(RMPRMSG) I RMPRSS="NO" S RMPRQT=1 K RMPRSS Q
  1. .I RMPRQT=1 Q
  1. .;Patch #78 - Add multiple DG1 and ZCL segments
  1. .I $E(RMPRMSG,1,3)="DG1"!($E(RMPRMSG,1,3)="ZCL") D DG1(RMPRNOD) Q
  1. .;look at ZSV for Prosthetic (4)
  1. .I $E(RMPRMSG,1,3)="ZSV" D ZSV(RMPRMSG) Q
  1. .I $E(RMPRMSG,1,3)="OBX" D OBX(RMPRNOD) Q
  1. .;I $E(RMPRMSG,1,3)="NTE" D NTE^RMPRHL7U(.MSG,RMPRNOD,RMPRO,RMPRTRLC) Q
  1. .Q
  1. K N
  1. ;check for new order, NW, and a prosthetic consult in RMPRSS
  1. I '$D(RMPRTRLC) D EXIT^RMPRHL7U Q
  1. I RMPRTRLC'="NW" D EXIT^RMPRHL7U Q
  1. I '$D(RMPRSS) D EXIT^RMPRHL7U Q
  1. I RMPRSS="NO" D EXIT^RMPRHL7U Q
  1. ;
  1. D NEW^RMPRHL7B
  1. ;
  1. I '$D(RMPRO) D REJECT^RMPRHL7U(.MSG,"unable to file order"),EXIT^RMPRHL7U Q
  1. ;
  1. D RTN(RMPRORFN,.RMPRO)
  1. ;
  1. D EXIT^RMPRHL7U
  1. Q
  1. ;
  1. RTN(RMPRORN,RMPRO) ;Put ^OR(100, ien for order into ^RMPR(668,
  1. S DA=RMPRO
  1. S DIE="^RMPR(668,",DR="19////^S X=RMPRORN"
  1. L +^RMPR(668,RMPRO) D ^DIE L -^RMPR(668,RMPRO)
  1. K DIE,DR
  1. ; set file 123 ien
  1. S RMPRGMRC=$$PKGID^ORX8($P(^RMPR(668,RMPRO,0),U,14))
  1. I RMPRGMRC["GMRC" S $P(^RMPR(668,RMPRO,0),U,15)=+RMPRGMRC
  1. E D REJECT^RMPRHL7U(.MSG),EXIT^RMPRHL7U
  1. Q