source: WorldVistAEHR/trunk/r/SURGERY-SR/SRCHL7A.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.3 KB
Line 
1SRCHL7A ;BIR/SJA - RECEIVE HL-7 CONSULTS MESSAGE, PARSE INTO COMPONENTS AND CALL PFSS GET ACCOUNT API ;12/17/04 05:10 PM
2 ;;3.0; Surgery ;**144**;24 Jun 93
3 ;
4 ; Reference to $$GETACCT^IBBAPI() is supported by DBIA #4664
5 ; Reference to ^GMR(123.5 is supported by DBIA #3861
6 ; Reference to ^DIC(40.7 is supported by DBIA #557
7 ; Reference to ^DG(40.8 is supported by DBIA #2817
8 Q
9ORC(SRCORC) ;Get fields from ORC segment.
10 ;SRCTRLC=ORC control code
11 ;SRCORNP=provider
12 I $E(SRCMSG,1,6)'="ORC|NW" S SRCQT=1 Q
13 S SRCTRLC=$P(SRCORC,"|",2)
14 S SRCORNP=$P(SRCORC,"|",13)
15 S SRCODT=$P(SRCORC,"|",16)
16 Q
17OBR(SRCOBR) ;Get fields from OBR segment.
18 ;SRCSS=type of consult, field 9, 1-4 if NO, then not surgery
19 ;Must have 99CON in SRC99C.
20 ;SRCODT=observation date/time
21 S SRC99C=$P($P(SRCOBR,"|",5),"^",6)
22 I SRC99C'="99CON" S SRCSS="NO",SRCQT=1 Q
23 S SRCSST=$P($P(SRCOBR,"|",5),"^",4)
24 S SRCSS=$$GET1^DIQ(123.5,SRCSST,.01) D
25 .I SRCSS["SURGERY REQUEST" S SRCSS=1 Q
26 .;then not surgery
27 .S SRCSS="NO"
28 I SRCSS="NO" S SRCQT=1 Q
29 S SRCODT=$P(SRCOBR,"|",7)
30 I SRCODT]"" S SRCODT=$$FMDATE^SRCHL7U(SRCODT)
31 S SRCATN=$P(SRCOBR,"|",20)
32 S SRCSTDT=$P(SRCOBR,"|",23)
33 I SRCSTDT]"" S SRCSTDT=$$FMDATE^SRCHL7U(SRCSTDT)
34 S SRCINTR=$P(SRCOBR,"|",33)
35 Q
36ZSV(SRCZSV) ;Get service from ZSV segment
37 S SRCZSS=$P($P(SRCZSV,"|",2),"^",4)
38 ;Set the service if ZSV provided
39 I $L($P(SRCZSV,"|",3)) S SRCOTXT=$P(SRCZSV,"|",3) ;consult type
40 Q
41OBX(SRCOBX) ;Get fields from OBX segment and set into SRC variables
42 ;SRCOID=observation id identifying value in seg. 5
43 ;free text or code^free text^I9C
44 S SRCMSG=MSG(SRCOBX)
45 S SRCOID=$P($P(SRCMSG,"|",4),"^",2)
46 I SRCOID="REASON FOR REQUEST" D
47 .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
48 ..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
49 ..I $P(SRCRF,":")="SURGEON" S SRCPV1(17)=$$FN($P(SRCRFL,": ",2)) Q
50 ..I SRCRF["ATTENDING SURGEON:" S SRCPV1(7)=$$FN($P(SRCRFL,": ",2)) Q
51 ..I SRCRF["SURGICAL SPECIALTY:" S SRX=$O(^SRO(137.45,"B1",$P(SRCRFL,": ",2),0)) Q
52 ..I SRCRF["PRINCIPAL PREOPERATIVE DIAGNOSIS:" D
53 ...S II=LN F S II=$O(MSG(SRCOBX,II)) Q:MSG(SRCOBX,II)=""!($L(SRCRF)>70) S SRCRFL=SRCRFL_" "_$G(MSG(SRCOBX,II))
54 ...S SRCDG1(1,4)=$E($P(SRCRFL,": ",2),1,40) Q
55 ..I SRCRF["PRINCIPAL OPERATIVE PROCEDURE:" D
56 ...S II=LN F S II=$O(MSG(SRCOBX,II)) Q:MSG(SRCOBX,II)=""!($L(SRCRF)>90) S SRCRFL=SRCRFL_" "_$G(MSG(SRCOBX,II))
57 ...S SRCPR1(4)=$E($P(SRCRFL,": ",2),1,60) Q
58 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)
59 S SRCPV1(2)="O"
60 Q
61EN(MSG) ;Entry point from protocol SR RECEIVE
62 Q:'+$$SWSTAT^IBBAPI()
63 ;MSG = local array which contains the HL7 segments
64 N LN,SRC99C,SRCARFN,SRCATN,SRCDG1,SRCDIV,SRCINTR,SRCMSG,SRCNOD
65 N SRCOBR,SRCOBX,SRCODT,SRCOID,SRCORNP,SRCOTXT,SRCPNM,SRCPR1,SRCPV2,SRCQT
66 N SRCRATSN,SRCRB,SRCRF,SRCRFL,SRCSEND,SRCSS,SRCSST,SRCSTDT,SRCSURG,SRX
67 N SRCTRLC,SRCZSS,SRDFN,SRDOP,Y
68 S SRCMSG="",SRCNOD=0,SRCPV2(8)=0,(SRCPV1(7),SRCPV1(17),SRCSURG(2),SRCDG1(1,4),SRCPR1(4))=""
69 F S SRCNOD=$O(MSG(SRCNOD)) Q:SRCNOD="" S SRCMSG=$G(MSG(SRCNOD)) I $E(SRCMSG,1,3)="MSH" D Q
70 .S SRCSEND=$P(SRCMSG,"|",3),SRCDIV=$O(^DG(40.8,"AD",$P(SRCMSG,"|",4),0))
71 ;SRCQT, stop flag in loop
72 S SRCMSG="",SRCNOD=0,SRCQT=0
73 F S SRCNOD=$O(MSG(SRCNOD)) Q:SRCNOD="" Q:SRCQT=1 S SRCMSG=$G(MSG(SRCNOD)) D
74 .I $E(SRCMSG,1,3)="PID" D PID^SRCHL7U(SRCMSG) Q
75 .;look at ORC|NW for new order
76 .I $E(SRCMSG,1,3)="ORC" D ORC(SRCMSG) Q
77 .I SRCQT=1 Q
78 .I $E(SRCMSG,1,3)="OBR" D OBR(SRCMSG) I SRCSS="NO" S SRCQT=1 Q
79 .I SRCQT=1 Q
80 .;look at ZSV for surgery (4)
81 .I $E(SRCMSG,1,3)="ZSV" D ZSV(SRCMSG) Q
82 .I $E(SRCMSG,1,3)="OBX" D OBX(SRCNOD) Q
83 I SRCSS="NO" Q ;not surgery request
84 I SRCPV2(8)'>0!(SRCSURG(2)="")!(SRCDG1(1,4)="")!(SRCPR1(4)="") D REJECT^SRCHL7U Q
85 ;check for new order, NW, and a surgery consult in SRCSS
86 I '$D(SRCTRLC)!(SRCTRLC'="NW")!('$D(SRCSS))!(SRCSS="NO") D EXIT^SRCHL7U Q
87ACCT S SRCARFN=+$$GETACCT^IBBAPI(SRDFN,"","A05","ACCT;SRCHL7A",.SRCPV1,.SRCPV2,.SRCPR1,.SRCDG1,"",SRCDIV,"",.SRCSURG)
88 I '$G(SRCARFN) D REJECT^SRCHL7U Q
89 D EXIT^SRCHL7U
90 Q
91FN(X) ;Return New Person Code give Name from HL-7 segment
92 I X["(" Q +$P(X,"(",2)
93 K DIC S DIC="^VA(200,",DIC(0)="XM" D ^DIC K DIC
94 Q $S(Y'=-1:+Y,1:"")
Note: See TracBrowser for help on using the repository browser.