BHL3MI.m

BHL3MI ; cmi/anchorage/maw - BHL Setup HL7 message and pass to APCD ; [ 06/07/2002 7:04 AM ]

 ;;3.01;BHL IHS Interfaces with GIS;**1,14**;JUN 01, 2002

 ;

 ;

 ;

 ;this routine will pull the message out of the UIF and give it back

 ;to APCD the way they expect

 ;

 ;cmi/anch/maw 10/7/2005 modified due to message structure at

 ;Claremore with new 3M interface

 ;

 ;

 ;

MAIN ;EP - this is the main routine driver

 D SET,MSH,PASS,EOJ^BHLSETI

 Q

 ;

SET ;-- this is the main routine driver

 Q:'$G(UIF)

 S BHLUIF=UIF

 S BHL3MC=1

 N BHLBSEG,BHLCNT

 S BHLCNT=1

 S BHL3DA=0 F  S BHL3DA=$O(^INTHU(UIF,3,BHL3DA)) Q:'BHL3DA  D

 . N BHLSEG

 . S BHLSEG=$G(^INTHU(UIF,3,BHL3DA,0))

 . N I

 . F I=1:1:$L(BHLSEG) D

 .. S $E(BHLBSEG,BHLCNT,BHLCNT)=$E(BHLSEG,I,I)

 .. D CHKSEG(BHLBSEG,BHL3MC)

 .. S BHLCNT=BHLCNT+1

 D SETSEG(BHL3MC,BHLBSEG)

 Q

 ;

CHKSEG(BSEG,MC) ;-- see if we are at a start of a segment

 I $E(BSEG,$L(BSEG)-2,$L(BSEG))="EVN" D SETSEG(MC,BSEG) Q

 I $E(BSEG,$L(BSEG)-2,$L(BSEG))="PID" D SETSEG(MC,BSEG) Q

 I $E(BSEG,$L(BSEG)-2,$L(BSEG))="PV1" D SETSEG(MC,BSEG) Q

 I $E(BSEG,$L(BSEG)-2,$L(BSEG))="DG1" D SETSEG(MC,BSEG) Q

 I $E(BSEG,$L(BSEG)-2,$L(BSEG))="PR1" D SETSEG(MC,BSEG) Q

 I $E(BSEG,$L(BSEG)-2,$L(BSEG))="Z3A" D SETSEG(MC,BSEG) Q

 I $E(BSEG,$L(BSEG)-2,$L(BSEG))="Z3R" D SETSEG(MC,BSEG) Q

 Q

 ;

SETSEG(C,BS) ;-- setup the segment array

 S APCDHL7M(C)=$E(BS,1,$L(BS)-3)

 S BHL3MC=BHL3MC+1

 S BHLBSEG=$E(BHLBSEG,$L(BHLBSEG)-2,$L(BHLBSEG))

 S BHLCNT=3

 Q

 ;

MSH ;-- let's setup the msh segment

 S BHLMDA=0 F  S BHLMDA=$O(APCDHL7M(BHLMDA)) Q:'BHLMDA  D

 . Q:$E(APCDHL7M(BHLMDA),1,3)'="MSH"

 . S FS=$E(APCDHL7M(BHLMDA),4,4)

 . S ENC=$P(APCDHL7M(BHLMDA),FS,2)

 Q

 ;

PASS ;-- call 3M filer

 D IN^APCD3M

 Q

 ;

BHL3MI    ; cmi/anchorage/maw - BHL Setup HL7 message and pass to APCD ; [ 06/07/2002 7:04 AM ]

 +1       ;;3.01;BHL IHS Interfaces with GIS;**1,14**;JUN 01, 2002

 +2       ;

 +3       ;

 +4       ;

 +5       ;this routine will pull the message out of the UIF and give it back

 +6       ;to APCD the way they expect

 +7       ;

 +8       ;cmi/anch/maw 10/7/2005 modified due to message structure at

 +9       ;Claremore with new 3M interface

 +10      ;

 +11      ;

 +12      ;

MAIN      ;EP - this is the main routine driver

 +1        DO SET

           DO MSH

           DO PASS

           DO EOJ^BHLSETI

 +2        QUIT 

 +3       ;

SET       ;-- this is the main routine driver

 +1        IF '$GET(UIF)

               QUIT 

 +2        SET BHLUIF=UIF

 +3        SET BHL3MC=1

 +4        NEW BHLBSEG,BHLCNT

 +5        SET BHLCNT=1

 +6        SET BHL3DA=0

           FOR 

               SET BHL3DA=$ORDER(^INTHU(UIF,3,BHL3DA))

               IF 'BHL3DA

                   QUIT 

               Begin DoDot:1

 +7                NEW BHLSEG

 +8                SET BHLSEG=$GET(^INTHU(UIF,3,BHL3DA,0))

 +9                NEW I

 +10               FOR I=1:1:$LENGTH(BHLSEG)

                       Begin DoDot:2

 +11                       SET $EXTRACT(BHLBSEG,BHLCNT,BHLCNT)=$EXTRACT(BHLSEG,I,I)

 +12                       DO CHKSEG(BHLBSEG,BHL3MC)

 +13                       SET BHLCNT=BHLCNT+1

                       End DoDot:2

               End DoDot:1

 +14       DO SETSEG(BHL3MC,BHLBSEG)

 +15       QUIT 

 +16      ;

CHKSEG(BSEG,MC) ;-- see if we are at a start of a segment

 +1        IF $EXTRACT(BSEG,$LENGTH(BSEG)-2,$LENGTH(BSEG))="EVN"

               DO SETSEG(MC,BSEG)

               QUIT 

 +2        IF $EXTRACT(BSEG,$LENGTH(BSEG)-2,$LENGTH(BSEG))="PID"

               DO SETSEG(MC,BSEG)

               QUIT 

 +3        IF $EXTRACT(BSEG,$LENGTH(BSEG)-2,$LENGTH(BSEG))="PV1"

               DO SETSEG(MC,BSEG)

               QUIT 

 +4        IF $EXTRACT(BSEG,$LENGTH(BSEG)-2,$LENGTH(BSEG))="DG1"

               DO SETSEG(MC,BSEG)

               QUIT 

 +5        IF $EXTRACT(BSEG,$LENGTH(BSEG)-2,$LENGTH(BSEG))="PR1"

               DO SETSEG(MC,BSEG)

               QUIT 

 +6        IF $EXTRACT(BSEG,$LENGTH(BSEG)-2,$LENGTH(BSEG))="Z3A"

               DO SETSEG(MC,BSEG)

               QUIT 

 +7        IF $EXTRACT(BSEG,$LENGTH(BSEG)-2,$LENGTH(BSEG))="Z3R"

               DO SETSEG(MC,BSEG)

               QUIT 

 +8        QUIT 

 +9       ;

SETSEG(C,BS) ;-- setup the segment array

 +1        SET APCDHL7M(C)=$EXTRACT(BS,1,$LENGTH(BS)-3)

 +2        SET BHL3MC=BHL3MC+1

 +3        SET BHLBSEG=$EXTRACT(BHLBSEG,$LENGTH(BHLBSEG)-2,$LENGTH(BHLBSEG))

 +4        SET BHLCNT=3

 +5        QUIT 

 +6       ;

MSH       ;-- let's setup the msh segment

 +1        SET BHLMDA=0

           FOR 

               SET BHLMDA=$ORDER(APCDHL7M(BHLMDA))

               IF 'BHLMDA

                   QUIT 

               Begin DoDot:1

 +2                IF $EXTRACT(APCDHL7M(BHLMDA),1,3)'="MSH"

                       QUIT 

 +3                SET FS=$EXTRACT(APCDHL7M(BHLMDA),4,4)

 +4                SET ENC=$PIECE(APCDHL7M(BHLMDA),FS,2)

               End DoDot:1

 +5        QUIT 

 +6       ;

PASS      ;-- call 3M filer

 +1        DO IN^APCD3M

 +2        QUIT 

 +3       ;