HLLP ;AISC/SAW-HL7 Hybrid Lower Level Protocol Receiver/Sender ;9/5/96 10:50 [ 04/02/2003 8:36 AM ]
;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 01, 2003
;;1.6;HEALTH LEVEL SEVEN;**1,12**;Oct 13, 1995
;This routine is used for the Version 1.5 Interface Only
INIT ;Initialize Variables
;----- BEGIN IHS MODIFICATION - HL*1.6*1004
I $G(IOT)="CHAN" D ^HLZTCP Q ; IHS/ITSC/TPF 08/19/02 TCP/IP network device check. SAME REDIRECT USED FOR CACHE TCP AS WELL AS MSM TCP
;----- END IHS MODIFICATION
;
S X="ERR^HLLP" S @^%ZOSF("TRAP") I $D(HLION) S IOP=HLION D ^%ZIS G EXIT:POP
I '$D(HLION) D HOME^%ZIS G EXIT:POP S HLION=$S(ION']"":"UNKNOWN",1:ION)
S IOP="NULL DEVICE" D ^%ZIS G EXIT:POP K IOP U IO D DT^DICRW S HLTIME=% U IO(0) X ^%ZOSF("TYPE-AHEAD")
K %,%H,%I,X S (DTIME,HLTRIES)=0 S:$D(HLNDAP0) DTIME=$P(HLNDAP0,"^",9),HLTRIES=$P(HLNDAP0,"^",5) S:DTIME'>0 DTIME=60 S:HLTRIES'>0 HLTRIES=3
I $D(^%ZOSF("OS")),^%ZOSF("OS")["VAX" U IO(0):PACK X ^%ZOSF("EOFF")
E U IO(0) X ^%ZOSF("EOFF")
S HLLPC=^%ZOSF("LPC"),X=255,HLTRM=^%ZOSF("TRMRD") X ^%ZOSF("RM") X ^%ZOSF("TRMON")
LOOP ;Infinite loop to check for HL7 messages to send/receive
F S HLLOG=$S($D(^HL(770,"ALOG",HLION)):1,1:0) D CHKREC,CHKSEND I $$S^%ZTLOAD S ZTSTOP=1 Q
EXIT Q
ERR ;Trap error
K HLL(1),^TMP("HLR",$J),^TMP("HLS",$J) D @^%ZOSF("ERRTN"),^%ZISC Q
CHKREC ;Check if there are HL7 messages to receive
D REC I '$D(HLDTOUT),'HLERR S HLSDATA(1)=$C(11)_"N21"_$C(13)_HLERR,HLC1=0,HLC2="" D SENDN K HLSDATA,HLERR G CHKREC
I '$D(HLDTOUT) U IO K HLERR D ^HLCHK
U IO Q
CHKSEND ;Check if there are HL7 messages to send
Q:'$D(HLNDAP)
I '$D(HLNDAP0) S HLNDAP0=$G(^HL(770,HLNDAP,0))
S HLDA=+$O(^HL(772,"AC","O",+$P(HLNDAP0,U,12),0)) G:'HLDA EX
S HLDA0=$G(^HL(772,HLDA,0)) G:HLDA0']"" EX
S HLXMZ=+$P(HLDA0,"^",5)
I 'HLXMZ D G EX
.D STATUS^HLTF0(HLDA,4,"","No pointer to Message file(#3.9)")
I '$D(^XMB(3.9,HLXMZ)) D G EX
.D STATUS^HLTF0(HLDA,4,"","No message found at #"_HLXMZ_" in Message file(#3.9)")
I '$O(^XMB(3.9,HLXMZ,2,0)) D G EX
.D STATUS^HLTF0(HLDA,4,"","No message contents at #"_HLXMZ_" in Message file(#3.9)")
S (HLI,HLTRIED)=0,HLSDT=+HLDA0 F HLJ=1:1 S HLI=$O(^XMB(3.9,HLXMZ,2,HLI)) Q:HLI'>0 S ^TMP("HLS",$J,HLSDT,HLJ)=$G(^XMB(3.9,HLXMZ,2,HLI,0))
CS1 S HLTRIED=HLTRIED+1 K ^TMP("HLR",$J),HLSDATA D SEND,REC I HLTRIED'=HLTRIES G CS1:$D(HLDTOUT) G CS1:$E(X0)="N"
G EX:$D(HLDTOUT)
I $E(X0)="N" S HLAC=4,HLMSG="Lower Level Protocol Error - "_$S($E(X1)="X":"Checksum",1:"Character Count")_" Did Not Match" D STATUS^HLTF0(HLDA,HLAC,HLMSG) G EX
I $S('$D(HLL(1)):1,"BHS,MSH"'[$E(HLL(1),1,3):1,1:0) S HLAC=4,HLMSG="Application Level error - Header Segment Missing" D STATUS^HLTF0(HLDA,HLAC,HLMSG) G EX
K HLXMZ D CHK^HLCHK,IN^HLTF(HLMTN,HLMID,HLTIME)
EX K HLAC,HLDA,HLDA0,HLERR,HLMSG,HLI,HLJ,^TMP("HLS",$J),^TMP("HLR",$J),HLSDATA,HLSDT,HLTRIED Q
CSUM ;Calculate Checksum
S HLC1=HLC1+$L(X),X=X_HLC2 X HLLPC S HLC2=$C(Y) Q
REC ;Receive a Message
K HLDTOUT,HLL,^TMP("HLR",$J) S HLC1=0,HLC2="",HLI=0,HLTIME=HLTIME+.000001
REC1 U IO(0) R X#245:DTIME S:'$T HLDTOUT=1 Q:$D(HLDTOUT) X HLTRM G REC1:Y'=11
U IO(0) R X0:DTIME S:'$T HLDTOUT=1 Q:$D(HLDTOUT) S X=$C(11)_X0_$C(13) D CSUM S:HLLOG HLI=HLI+1,^TMP("HL",HLION,HLTIME,"REC",HLI)=X0
U IO(0) F HLK=1:1 R X1#246:DTIME S:'$T HLDTOUT=1 Q:$D(HLDTOUT) X HLTRM D:HLLOG Q:Y=28 I $L(X1) S:HLK'>2 HLL(HLK)=X1 S ^TMP("HLR",$J,HLTIME,HLK)=X1,X=X1_$S($L(X1)<245:$C(13),1:"") D CSUM
.;Record Incoming Transmission in Log
.S HLII=X1 S:$P(X1,$E(X1,4))="MSH" $P(X1,$E(X1,4),8)=""
.S HLI=HLI+1,^TMP("HL",HLION,HLTIME,"REC",HLI)=X1,X1=HLII
Q:$D(HLDTOUT) S X=HLC2 X HLLPC S HLCSUM=Y,HLC=+$E(X1,($L(X1)-2),$L(X1)),HLB=+$E(X1,($L(X1)-7),($L(X1)-3)),HLERR=$S(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
I HLLOG S ^TMP("HL",HLION,HLTIME,"REC","CKS")=HLCSUM_"/"_HLC_"^"_HLC1_"/"_HLB
U IO(0) R X2:DTIME S:'$T HLDTOUT=1
Q
SEND ;Send a Message
N X,Y S HLC1=0,HLC2=""
U IO(0) S X=$C(11)_"D21"_$C(13) W X D CSUM I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND",0)="D21"
SENDN I '$D(HLSDT) U IO(0) S HLI="" F S HLI=$O(HLSDATA(HLI)) Q:HLI="" S X=HLSDATA(HLI)_$S('$D(HLERR):$C(13),1:"") W X D CSUM I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND",HLI)=$S('$D(HLERR):HLSDATA(HLI),1:"N21 "_HLERR)
I $D(HLSDT) U IO(0) S HLI="" F S HLI=$O(^TMP("HLS",$J,HLSDT,HLI)) Q:HLI="" S HLSDATA=^(HLI),X=HLSDATA_$C(13) W X D CSUM I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND",HLI)=HLSDATA
S X=HLC2 X HLLPC S X=$E("0000",1,(5-$L(HLC1)))_HLC1_$E("00",1,(3-$L(Y)))_Y_$C(28)_$C(13) U IO(0) W X I HLLOG S ^TMP("HL",HLION,HLTIME,"SEND","CKS")=$P(X,$C(28))
Q
HLLP ;AISC/SAW-HL7 Hybrid Lower Level Protocol Receiver/Sender ;9/5/96 10:50 [ 04/02/2003 8:36 AM ]
+1 ;;1.6;HEALTH LEVEL SEVEN;**1004**;APR 01, 2003
+2 ;;1.6;HEALTH LEVEL SEVEN;**1,12**;Oct 13, 1995
+3 ;This routine is used for the Version 1.5 Interface Only
INIT ;Initialize Variables
+1 ;----- BEGIN IHS MODIFICATION - HL*1.6*1004
+2 ; IHS/ITSC/TPF 08/19/02 TCP/IP network device check. SAME REDIRECT USED FOR CACHE TCP AS WELL AS MSM TCP
IF $GET(IOT)="CHAN"
DO ^HLZTCP
QUIT
+3 ;----- END IHS MODIFICATION
+4 ;
+5 SET X="ERR^HLLP"
SET @^%ZOSF("TRAP")
IF $DATA(HLION)
SET IOP=HLION
DO ^%ZIS
IF POP
GOTO EXIT
+6 IF '$DATA(HLION)
DO HOME^%ZIS
IF POP
GOTO EXIT
SET HLION=$SELECT(ION']"":"UNKNOWN",1:ION)
+7 SET IOP="NULL DEVICE"
DO ^%ZIS
IF POP
GOTO EXIT
KILL IOP
USE IO
DO DT^DICRW
SET HLTIME=%
USE IO(0)
XECUTE ^%ZOSF("TYPE-AHEAD")
+8 KILL %,%H,%I,X
SET (DTIME,HLTRIES)=0
IF $DATA(HLNDAP0)
SET DTIME=$PIECE(HLNDAP0,"^",9)
SET HLTRIES=$PIECE(HLNDAP0,"^",5)
IF DTIME'>0
SET DTIME=60
IF HLTRIES'>0
SET HLTRIES=3
+9 IF $DATA(^%ZOSF("OS"))
IF ^%ZOSF("OS")["VAX"
USE IO(0):PACK
XECUTE ^%ZOSF("EOFF")
+10 IF '$TEST
USE IO(0)
XECUTE ^%ZOSF("EOFF")
+11 SET HLLPC=^%ZOSF("LPC")
SET X=255
SET HLTRM=^%ZOSF("TRMRD")
XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("TRMON")
LOOP ;Infinite loop to check for HL7 messages to send/receive
+1 FOR
SET HLLOG=$SELECT($DATA(^HL(770,"ALOG",HLION)):1,1:0)
DO CHKREC
DO CHKSEND
IF $$S^%ZTLOAD
SET ZTSTOP=1
QUIT
EXIT QUIT
ERR ;Trap error
+1 KILL HLL(1),^TMP("HLR",$JOB),^TMP("HLS",$JOB)
DO @^%ZOSF("ERRTN")
DO ^%ZISC
QUIT
CHKREC ;Check if there are HL7 messages to receive
+1 DO REC
IF '$DATA(HLDTOUT)
IF 'HLERR
SET HLSDATA(1)=$CHAR(11)_"N21"_$CHAR(13)_HLERR
SET HLC1=0
SET HLC2=""
DO SENDN
KILL HLSDATA,HLERR
GOTO CHKREC
+2 IF '$DATA(HLDTOUT)
USE IO
KILL HLERR
DO ^HLCHK
+3 USE IO
QUIT
CHKSEND ;Check if there are HL7 messages to send
+1 IF '$DATA(HLNDAP)
QUIT
+2 IF '$DATA(HLNDAP0)
SET HLNDAP0=$GET(^HL(770,HLNDAP,0))
+3 SET HLDA=+$ORDER(^HL(772,"AC","O",+$PIECE(HLNDAP0,U,12),0))
IF 'HLDA
GOTO EX
+4 SET HLDA0=$GET(^HL(772,HLDA,0))
IF HLDA0']""
GOTO EX
+5 SET HLXMZ=+$PIECE(HLDA0,"^",5)
+6 IF 'HLXMZ
Begin DoDot:1
+7 DO STATUS^HLTF0(HLDA,4,"","No pointer to Message file(#3.9)")
End DoDot:1
GOTO EX
+8 IF '$DATA(^XMB(3.9,HLXMZ))
Begin DoDot:1
+9 DO STATUS^HLTF0(HLDA,4,"","No message found at #"_HLXMZ_" in Message file(#3.9)")
End DoDot:1
GOTO EX
+10 IF '$ORDER(^XMB(3.9,HLXMZ,2,0))
Begin DoDot:1
+11 DO STATUS^HLTF0(HLDA,4,"","No message contents at #"_HLXMZ_" in Message file(#3.9)")
End DoDot:1
GOTO EX
+12 SET (HLI,HLTRIED)=0
SET HLSDT=+HLDA0
FOR HLJ=1:1
SET HLI=$ORDER(^XMB(3.9,HLXMZ,2,HLI))
IF HLI'>0
QUIT
SET ^TMP("HLS",$JOB,HLSDT,HLJ)=$GET(^XMB(3.9,HLXMZ,2,HLI,0))
CS1 SET HLTRIED=HLTRIED+1
KILL ^TMP("HLR",$JOB),HLSDATA
DO SEND
DO REC
IF HLTRIED'=HLTRIES
IF $DATA(HLDTOUT)
GOTO CS1
IF $EXTRACT(X0)="N"
GOTO CS1
+1 IF $DATA(HLDTOUT)
GOTO EX
+2 IF $EXTRACT(X0)="N"
SET HLAC=4
SET HLMSG="Lower Level Protocol Error - "_$SELECT($EXTRACT(X1)="X":"Checksum",1:"Character Count")_" Did Not Match"
DO STATUS^HLTF0(HLDA,HLAC,HLMSG)
GOTO EX
+3 IF $SELECT('$DATA(HLL(1)):1,"BHS,MSH"'[$EXTRACT(HLL(1),1,3):1,1:0)
SET HLAC=4
SET HLMSG="Application Level error - Header Segment Missing"
DO STATUS^HLTF0(HLDA,HLAC,HLMSG)
GOTO EX
+4 KILL HLXMZ
DO CHK^HLCHK
DO IN^HLTF(HLMTN,HLMID,HLTIME)
EX KILL HLAC,HLDA,HLDA0,HLERR,HLMSG,HLI,HLJ,^TMP("HLS",$JOB),^TMP("HLR",$JOB),HLSDATA,HLSDT,HLTRIED
QUIT
CSUM ;Calculate Checksum
+1 SET HLC1=HLC1+$LENGTH(X)
SET X=X_HLC2
XECUTE HLLPC
SET HLC2=$CHAR(Y)
QUIT
REC ;Receive a Message
+1 KILL HLDTOUT,HLL,^TMP("HLR",$JOB)
SET HLC1=0
SET HLC2=""
SET HLI=0
SET HLTIME=HLTIME+.000001
REC1 USE IO(0)
READ X#245:DTIME
IF '$TEST
SET HLDTOUT=1
IF $DATA(HLDTOUT)
QUIT
XECUTE HLTRM
IF Y'=11
GOTO REC1
+1 USE IO(0)
READ X0:DTIME
IF '$TEST
SET HLDTOUT=1
IF $DATA(HLDTOUT)
QUIT
SET X=$CHAR(11)_X0_$CHAR(13)
DO CSUM
IF HLLOG
SET HLI=HLI+1
SET ^TMP("HL",HLION,HLTIME,"REC",HLI)=X0
+2 USE IO(0)
FOR HLK=1:1
READ X1#246:DTIME
IF '$TEST
SET HLDTOUT=1
IF $DATA(HLDTOUT)
QUIT
XECUTE HLTRM
IF HLLOG
Begin DoDot:1
+3 ;Record Incoming Transmission in Log
+4 SET HLII=X1
IF $PIECE(X1,$EXTRACT(X1,4))="MSH"
SET $PIECE(X1,$EXTRACT(X1,4),8)=""
+5 SET HLI=HLI+1
SET ^TMP("HL",HLION,HLTIME,"REC",HLI)=X1
SET X1=HLII
End DoDot:1
IF Y=28
QUIT
IF $LENGTH(X1)
IF HLK'>2
SET HLL(HLK)=X1
SET ^TMP("HLR",$JOB,HLTIME,HLK)=X1
SET X=X1_$SELECT($LENGTH(X1)<245:$CHAR(13),1:"")
DO CSUM
+6 IF $DATA(HLDTOUT)
QUIT
SET X=HLC2
XECUTE HLLPC
SET HLCSUM=Y
SET HLC=+$EXTRACT(X1,($LENGTH(X1)-2),$LENGTH(X1))
SET HLB=+$EXTRACT(X1,($LENGTH(X1)-7),($LENGTH(X1)-3))
SET HLERR=$SELECT(HLCSUM'=HLC:"X",HLC1'=HLB:"C",1:1)
+7 IF HLLOG
SET ^TMP("HL",HLION,HLTIME,"REC","CKS")=HLCSUM_"/"_HLC_"^"_HLC1_"/"_HLB
+8 USE IO(0)
READ X2:DTIME
IF '$TEST
SET HLDTOUT=1
+9 QUIT
SEND ;Send a Message
+1 NEW X,Y
SET HLC1=0
SET HLC2=""
+2 USE IO(0)
SET X=$CHAR(11)_"D21"_$CHAR(13)
WRITE X
DO CSUM
IF HLLOG
SET ^TMP("HL",HLION,HLTIME,"SEND",0)="D21"
SENDN IF '$DATA(HLSDT)
USE IO(0)
SET HLI=""
FOR
SET HLI=$ORDER(HLSDATA(HLI))
IF HLI=""
QUIT
SET X=HLSDATA(HLI)_$SELECT('$DATA(HLERR):$CHAR(13),1:"")
WRITE X
DO CSUM
IF HLLOG
SET ^TMP("HL",HLION,HLTIME,"SEND",HLI)=$SELECT('$DATA(HLERR):HLSDATA(HLI),1:"N21 "_HLERR)
+1 IF $DATA(HLSDT)
USE IO(0)
SET HLI=""
FOR
SET HLI=$ORDER(^TMP("HLS",$JOB,HLSDT,HLI))
IF HLI=""
QUIT
SET HLSDATA=^(HLI)
SET X=HLSDATA_$CHAR(13)
WRITE X
DO CSUM
IF HLLOG
SET ^TMP("HL",HLION,HLTIME,"SEND",HLI)=HLSDATA
+2 SET X=HLC2
XECUTE HLLPC
SET X=$EXTRACT("0000",1,(5-$LENGTH(HLC1)))_HLC1_$EXTRACT("00",1,(3-$LENGTH(Y)))_Y_$CHAR(28)_$CHAR(13)
USE IO(0)
WRITE X
IF HLLOG
SET ^TMP("HL",HLION,HLTIME,"SEND","CKS")=$PIECE(X,$CHAR(28))
+3 QUIT
