source: FOIAVistA/tag/r/SURGERY-SR/SRCHL7A.m@ 1590

SRCHL7A ;BIR/SJA - RECEIVE HL-7 CONSULTS MESSAGE, PARSE INTO COMPONENTS AND CALL PFSS GET ACCOUNT API ;12/17/04  05:10 PM
 ;;3.0; Surgery ;**144**;24 Jun 93
 ;
 ; Reference to $$GETACCT^IBBAPI() is supported by DBIA #4664
 ; Reference to ^GMR(123.5 is supported by DBIA #3861
 ; Reference to ^DIC(40.7 is supported by DBIA #557
 ; Reference to ^DG(40.8 is supported by DBIA #2817
 Q
ORC(SRCORC) ;Get fields from ORC segment.
 ;SRCTRLC=ORC control code
 ;SRCORNP=provider
 I $E(SRCMSG,1,6)'="ORC|NW" S SRCQT=1 Q
 S SRCTRLC=$P(SRCORC,"|",2)
 S SRCORNP=$P(SRCORC,"|",13)
 S SRCODT=$P(SRCORC,"|",16)
 Q
OBR(SRCOBR) ;Get fields from OBR segment.
 ;SRCSS=type of consult, field 9, 1-4 if NO, then not surgery
 ;Must have 99CON in SRC99C.
 ;SRCODT=observation date/time
 S SRC99C=$P($P(SRCOBR,"|",5),"^",6)
 I SRC99C'="99CON" S SRCSS="NO",SRCQT=1 Q
 S SRCSST=$P($P(SRCOBR,"|",5),"^",4)
 S SRCSS=$$GET1^DIQ(123.5,SRCSST,.01) D
 .I SRCSS["SURGERY REQUEST" S SRCSS=1 Q
 .;then not surgery
 .S SRCSS="NO"
 I SRCSS="NO" S SRCQT=1 Q
 S SRCODT=$P(SRCOBR,"|",7)
 I SRCODT]"" S SRCODT=$$FMDATE^SRCHL7U(SRCODT)
 S SRCATN=$P(SRCOBR,"|",20)
 S SRCSTDT=$P(SRCOBR,"|",23)
 I SRCSTDT]"" S SRCSTDT=$$FMDATE^SRCHL7U(SRCSTDT)
 S SRCINTR=$P(SRCOBR,"|",33)
 Q
ZSV(SRCZSV) ;Get service from ZSV segment
 S SRCZSS=$P($P(SRCZSV,"|",2),"^",4)
 ;Set the service if ZSV provided
 I $L($P(SRCZSV,"|",3)) S SRCOTXT=$P(SRCZSV,"|",3) ;consult type
 Q
OBX(SRCOBX) ;Get fields from OBX segment and set into SRC variables
 ;SRCOID=observation id identifying value in seg. 5
 ;free text or code^free text^I9C
 S SRCMSG=MSG(SRCOBX)
 S SRCOID=$P($P(SRCMSG,"|",4),"^",2)
 I SRCOID="REASON FOR REQUEST" D
 .S LN=0 F  S LN=$O(MSG(SRCOBX,LN)) Q:LN=""  S SRCRF(LN+1)=$G(MSG(SRCOBX,LN)),SRCRFL=SRCRF(LN+1),SRCRF=$$UP^XLFSTR($G(SRCRF(LN+1))) D
 ..I SRCRF["DATE OF OPERATION:" S (SRDOP,X)=$P(SRCRFL,": ",2),%DT="XT" D ^%DT S:Y>0 SRCPV2(8)=Y I Y'>0 D NOW^%DTC S SRCPV2(8)=X Q
 ..I $P(SRCRF,":")="SURGEON" S SRCPV1(17)=$$FN($P(SRCRFL,": ",2)) Q
 ..I SRCRF["ATTENDING SURGEON:" S SRCPV1(7)=$$FN($P(SRCRFL,": ",2)) Q
 ..I SRCRF["SURGICAL SPECIALTY:" S SRX=$O(^SRO(137.45,"B1",$P(SRCRFL,": ",2),0)) Q
 ..I SRCRF["PRINCIPAL PREOPERATIVE DIAGNOSIS:" D
 ...S II=LN F  S II=$O(MSG(SRCOBX,II)) Q:MSG(SRCOBX,II)=""!($L(SRCRF)>70)  S SRCRFL=SRCRFL_" "_$G(MSG(SRCOBX,II))
 ...S SRCDG1(1,4)=$E($P(SRCRFL,": ",2),1,40) Q
 ..I SRCRF["PRINCIPAL OPERATIVE PROCEDURE:" D
 ...S II=LN F  S II=$O(MSG(SRCOBX,II)) Q:MSG(SRCOBX,II)=""!($L(SRCRF)>90)  S SRCRFL=SRCRFL_" "_$G(MSG(SRCOBX,II))
 ...S SRCPR1(4)=$E($P(SRCRFL,": ",2),1,60) Q
 S SRCPV1(18)=$O(^DIC(40.7,"C",429,0)) I SRX S SRCSURG(2)=$P($G(^SRO(137.45,SRX,0)),"^",2),SRCPV1(3)=$P($G(^SRO(137.45,SRX,0)),"^",5)
 S SRCPV1(2)="O"
 Q
EN(MSG) ;Entry point from protocol SR RECEIVE
 Q:'+$$SWSTAT^IBBAPI()
 ;MSG = local array which contains the HL7 segments
 N LN,SRC99C,SRCARFN,SRCATN,SRCDG1,SRCDIV,SRCINTR,SRCMSG,SRCNOD
 N SRCOBR,SRCOBX,SRCODT,SRCOID,SRCORNP,SRCOTXT,SRCPNM,SRCPR1,SRCPV2,SRCQT
 N SRCRATSN,SRCRB,SRCRF,SRCRFL,SRCSEND,SRCSS,SRCSST,SRCSTDT,SRCSURG,SRX
 N SRCTRLC,SRCZSS,SRDFN,SRDOP,Y
 S SRCMSG="",SRCNOD=0,SRCPV2(8)=0,(SRCPV1(7),SRCPV1(17),SRCSURG(2),SRCDG1(1,4),SRCPR1(4))=""
 F  S SRCNOD=$O(MSG(SRCNOD)) Q:SRCNOD=""  S SRCMSG=$G(MSG(SRCNOD)) I $E(SRCMSG,1,3)="MSH" D  Q
 .S SRCSEND=$P(SRCMSG,"|",3),SRCDIV=$O(^DG(40.8,"AD",$P(SRCMSG,"|",4),0))
 ;SRCQT, stop flag in loop
 S SRCMSG="",SRCNOD=0,SRCQT=0
 F  S SRCNOD=$O(MSG(SRCNOD)) Q:SRCNOD=""  Q:SRCQT=1  S SRCMSG=$G(MSG(SRCNOD)) D
 .I $E(SRCMSG,1,3)="PID" D PID^SRCHL7U(SRCMSG) Q
 .;look at ORC|NW for new order
 .I $E(SRCMSG,1,3)="ORC" D ORC(SRCMSG) Q
 .I SRCQT=1 Q
 .I $E(SRCMSG,1,3)="OBR" D OBR(SRCMSG) I SRCSS="NO" S SRCQT=1 Q
 .I SRCQT=1 Q
 .;look at ZSV for surgery (4)
 .I $E(SRCMSG,1,3)="ZSV" D ZSV(SRCMSG) Q
 .I $E(SRCMSG,1,3)="OBX" D OBX(SRCNOD) Q
 I SRCSS="NO" Q  ;not surgery request
 I SRCPV2(8)'>0!(SRCSURG(2)="")!(SRCDG1(1,4)="")!(SRCPR1(4)="") D REJECT^SRCHL7U Q
 ;check for new order, NW, and a surgery consult in SRCSS
 I '$D(SRCTRLC)!(SRCTRLC'="NW")!('$D(SRCSS))!(SRCSS="NO") D EXIT^SRCHL7U Q
ACCT S SRCARFN=+$$GETACCT^IBBAPI(SRDFN,"","A05","ACCT;SRCHL7A",.SRCPV1,.SRCPV2,.SRCPR1,.SRCDG1,"",SRCDIV,"",.SRCSURG)
 I '$G(SRCARFN) D REJECT^SRCHL7U Q
 D EXIT^SRCHL7U
 Q
FN(X) ;Return New Person Code give Name from HL-7 segment
 I X["(" Q +$P(X,"(",2)
 K DIC S DIC="^VA(200,",DIC(0)="XM" D ^DIC K DIC
 Q $S(Y'=-1:+Y,1:"")