BHLBPS ; IHS/TUCSON/DCP - HL7 RDS Message Processor ;
;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
;
;------------------------------------------------------------
; This routine processes HL7 RDS messages and files the data
; into RPMS/PCC. It does not produce any output variables.
;
; This routine requires the input variables listed below.
; These variables are supplied by the HL7 package, based
; on the incoming message that it was processing when it
; branched to this routine via the protocol file.
;
; HLNEXT = M code to be executed to $O through
; the nodes of global that contains the
; message being processed.
;
; HLNODE = A node from the message text global. This
; variable is set to the next line of the
; incoming message when HLNEXT is executed.
;
; HLQUIT = A variable that indicates when there are no
; more nodes (message lines) to process.
;
; HLMTIENS = The IEN in the MESSAGE TEXT FILE (#772)
; for the subscriber application.
;
; HL("APAT") = The application acknowledgement condition
; from the message header segment of the
; incoming message.
;
; HL("EID") = The IEN in the PROTOCOL FILE (#101) of
; the event driver protocol that generated
; the incoming message.
;
; HL("EIDS") = The IEN in the PROTOCOL FILE (#101) of
; the subscriber protocol that is receiving
; the incoming message.
;
; HL("FS") = HL7 field separator character for the
; incoming message.
;
; HL("ECH") = HL7 encoding characters for the incoming
; message.
;
; HL("MID") = The HL7 message control ID for the incoming
; message.
;
;
START ; ENTRY POINT from HL7 client protocol
;
D INIT
F X HLNEXT Q:HLQUIT'>0 S BHLSEG=$P(HLNODE,BHLFS,1) I BHLSEG'="",$T(@BHLSEG)'="" S BHLDATA=$P(HLNODE,BHLFS,2,$L(HLNODE,BHLFS)) D @BHLSEG
D FILING,ACKMSG
I $D(HLERR),BHLERR'="" S BHLERR=BHLERR_". "_HLERR
I BHLERR'="" S HLERR=BHLERR D BULLETIN
D DISPLAY
END D EOJ
Q
;-------------------------------------------------------------
MSH ;
N BHLFAC
; adjust pieces so piece numbers match HL7 field numbers
S BHLDATA=BHLFS_BHLDATA
; save MSH data for use in ACK message
S BHLMSH=BHLDATA
; HL7 receiving facility number
S BHLFAC=$P(BHLDATA,BHLFS,6)
S $P(BHLBPS("PAT DEMO"),BHLFS,6)=BHLFAC
S $P(BHLBPS("VISIT"),BHLFS,3)=BHLFAC
Q
;
PID ;
S BHLBPS("PID")=""
; name
S $P(BHLBPS("PAT DEMO"),BHLFS,1)=$$FMNAME^HLFNC($P(BHLDATA,BHLFS,5),HLECH)
; dob
S $P(BHLBPS("PAT DEMO"),BHLFS,2)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,7))
; sex
S $P(BHLBPS("PAT DEMO"),BHLFS,3)=$P(BHLDATA,BHLFS,8)
; ssn
S $P(BHLBPS("PAT DEMO"),BHLFS,4)=$P(BHLDATA,BHLFS,19)
; chart number (HRN)
S $P(BHLBPS("PAT DEMO"),BHLFS,5)=$P($P(BHLDATA,BHLFS,3),BHLCS,1)
Q
;
ORC ;
S BHLBPS("ORC")=""
; provider DEA #
S $P(BHLBPS("MED"),BHLFS,11)=$P($P(BHLDATA,BHLFS,12),BHLCS,1)
; provider name - last, first, middle, suffix - 30 char max
S $P(BHLBPS("MED"),BHLFS,12)=$$FMNAME^HLFNC($E($P($P(BHLDATA,BHLFS,12),BHLCS,2,5),1,30),HLECH)
Q
;
RXD ;
S BHLBPS("RXD")=""
; rx number
S $P(BHLBPS("MED"),BHLFS,1)=$P(BHLDATA,BHLFS,7)
; quantity
S $P(BHLBPS("MED"),BHLFS,2)=$P(BHLDATA,BHLFS,4)
; dispense date
S $P(BHLBPS("MED"),BHLFS,4)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,3))
; xkey
S $P(BHLBPS("MED"),BHLFS,5)=$P(BHLDATA,BHLFS,7)_"_"_$P(BHLDATA,BHLFS,1)
; ndc
S $P(BHLBPS("MED"),BHLFS,7)=$P($P(BHLDATA,BHLFS,2),BHLCS,4)
; drug
S $P(BHLBPS("MED"),BHLFS,8)=$P($P(BHLDATA,BHLFS,2),BHLCS,5)
; units
S $P(BHLBPS("MED"),BHLFS,9)=$P(BHLDATA,BHLFS,5)
; sig
S $P(BHLBPS("MED"),BHLFS,10)=$P(BHLDATA,BHLFS,9)
Q
;
Z02 ;
S BHLBPS("Z02")=""
; days
S $P(BHLBPS("MED"),BHLFS,3)=$P(BHLDATA,BHLFS,2)
; action
S $P(BHLBPS("MED"),BHLFS,6)=$P(BHLDATA,BHLFS,3)
; rph code
S $P(BHLBPS("MED"),BHLFS,13)=$P($P(BHLDATA,BHLFS,1),BHLCS,1)
; rph name - last, first, middle - 30 char max
S $P(BHLBPS("MED"),BHLFS,14)=$$FMNAME^HLFNC($E($P($P(BHLDATA,BHLFS,1),BHLCS,2,4),1,30),HLECH)
Q
;
Z03 ;
S BHLBPS("Z03")=""
; visit date
S $P(BHLBPS("VISIT"),BHLFS,1)=$$FMDATE^HLFNC($P(BHLDATA,BHLFS,1))
; service catagory
S $P(BHLBPS("VISIT"),BHLFS,2)=$P(BHLDATA,BHLFS,2)
Q
;
FILING ;
N SEG
F SEG="PID","ORC","RXD","Z02","Z03" I '$D(BHLBPS(SEG)) S BHLERR=BHLERR_","_SEG
I BHLERR'="" S BHLERR="MISSING MESSAGE SEGMENT(S): "_$E(BHLERR,2,$L(BHLERR)) Q
D ^BHLBPS1
Q
;
ACKMSG ;
; transmit acknowledgement message back to sending application if required
N HLRESLTA
I $G(HL("APAT"))="",$G(HL("ACAT"))'="" Q
I HL("APAT")="NE" Q
I HL("APAT")="SU",BHLERR'="" Q
I HL("APAT")="ER",BHLERR="" Q
S HLA("HLA",1)="MSA"_BHLFS_$S(BHLERR="":"AA",1:"AE")_BHLFS_HL("MID")
I BHLERR'="" S HLA("HLA",2)="ERR"_BHLFS_BHLERR
Q:$G(BHLDBUG) ; don't send ACK in programmer debug mode
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLTA)
I $P(HLRESLTA,U,2)'="" S BHLERR=BHLERR_" ** APP ACK GEN ERROR "_$TR(HLRESLTA,U,":")_" **"
Q
;
BULLETIN ; Send Error Bulletin
;
Q:$G(BHLDBUG)
N %X,%Y,X,XMB,XMDT,XMDUZ,Y1
S XMB="BHLBPS RX-PCC MESSAGE ERROR"
S XMB(1)=BHLERR
S XMB(2)=$G(BHLEDATA)
S XMB(3)=HLMTIEN
S XMDUZ=.5
D ^XMB
Q
;
EOJ ;
K BHLDATA,BHLFS,BHLCS,BHLBPS,BHLMSH,BHLERR,BHLSEG,BHLEDATA
K D0,DA,DD,DFN,DIC,DIK,DO,DR,F,I,X,Y,%,HLA
Q
;
INIT ;
D ^XBKVAR ; make sure kernel variables are defined
D EOJ
K HLERR
S BHLERR=""
S BHLBPS("MED")=""
S BHLBPS("VISIT")=""
S BHLBPS("PAT DEMO")=""
S BHLFS=HL("FS") ; HL7 field separator
S HLECH=HL("ECH") ; HL7 encoding characters
S BHLCS=$E(HLECH,1) ; HL7 component separator
Q
;
DEBUG ; ENTRY POINT for programmer testing
;
; This entry point will not send any bulletins or HL7 messages.
; The ACK message, HL7 errors, and bulletin errors will be written
; to the screen instead. If the error involves data stored in
; the APCDALVR array, that array will be written out to
; ^TMP("BHLBPS",$J,"APCDALVR",I), where I is the ACPDALVR index.
;
N BHLMSH9,BHLSAN,X,X2,HL,HLMTIEN,HLNODE,HLQUIT,HLNEXT,HLECH
N %1,%DT,DISYS,IO,DIR,X,Y
;
S DIR(0)="NO",DIR("T")=300,DIR("A")="Enter IEN for message to be processed" D ^DIR
S HLMTIEN=Y Q:"^"[HLMTIEN
;
S HLNODE=$G(^HL(772,HLMTIEN,"IN",1,0))
I $E(HLNODE,1,3)'="MSH" W !,"MSH is missing" Q
;
; extract data from MSH
;
S HL("FS")=$E(HLNODE,4)
S HL("ECH")=$P(HLNODE,HL("FS"),2)
S HL("SAN")=$P(HLNODE,HL("FS"),3)
S HL("RAN")=$P(HLNODE,HL("FS"),5)
S BHLMSH9=$P(HLNODE,HL("FS"),9)
S HL("MTN")=$P(BHLMSH9,$E(HL("ECH"),1),1)
S HL("ETN")=$P(BHLMSH9,$E(HL("ECH"),1),2)
S HL("MID")=$P(HLNODE,HL("FS"),10)
S HL("ACAT")=$P(HLNODE,HL("FS"),15)
S HL("APAT")=$P(HLNODE,HL("FS"),16)
;
; check MSH for missing data
;
I HL("SAN")="" W !,"sending application is missing from MSH" Q
I HL("RAN")="" W !,"receiving application is missing from MSH" Q
I HL("MTN")="" W !,"message type is missing from MSH" Q
I HL("ETN")="" W !,"event type is missing from MSH" Q
;
;Validate message type
;
S HL("MTP")=0
S:(HL("MTN")'="") HL("MTP")=+$O(^HL(771.2,"B",HL("MTN"),0))
I ('HL("MTP")) W !,"Invalid Message Type" Q
;
;Validate event type
;
S HL("ETP")=0
S:(HL("ETN")'="") HL("ETP")=+$O(^HL(779.001,"B",HL("ETN"),0))
I ('HL("ETP")) W !,"Invalid Event Type" Q
;
;Validate sending application
;
S HL("SAP")=+$O(^HL(771,"B",HL("SAN"),0))
I 'HL("SAP") S BHLSAN=$$UPPER^HLFNC(HL("RAN")),HL("SAP")=+$O(^HL(771,"B",BHLSAN,0))
I 'HL("SAP") W !,"Invalid Sending Application" Q
;
;Validate receiving application
;
S HL("RAP")=+$O(^HL(771,"B",HL("RAN"),0))
I 'HL("RAP") S X=$$UPPER^HLFNC(HL("RAN")),HL("RAP")=+$O(^HL(771,"B",X,0))
I 'HL("RAP") W !,"Invalid Receiving Application"
S X2=$G(^HL(771,HL("RAP"),0))
I (X2="") W !,"Invalid Receiving Application" Q
I ($P(X2,"^",2)'="a") W !,"Receiving Application is Inactive" Q
;
;Find Server Protocol - based on message and event type
;
S HL("EID")=+$O(^ORD(101,"AHL1",HL("SAP"),HL("MTP"),HL("ETP"),0))
I 'HL("EID") W !,"Invalid Event" Q
;
;Find Client Protocol - in ITEM multiple of Server Protocol
;
S HL("EIDS")=0
F S HL("EIDS")=+$O(^ORD(101,HL("EID"),10,"B",HL("EIDS"))) Q:('HL("EIDS")) S X=$G(^ORD(101,HL("EIDS"),770)) Q:(($P(X,"^",2)=HL("RAP"))&($P(X,"^",3)=HL("MTP"))&($P(X,"^",4)=HL("ETP")))
I 'HL("EIDS") W !,"Invalid Receiving Application for this Event" Q
;
W !,"Processing..."
S HLNODE=""
S HLQUIT=0
S HLNEXT="S HLQUIT=$O(^HL(772,HLMTIEN,""IN"",HLQUIT)) S:HLQUIT HLNODE=$G(^(HLQUIT,0))"
K BHLMSH9,BHLSAN,X,X2
K ^TMP("BHLBPS",$J)
S BHLDBUG=1
D START
W !,"Done"
K BHLDBUG
Q
;
DISPLAY ; Display result messages (programmer debug mode only)
;
Q:'$G(BHLDBUG)
W !,"Error Message:",!,?3,$S($G(HLERR)="":"none",1:HLERR)
W !,"Error Data:",!,?3,$S($G(BHLEDATA)="":"none",1:BHLEDATA)
W !,"ACK message:"
I '$D(HLA) W !,?3,"none" Q
N I S I=0 F S I=$O(HLA("HLA",I)) Q:I="" W !,?3,HLA("HLA",I)
Q
BHLBPS ; IHS/TUCSON/DCP - HL7 RDS Message Processor ;
+1 ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
+2 ;
+3 ;------------------------------------------------------------
+4 ; This routine processes HL7 RDS messages and files the data
+5 ; into RPMS/PCC. It does not produce any output variables.
+6 ;
+7 ; This routine requires the input variables listed below.
+8 ; These variables are supplied by the HL7 package, based
+9 ; on the incoming message that it was processing when it
+10 ; branched to this routine via the protocol file.
+11 ;
+12 ; HLNEXT = M code to be executed to $O through
+13 ; the nodes of global that contains the
+14 ; message being processed.
+15 ;
+16 ; HLNODE = A node from the message text global. This
+17 ; variable is set to the next line of the
+18 ; incoming message when HLNEXT is executed.
+19 ;
+20 ; HLQUIT = A variable that indicates when there are no
+21 ; more nodes (message lines) to process.
+22 ;
+23 ; HLMTIENS = The IEN in the MESSAGE TEXT FILE (#772)
+24 ; for the subscriber application.
+25 ;
+26 ; HL("APAT") = The application acknowledgement condition
+27 ; from the message header segment of the
+28 ; incoming message.
+29 ;
+30 ; HL("EID") = The IEN in the PROTOCOL FILE (#101) of
+31 ; the event driver protocol that generated
+32 ; the incoming message.
+33 ;
+34 ; HL("EIDS") = The IEN in the PROTOCOL FILE (#101) of
+35 ; the subscriber protocol that is receiving
+36 ; the incoming message.
+37 ;
+38 ; HL("FS") = HL7 field separator character for the
+39 ; incoming message.
+40 ;
+41 ; HL("ECH") = HL7 encoding characters for the incoming
+42 ; message.
+43 ;
+44 ; HL("MID") = The HL7 message control ID for the incoming
+45 ; message.
+46 ;
+47 ;
START ; ENTRY POINT from HL7 client protocol
+1 ;
+2 DO INIT
+3 FOR
XECUTE HLNEXT
IF HLQUIT'>0
QUIT
SET BHLSEG=$PIECE(HLNODE,BHLFS,1)
IF BHLSEG'=""
IF $TEXT(@BHLSEG)'=""
SET BHLDATA=$PIECE(HLNODE,BHLFS,2,$LENGTH(HLNODE,BHLFS))
DO @BHLSEG
+4 DO FILING
DO ACKMSG
+5 IF $DATA(HLERR)
IF BHLERR'=""
SET BHLERR=BHLERR_". "_HLERR
+6 IF BHLERR'=""
SET HLERR=BHLERR
DO BULLETIN
+7 DO DISPLAY
END DO EOJ
+1 QUIT
+2 ;-------------------------------------------------------------
MSH ;
+1 NEW BHLFAC
+2 ; adjust pieces so piece numbers match HL7 field numbers
+3 SET BHLDATA=BHLFS_BHLDATA
+4 ; save MSH data for use in ACK message
+5 SET BHLMSH=BHLDATA
+6 ; HL7 receiving facility number
+7 SET BHLFAC=$PIECE(BHLDATA,BHLFS,6)
+8 SET $PIECE(BHLBPS("PAT DEMO"),BHLFS,6)=BHLFAC
+9 SET $PIECE(BHLBPS("VISIT"),BHLFS,3)=BHLFAC
+10 QUIT
+11 ;
PID ;
+1 SET BHLBPS("PID")=""
+2 ; name
+3 SET $PIECE(BHLBPS("PAT DEMO"),BHLFS,1)=$$FMNAME^HLFNC($PIECE(BHLDATA,BHLFS,5),HLECH)
+4 ; dob
+5 SET $PIECE(BHLBPS("PAT DEMO"),BHLFS,2)=$$FMDATE^HLFNC($PIECE(BHLDATA,BHLFS,7))
+6 ; sex
+7 SET $PIECE(BHLBPS("PAT DEMO"),BHLFS,3)=$PIECE(BHLDATA,BHLFS,8)
+8 ; ssn
+9 SET $PIECE(BHLBPS("PAT DEMO"),BHLFS,4)=$PIECE(BHLDATA,BHLFS,19)
+10 ; chart number (HRN)
+11 SET $PIECE(BHLBPS("PAT DEMO"),BHLFS,5)=$PIECE($PIECE(BHLDATA,BHLFS,3),BHLCS,1)
+12 QUIT
+13 ;
ORC ;
+1 SET BHLBPS("ORC")=""
+2 ; provider DEA #
+3 SET $PIECE(BHLBPS("MED"),BHLFS,11)=$PIECE($PIECE(BHLDATA,BHLFS,12),BHLCS,1)
+4 ; provider name - last, first, middle, suffix - 30 char max
+5 SET $PIECE(BHLBPS("MED"),BHLFS,12)=$$FMNAME^HLFNC($EXTRACT($PIECE($PIECE(BHLDATA,BHLFS,12),BHLCS,2,5),1,30),HLECH)
+6 QUIT
+7 ;
RXD ;
+1 SET BHLBPS("RXD")=""
+2 ; rx number
+3 SET $PIECE(BHLBPS("MED"),BHLFS,1)=$PIECE(BHLDATA,BHLFS,7)
+4 ; quantity
+5 SET $PIECE(BHLBPS("MED"),BHLFS,2)=$PIECE(BHLDATA,BHLFS,4)
+6 ; dispense date
+7 SET $PIECE(BHLBPS("MED"),BHLFS,4)=$$FMDATE^HLFNC($PIECE(BHLDATA,BHLFS,3))
+8 ; xkey
+9 SET $PIECE(BHLBPS("MED"),BHLFS,5)=$PIECE(BHLDATA,BHLFS,7)_"_"_$PIECE(BHLDATA,BHLFS,1)
+10 ; ndc
+11 SET $PIECE(BHLBPS("MED"),BHLFS,7)=$PIECE($PIECE(BHLDATA,BHLFS,2),BHLCS,4)
+12 ; drug
+13 SET $PIECE(BHLBPS("MED"),BHLFS,8)=$PIECE($PIECE(BHLDATA,BHLFS,2),BHLCS,5)
+14 ; units
+15 SET $PIECE(BHLBPS("MED"),BHLFS,9)=$PIECE(BHLDATA,BHLFS,5)
+16 ; sig
+17 SET $PIECE(BHLBPS("MED"),BHLFS,10)=$PIECE(BHLDATA,BHLFS,9)
+18 QUIT
+19 ;
Z02 ;
+1 SET BHLBPS("Z02")=""
+2 ; days
+3 SET $PIECE(BHLBPS("MED"),BHLFS,3)=$PIECE(BHLDATA,BHLFS,2)
+4 ; action
+5 SET $PIECE(BHLBPS("MED"),BHLFS,6)=$PIECE(BHLDATA,BHLFS,3)
+6 ; rph code
+7 SET $PIECE(BHLBPS("MED"),BHLFS,13)=$PIECE($PIECE(BHLDATA,BHLFS,1),BHLCS,1)
+8 ; rph name - last, first, middle - 30 char max
+9 SET $PIECE(BHLBPS("MED"),BHLFS,14)=$$FMNAME^HLFNC($EXTRACT($PIECE($PIECE(BHLDATA,BHLFS,1),BHLCS,2,4),1,30),HLECH)
+10 QUIT
+11 ;
Z03 ;
+1 SET BHLBPS("Z03")=""
+2 ; visit date
+3 SET $PIECE(BHLBPS("VISIT"),BHLFS,1)=$$FMDATE^HLFNC($PIECE(BHLDATA,BHLFS,1))
+4 ; service catagory
+5 SET $PIECE(BHLBPS("VISIT"),BHLFS,2)=$PIECE(BHLDATA,BHLFS,2)
+6 QUIT
+7 ;
FILING ;
+1 NEW SEG
+2 FOR SEG="PID","ORC","RXD","Z02","Z03"
IF '$DATA(BHLBPS(SEG))
SET BHLERR=BHLERR_","_SEG
+3 IF BHLERR'=""
SET BHLERR="MISSING MESSAGE SEGMENT(S): "_$EXTRACT(BHLERR,2,$LENGTH(BHLERR))
QUIT
+4 DO ^BHLBPS1
+5 QUIT
+6 ;
ACKMSG ;
+1 ; transmit acknowledgement message back to sending application if required
+2 NEW HLRESLTA
+3 IF $GET(HL("APAT"))=""
IF $GET(HL("ACAT"))'=""
QUIT
+4 IF HL("APAT")="NE"
QUIT
+5 IF HL("APAT")="SU"
IF BHLERR'=""
QUIT
+6 IF HL("APAT")="ER"
IF BHLERR=""
QUIT
+7 SET HLA("HLA",1)="MSA"_BHLFS_$SELECT(BHLERR="":"AA",1:"AE")_BHLFS_HL("MID")
+8 IF BHLERR'=""
SET HLA("HLA",2)="ERR"_BHLFS_BHLERR
+9 ; don't send ACK in programmer debug mode
IF $GET(BHLDBUG)
QUIT
+10 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLTA)
+11 IF $PIECE(HLRESLTA,U,2)'=""
SET BHLERR=BHLERR_" ** APP ACK GEN ERROR "_$TRANSLATE(HLRESLTA,U,":")_" **"
+12 QUIT
+13 ;
BULLETIN ; Send Error Bulletin
+1 ;
+2 IF $GET(BHLDBUG)
QUIT
+3 NEW %X,%Y,X,XMB,XMDT,XMDUZ,Y1
+4 SET XMB="BHLBPS RX-PCC MESSAGE ERROR"
+5 SET XMB(1)=BHLERR
+6 SET XMB(2)=$GET(BHLEDATA)
+7 SET XMB(3)=HLMTIEN
+8 SET XMDUZ=.5
+9 DO ^XMB
+10 QUIT
+11 ;
EOJ ;
+1 KILL BHLDATA,BHLFS,BHLCS,BHLBPS,BHLMSH,BHLERR,BHLSEG,BHLEDATA
+2 KILL D0,DA,DD,DFN,DIC,DIK,DO,DR,F,I,X,Y,%,HLA
+3 QUIT
+4 ;
INIT ;
+1 ; make sure kernel variables are defined
DO ^XBKVAR
+2 DO EOJ
+3 KILL HLERR
+4 SET BHLERR=""
+5 SET BHLBPS("MED")=""
+6 SET BHLBPS("VISIT")=""
+7 SET BHLBPS("PAT DEMO")=""
+8 ; HL7 field separator
SET BHLFS=HL("FS")
+9 ; HL7 encoding characters
SET HLECH=HL("ECH")
+10 ; HL7 component separator
SET BHLCS=$EXTRACT(HLECH,1)
+11 QUIT
+12 ;
DEBUG ; ENTRY POINT for programmer testing
+1 ;
+2 ; This entry point will not send any bulletins or HL7 messages.
+3 ; The ACK message, HL7 errors, and bulletin errors will be written
+4 ; to the screen instead. If the error involves data stored in
+5 ; the APCDALVR array, that array will be written out to
+6 ; ^TMP("BHLBPS",$J,"APCDALVR",I), where I is the ACPDALVR index.
+7 ;
+8 NEW BHLMSH9,BHLSAN,X,X2,HL,HLMTIEN,HLNODE,HLQUIT,HLNEXT,HLECH
+9 NEW %1,%DT,DISYS,IO,DIR,X,Y
+10 ;
+11 SET DIR(0)="NO"
SET DIR("T")=300
SET DIR("A")="Enter IEN for message to be processed"
DO ^DIR
+12 SET HLMTIEN=Y
IF "^"[HLMTIEN
QUIT
+13 ;
+14 SET HLNODE=$GET(^HL(772,HLMTIEN,"IN",1,0))
+15 IF $EXTRACT(HLNODE,1,3)'="MSH"
WRITE !,"MSH is missing"
QUIT
+16 ;
+17 ; extract data from MSH
+18 ;
+19 SET HL("FS")=$EXTRACT(HLNODE,4)
+20 SET HL("ECH")=$PIECE(HLNODE,HL("FS"),2)
+21 SET HL("SAN")=$PIECE(HLNODE,HL("FS"),3)
+22 SET HL("RAN")=$PIECE(HLNODE,HL("FS"),5)
+23 SET BHLMSH9=$PIECE(HLNODE,HL("FS"),9)
+24 SET HL("MTN")=$PIECE(BHLMSH9,$EXTRACT(HL("ECH"),1),1)
+25 SET HL("ETN")=$PIECE(BHLMSH9,$EXTRACT(HL("ECH"),1),2)
+26 SET HL("MID")=$PIECE(HLNODE,HL("FS"),10)
+27 SET HL("ACAT")=$PIECE(HLNODE,HL("FS"),15)
+28 SET HL("APAT")=$PIECE(HLNODE,HL("FS"),16)
+29 ;
+30 ; check MSH for missing data
+31 ;
+32 IF HL("SAN")=""
WRITE !,"sending application is missing from MSH"
QUIT
+33 IF HL("RAN")=""
WRITE !,"receiving application is missing from MSH"
QUIT
+34 IF HL("MTN")=""
WRITE !,"message type is missing from MSH"
QUIT
+35 IF HL("ETN")=""
WRITE !,"event type is missing from MSH"
QUIT
+36 ;
+37 ;Validate message type
+38 ;
+39 SET HL("MTP")=0
+40 IF (HL("MTN")'="")
SET HL("MTP")=+$ORDER(^HL(771.2,"B",HL("MTN"),0))
+41 IF ('HL("MTP"))
WRITE !,"Invalid Message Type"
QUIT
+42 ;
+43 ;Validate event type
+44 ;
+45 SET HL("ETP")=0
+46 IF (HL("ETN")'="")
SET HL("ETP")=+$ORDER(^HL(779.001,"B",HL("ETN"),0))
+47 IF ('HL("ETP"))
WRITE !,"Invalid Event Type"
QUIT
+48 ;
+49 ;Validate sending application
+50 ;
+51 SET HL("SAP")=+$ORDER(^HL(771,"B",HL("SAN"),0))
+52 IF 'HL("SAP")
SET BHLSAN=$$UPPER^HLFNC(HL("RAN"))
SET HL("SAP")=+$ORDER(^HL(771,"B",BHLSAN,0))
+53 IF 'HL("SAP")
WRITE !,"Invalid Sending Application"
QUIT
+54 ;
+55 ;Validate receiving application
+56 ;
+57 SET HL("RAP")=+$ORDER(^HL(771,"B",HL("RAN"),0))
+58 IF 'HL("RAP")
SET X=$$UPPER^HLFNC(HL("RAN"))
SET HL("RAP")=+$ORDER(^HL(771,"B",X,0))
+59 IF 'HL("RAP")
WRITE !,"Invalid Receiving Application"
+60 SET X2=$GET(^HL(771,HL("RAP"),0))
+61 IF (X2="")
WRITE !,"Invalid Receiving Application"
QUIT
+62 IF ($PIECE(X2,"^",2)'="a")
WRITE !,"Receiving Application is Inactive"
QUIT
+63 ;
+64 ;Find Server Protocol - based on message and event type
+65 ;
+66 SET HL("EID")=+$ORDER(^ORD(101,"AHL1",HL("SAP"),HL("MTP"),HL("ETP"),0))
+67 IF 'HL("EID")
WRITE !,"Invalid Event"
QUIT
+68 ;
+69 ;Find Client Protocol - in ITEM multiple of Server Protocol
+70 ;
+71 SET HL("EIDS")=0
+72 FOR
SET HL("EIDS")=+$ORDER(^ORD(101,HL("EID"),10,"B",HL("EIDS")))
IF ('HL("EIDS"))
QUIT
SET X=$GET(^ORD(101,HL("EIDS"),770))
IF (($PIECE(X,"^",2)=HL("RAP"))&($PIECE(X,"^",3)=HL("MTP"))&($PIECE(X,"^",4)=HL("ETP")))
QUIT
+73 IF 'HL("EIDS")
WRITE !,"Invalid Receiving Application for this Event"
QUIT
+74 ;
+75 WRITE !,"Processing..."
+76 SET HLNODE=""
+77 SET HLQUIT=0
+78 SET HLNEXT="S HLQUIT=$O(^HL(772,HLMTIEN,""IN"",HLQUIT)) S:HLQUIT HLNODE=$G(^(HLQUIT,0))"
+79 KILL BHLMSH9,BHLSAN,X,X2
+80 KILL ^TMP("BHLBPS",$JOB)
+81 SET BHLDBUG=1
+82 DO START
+83 WRITE !,"Done"
+84 KILL BHLDBUG
+85 QUIT
+86 ;
DISPLAY ; Display result messages (programmer debug mode only)
+1 ;
+2 IF '$GET(BHLDBUG)
QUIT
+3 WRITE !,"Error Message:",!,?3,$SELECT($GET(HLERR)="":"none",1:HLERR)
+4 WRITE !,"Error Data:",!,?3,$SELECT($GET(BHLEDATA)="":"none",1:BHLEDATA)
+5 WRITE !,"ACK message:"
+6 IF '$DATA(HLA)
WRITE !,?3,"none"
QUIT
+7 NEW I
SET I=0
FOR
SET I=$ORDER(HLA("HLA",I))
IF I=""
QUIT
WRITE !,?3,HLA("HLA",I)
+8 QUIT
