SRCHL7A.m

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:"")

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:"")