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 ;
