source: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLLP.m@ 636

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