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