- HLLP ;AISC/SAW-HL7 Hybrid Lower Level Protocol Receiver/Sender ;9/5/96 10:50
- ;;1.6;HEALTH LEVEL SEVEN;**1,12,29**;Oct 13, 1995
- ;This routine is used for the Version 1.5 Interface Only
- INIT ;Initialize Variables
- 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
- U IO D DT^DICRW
- I HLTIME<% S HLTIME=%
- E S HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
- K HLDTOUT,HLL,^TMP("HLR",$J) S HLC1=0,HLC2="",HLI=0
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLLP 4363 printed Feb 18, 2025@23:24:40 Page 2
- HLLP ;AISC/SAW-HL7 Hybrid Lower Level Protocol Receiver/Sender ;9/5/96 10:50
- +1 ;;1.6;HEALTH LEVEL SEVEN;**1,12,29**;Oct 13, 1995
- +2 ;This routine is used for the Version 1.5 Interface Only
- INIT ;Initialize Variables
- +1 SET X="ERR^HLLP"
- SET @^%ZOSF("TRAP")
- IF $DATA(HLION)
- SET IOP=HLION
- DO ^%ZIS
- if POP
- GOTO EXIT
- +2 IF '$DATA(HLION)
- DO HOME^%ZIS
- if POP
- GOTO EXIT
- SET HLION=$SELECT(ION']"":"UNKNOWN",1:ION)
- +3 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")
- +4 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
- +5 IF $DATA(^%ZOSF("OS"))
- IF ^%ZOSF("OS")["VAX"
- USE IO(0):PACK
- XECUTE ^%ZOSF("EOFF")
- +6 IF '$TEST
- USE IO(0)
- XECUTE ^%ZOSF("EOFF")
- +7 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 USE IO
- DO DT^DICRW
- +2 IF HLTIME<%
- SET HLTIME=%
- +3 IF '$TEST
- SET HLTIME=$$FMADD^XLFDT(HLTIME,0,0,0,1)
- +4 KILL HLDTOUT,HLL,^TMP("HLR",$JOB)
- SET HLC1=0
- SET HLC2=""
- SET HLI=0
- 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
