4:13 PM 5-MAY-97 IHS PATCH 3 FOR VA HL7 (HL), IHS/TUC/DLR 5/5/97 HLCHK HLCHK ;AISC/SAW-Validate HL7 Messages Received ;4/28/95 09:59 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**1**;Oct 13, 1995 ;This routine is used for the Version 1.5 Interface Only D CHK D IN^HLTF(HLMTN,HLMID,HLTIME) S HLMT=$S(HLMTN="QRY":"ORF",HLMTN="ORM":"ORR",1:"ACK") D MSH G ACK:$D(HLERR) K HLDATA,HLL,HLMSA,HLMT,HLMTP,^TMP("HLR",$J) I HLROU="^NONE"!(HLROU="^") D KILL Q D @HLROU G REPLY MSH ;Create MSH Segment for HL7 Reply I '$D(HLDT)!('$D(HLDT1)) N %,%H,%I D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(HLDT) S HLSDATA(1)="MSH"_HLFS_HLECH_HLFS_$P(HLDATA,HLFS,5,6)_HLFS_$P(HLDATA,HLFS,3,4)_HLFS_HLDT1_HLFS_HLFS_HLMT_HLFS_HLDT_HLFS_HLPID_HLFS_HLVER Q CHK ;Validate Data in Header Segment of an HL7 Message K HLERR S HLDATA=HLL(1),HLFS=$E(HLDATA,4),HLECH=$P(HLDATA,HLFS,2),HLQ="""""",HLDAN=$P(HLDATA,HLFS,5),HLMNT="" D .I $E(HLDATA,1,3)="BHS" S HLMID=$P(HLDATA,HLFS,11),X=$P(HLDATA,HLFS,9),HLPID=$P(X,$E(HLECH),2),HLMTN=$E($P(X,$E(HLECH),3),1,3),HLVER=$P(X,$E(HLECH),4) S:$P(HLDATA,HLFS,10)]"" HLMSA=$P(HLDATA,HLFS,10),$P(HLMSA,$E(HLECH),2)=$P(HLDATA,HLFS,12) .I $E(HLDATA,1,3)="MSH" S HLMID=$P(HLDATA,HLFS,10),HLPID=$P(HLDATA,HLFS,11),HLMTN=$P($P(HLDATA,HLFS,9),$E(HLECH)),HLVER=$P(HLDATA,HLFS,12) S:HLMTN="" HLMTN=0 I $E($G(HLL(2)),1,3)="MSA" S HLMSA=HLL(2) I HLMTN']"" S HLERR="Invalid Message Type" Q I '$D(^HL(771.2,"B",HLMTN)) S HLERR="Invalid Message Type" Q I HLFS=""!(HLFS?.C) S HLERR="Invalid Header Segment" Q I $E(HLDATA,1,3)'="MSH",$E(HLDATA,1,3)'="BHS" S HLERR="Invalid Header Segment" Q I HLDAN']"" S HLERR="Invalid Receiving Application" Q S HLDAP=+$O(^HL(771,"B",HLDAN,0)) I 'HLDAP S HLDAN=$$UPPER^HLFNC(HLDAN),HLDAP=+$O(^HL(771,"B",HLDAN,0)) I 'HLDAP S HLERR="Invalid Receiving Application" Q I '$D(^HL(771,HLDAP,0)) S HLERR="Invalid Receiving Application" Q I $P(^HL(771,HLDAP,0),"^",2)'="a" S HLERR="Receiving Application is Inactive" Q S X=$P(HLDATA,HLFS,3) I X']"" S HLERR="Invalid Sending Application" Q I '$D(^HL(770,"AF",X)) S X=$$UPPER^HLFNC(X) I '$D(^HL(770,"AF",X)) S HLERR="Invalid Sending Application" Q S HLSA=X,X=$P(HLDATA,HLFS,4) I X']"" S HLERR="Invalid Sending Facility" Q I '$D(^HL(770,"AF",HLSA,X)) S X=$$UPPER^HLFNC(X) I '$D(^HL(770,"AF",HLSA,X)) S HLERR="Invalid Sending Facility" Q S X=$P(HLDATA,HLFS,6),X=$$UPPER^HLFNC(X) I X']"" S HLERR="Invalid Receiving Facility" Q I '$D(^HL(770,"AE",HLSA,X)) S HLERR="Invalid Receiving Facility" Q I '$D(HLNDAP0) S HLNDAP=+$O(^HL(770,"B",HLSA,0)),HLNDAP0=$G(^HL(770,HLNDAP,0)) S:$P(HLNDAP0,"^",6)]"" HLION=$P(HLNDAP0,"^",6) I HLVER']"" S HLERR="Invalid HL7 Version" Q S X=$O(^HL(771.5,"B",HLVER,0)) I 'X S HLERR="Invalid HL7 Version" Q I X'=$P(^HL(770,+$O(^HL(770,"B",HLSA,0)),0),"^",7) S HLERR="Invalid HL7 version for Receiving Application" Q I "DTP"'[HLPID S HLERR="Inappropriate HL7 Processing ID" Q S HLMTP=+$O(^HL(771.2,"B",HLMTN,0)) I HLMTN'="ACK",'$O(^HL(771,HLDAP,"MSG","B",HLMTP,0)) S HLERR="Invalid Message Type for Receiving Application" Q S HLROU=$G(^HL(771,HLDAP,"MSG",+$O(^HL(771,HLDAP,"MSG","B",HLMTP,0)),"R")) I HLROU']""!(HLROU="NONE") I HLMTN'="ACK",HLMTN'="MCF" S HLERR="Invalid Message Type for Receiving Application" Q S X=$P($P(HLDATA,HLFS,8),$E(HLECH)),X=$$UPPER^HLFNC(X) D ^XUSHSH D Q:$D(HLERR) .I X']"" S:HLMTN'="ACK"&(HLMTN'="MCF")&(HLMTN'="ORR") HLDUZ=0 Q .S HLDUZ=+$O(^VA(200,"A",X,0)) I '$D(^VA(200,HLDUZ,.1)) I HLMTN'="ACK",HLMTN'="MCF",HLMTN'="ORR" S HLDUZ=0 S X=$P($P(HLDATA,HLFS,8),$E(HLECH),3) I X]"" D Q:$D(HLERR) .I '$D(^VA(200,HLDUZ,20)) S HLERR="No Signature Code on File" Q .S X=$$UPPER^HLFNC(X) D HASH^XUSHSHP I X'=$P(^VA(200,HLDUZ,20),"^",4)!($P(^(20),"^",2)']"") S HLERR="Invalid Electronic Signature Code" Q .S HLESIG=$P(^VA(200,HLDUZ,20),"^",2) S:HLROU'["^" HLROU="^"_HLROU Q ACK ;Create and Send 'AR' Error Type Acknowledgement Message K HLDATA,HLL,^TMP("HLR",$J) S HLSDATA(2)="MSA"_HLFS_"AR"_HLFS_HLMID_HLFS_HLERR K HLERR D SEND^HLLP,KILL Q ; REPLY ;Send a Reply/Ack to a HL7 Message Received N I,HLAC,HLMSG,HLERR I $D(HLSDT) S I="",I=$O(^TMP("HLS",$J,HLSDT,I)),I=$O(^(I)),HLMSA=$G(^(+I)) I '$D(HLSDT),$D(HLSDATA) S I="",I=$O(HLSDATA(I)),I=$O(HLSDATA(I)),HLMSA=$G(HLSDATA(+I)) I $D(HLMSA),$D(HLDAP),HLDAP,$E(HLMSA,1,3)="MSA" S HLMSG="" D . S HLAC=$P(HLMSA,HLFS,2) . Q:(HLAC="")!('$D(HLNDAP)) . I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) . S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3) . D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) ; I $D(HLSEC) D . I $D(HLSDT) S I="",I=$O(^TMP("HLS",$J,HLSDT,I)),$P(^TMP("HLS",$J,HLSDT,I),HLFS,8)=HLSEC . I '$D(HLSDT) S I="",I=$O(HLSDATA(I)),$P(HLSDATA(I),HLFS,8)=HLSEC ; K HLERR D SEND^HLLP,KILL K ^TMP("HLS",$J) Q ; KILL ;Kill variables before receiving another HL7 message K HLB,HLC,HLC1,HLC2,HLCSUM,HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLDUZ,HLECH,HLERR,HLESIG,HLFS,HLI,HLII,HLK,HLMID,HLMSA,HLMTN,HLPID,HLQ,HLROU,HLSA,HLSDATA,HLSDT,HLVER,X,X0,X1 D NOW^%DTC S HLTIME=% K %,%H,%I Q HLCS HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;06/26/96 10:29 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2,9**;Oct 13, 1995 ; ;The SEND function is invoked by the transaction processor. ;It's function is to $O through the ITEM multiple of the Event Driver ;Protocol and create child entries in the Message Text file (#772) ;for the message at HLMTIEN. These child messages point back ;to the parent message so that message text does not need to ;be duplicated when a message is sent to multiple applications. ; ;The SENDACK function is also invoked by the transaction processor. ;It's function is to create a child entry in the Message Text file ;for the message at HLMTIENA and deliver the message to the ;application the requested/sent information. ; ;For DHCP to DHCP messaging (i.e. internal to internal), an incoming ;message is created in the Message Text file which is a duplication ;of the outgoing message. The incoming message is then processed by ;calling the transaction processor. ; ;For DHCP to COTS messaging (i.e. internal to external), the message ;is filed in the Message Text file with the Logical Link defined and ;a status of PENDING TRANSMISSION. These entries are picked up by ;the background filer and transmitted to the appropriate COTS system. ; ; TASK ;Entry point for tasked sending of outgoing message Q:(('$D(HLMTIEN))!('$D(HLEID))) N TMPRSLT D SEND(HLMTIEN,HLEID,"TMPRSLT") Q SEND(HLMTIEN,HLEID,HLRESULT) ;Send an HL7 message ;HLMTIEN=The IEN of the parent message in file # 772 ;HLEID=The IEN of the Event Driver protocol in file #101 ;HLRESULT=Variable for any error text (pass by reference) ; ;Declare variables N HLARY,HLERROR,HLEIDS,HLCLIENT,HLOGLINK,HLMTIENS,HLMSGPTR S HLERROR="" ;Get all subscribers to the message D ITEM^HLUTIL2(HLEID,"PTR") ;Quit if no subscribers (considered successful delivery) G:($G(HLARY(0))'>0) EXIT ;Deliver message to each subscriber S HLEIDS=0 F S HLEIDS=$O(HLARY(HLEIDS)) Q:(HLEIDS'>0) D .;Get pointer to receiving application .S HLCLIENT=+HLARY(HLEIDS) .Q:(HLCLIENT'>0) .;Get pointer to logical link .S HLOGLINK=$P(HLARY(HLEIDS),"^",2) .;Determine if receiving application is internal or external .; Logical link has a value for external applications .; Logical link is NULL for internal applications .I (HLOGLINK) D COTS Q .;Create 'incoming' message based on 'outgoing' message (internal) .D DHCP(HLMTIEN,HLEIDS,HLCLIENT) .Q:(HLERROR) .;Process the 'incoming' message .S HLERROR="" .D PROCESS^HLTP0(HLMSGPTR,"DHCP","",.HLERROR) .;Update Status of 'incoming' message to SUCCESSFULLY COMPLETED .; or ERROR DURING TRANSMISSION .D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR:+HLERROR,1:""),$S(HLERROR:$P(HLERROR,"^",2),1:"")) EXIT S HLRESULT=HLERROR Q COTS ;Internal to external communication ;Create child entry in Message Text file D SEND^HLMA2(HLEIDS,HLMTIEN,HLCLIENT,"I",.HLMTIENS,HLOGLINK) I ((+HLMTIENS)'>0) S HLERROR=HLMTIENS Q ;'Pass' message to background filer by setting status of child ; to PENDING TRANSMISSION D STATUS^HLTF0(HLMTIENS,1) Q DHCP(HLMTIEN,HLEIDS,HLCLIENT) ;Internal to internal communication ; ;Input : HLMTIEN - Pointer to parent outgoing message (file #772) ; HLEIDS - Pointer to subscribing protocol (file #101) ; HLCLIENT - Pointer to receiving application (file # 771) ; ;Output : HLMTIENS - Pointer to child outgoing message (file #772) ; HLMSGPTR - Pointer to [parent] incoming message (file #772) ; HLERROR - ErrorCode ^ ErrorText ; ;Notes : This module only copies the outgoing message into an incoming ; message. Delivery of the message (i.e. processing of it) ; must be done by the calling application. ; : Message/batch header (MSH/BSH) is built and placed in the ; incoming message ; : HLMTIENS, HLMSGPTR, and HLERROR will be initialized ; : Existance and validity of input is assumed ; ;Declare variables N MSGID,MSGDT,MSGDTH,HDR2BLD,TMP,HLHDR,BHSHDR S HLERROR="" S HLMTIENS=0 S HLMSGPTR=0 ;Create child entry in Message Text file D SEND^HLMA2(HLEIDS,HLMTIEN,HLCLIENT,"I",.HLMTIENS) I ((+HLMTIENS)'>0) S HLERROR=HLMTIENS Q ;'Receive' message by making an incoming message ;Determine type of header to build S TMP=$G(^HL(772,HLMTIEN,0)) S HDR2BLD=$P(TMP,"^",14) ;Build message header (MSH) I (HDR2BLD="M") D Q:(HLERROR) .S TMP="" .D HEADER^HLCSHDR(HLMTIENS,.TMP) .Q:(TMP="") .;Error building header .S HLERROR="4^Unable to build message header => "_TMP .D STATUS^HLTF0(HLMTIENS,4,0,$P(HLERROR,"^",2)) ;Build batch header (BHS or FHS) I (HDR2BLD'="M") D Q:(HLERROR) .S TMP="" .D BHSHDR^HLCSHDR(HLMTIENS) .S:($E(BHSHDR(1),1)="-") TMP=$P(BHSHDR(1),"^",2) .Q:(TMP="") .;Error building header .S HLERROR="4^Unable to build batch header => "_TMP .D STATUS^HLTF0(HLMTIENS,4,0,$P(HLERROR,"^",2)) ;Create entry for 'incoming' message D CREATE^HLTF(.MSGID,.HLMSGPTR,.MSGDT,.MSGDTH) ;Move header and rest of message into 'incoming' message I (HDR2BLD="M") D .;Use MSH as header .D MRGINT^HLTF1(HLMTIEN,HLMSGPTR,"HLHDR") I (HDR2BLD'="M") D .;Use BHS or FHS as header .D MRGINT^HLTF1(HLMTIEN,HLMSGPTR,"BHSHDR") ;Set status of outgoing message to AWAITING ACKNOWLEDGEMENT D STATUS^HLTF0(HLMTIENS,$S($P(^HL(772,HLMTIEN,0),U,7):3,1:2)) ;Set status of 'incoming' message to AWAITING PROCESSING D STATUS^HLTF0(HLMSGPTR,9) Q SENDACK(HLMTIENA,HLEID,HLEIDS,HLRESULT) ;Send an HL7 acknowledgement/response ;HLMTIENA=The IEN of the parent acknowledgment/response message in ; file # 772 ;HLEIDS=The IEN of the Subscribing protocol in file # 101 ;HLEID=The IEN of the Event Driver protocol in file #101 ;HLRESULT=Variable for any error text (pass by reference) ; N HLERROR,HLOGLINK,HLCLIENT,HLMTIENS,HLMSGPTR,HLCLNODE I $G(HLMTIENA)=""!($G(HLEID)="")!($G(HLEIDS)="") S HLERROR="0^7^"_$G(^HL(771.7,7,0))_"at SENDACK^HLCS entry point" G EXIT2 S HLCLNODE=$G(^ORD(101,HLEID,770)) ;Get pointers to Logical Link & receiving application S HLOGLINK=$P($G(^ORD(101,HLEIDS,770)),U,7) S HLCLIENT=$P(HLCLNODE,U,1) Q:('HLCLIENT) ;Determine if receiving application is internal or external ; Logical link has a value for external applications ; Logical link is NULL for internal applications I (HLOGLINK) D COTSACK Q ;Create 'incoming' message based on 'outgoing' message (internal) D DHCP(HLMTIENA,HLEID,HLCLIENT) ;Process the 'incoming' message I (HLMSGPTR) D .S HLERROR="" .D PROCESS^HLTP0(HLMSGPTR,"DHCP","",.HLERROR) ;Update Status of 'incoming' message to SUCCESSFULLY COMPLETED ; or ERROR DURING TRANSMISSION D STATUS^HLTF0(HLMSGPTR,$S(HLERROR:4,1:3),$S(HLERROR:+HLERROR,1:""),$S(HLERROR:$P(HLERROR,"^",2),1:"")) EXIT2 ; S HLRESULT=$G(HLERROR) Q COTSACK ;Internal to external communication of acknowledgements/responses ;Create child entry in Message Text file D SEND^HLMA2(HLEID,HLMTIENA,HLCLIENT,"I",.HLMTIENS,HLOGLINK) ;'Pass' message to background filer by setting status of child ; to PENDING TRANSMISSION D STATUS^HLTF0(HLMTIENS,1) Q HLCSDL HLCSDL ;ALB/MTC/SF/JC - INITIALIZE VARIABLES AND OPEN DEVICE X3.28 ;04/25/96 10:50 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2**;Oct 13, 1995 ; EN ;-- entry point for X3.28 protocol ; ;-- error trap (keepalive for disconnects) ;---- start of IHS change ;IHS/TUC/DLR 03/19/97 IHS PATCH 1 - no DSM or $ETRAP at IHS ;I ^%ZOSF("OS")["DSM" N $ETRAP S $ET="" ;---- end of IHS change S X="ERROR^HLCSDL",@^%ZOSF("TRAP") EN1 ;-- check device init ;-- if device error and still running, try again I $$INIT,$$RUN^HLCSDL2 D EXIT H 5 G EN1 ;-- setup X3.28 parameters I $$XSETUP G ENQ ;-- file start stats D FILE ;-- start LLP D START^HLCSDL1 ;-- file end stats D END ;-- exit ENQ D EXIT ; Q ; INIT() ;-- check for device, open ; This fucntion will return a 1 if it fails else 0 ; N RESULT S RESULT=0 I '$D(HLDP)&($G(%)'="") S HLDP=% ;LAUNCHED FROM VMS I '$D(HLDP) S RESULT=1 G INITQ D DT^DICRW I HLDP'>0 S HLDP=$O(^HLCS(870,"B",HLDP,"")) I HLDP'>0 S RESULT=1 G INITQ ;HLDP IEN of LOGICAL LINK file #870 S HLDNODE=$G(^HLCS(870,HLDP,0)) ;-- get parameters from 869.2 S HLPARM=$G(^HLCS(869.2,+$P(HLDNODE,U,3),300)) ;pointer to DEVICE file S HLDEVPTR=$P(HLPARM,U) ;-- check for valid pointer I HLDEVPTR'>0 S RESULT=1 G INITQ ;-- check for device S HLDEVICE=$P($G(^%ZIS(1,HLDEVPTR,0)),"^",1) I HLDEVICE="" S RESULT=1 G INITQ ;-- open device D MONITOR^HLCSDR2("OPEN",5,HLDP) K ZTIO S IOP=HLDEVICE D ^%ZIS I POP D MONITOR^HLCSDR2("OPENFAIL",5,HLDP) H 3 S RESULT=1 G INITQ ;-- set up environment S X=255 U IO X ^%ZOSF("EOFF"),^%ZOSF("RM"),^%ZOSF("TRMON") ; INITQ Q RESULT ; XSETUP() ;-- This function will set up all parameters required by the X3.28 ; protocol. ; This function will return a 1 if it fails, else 0 ; N RESULT S RESULT=0 ;-- initialize and set defaults ;-- max message size S HLMMS=$P(HLPARM,U,2) S:'HLMMS HLMMS=99999 ;-- block size S HLDBLOCK=$P(HLPARM,U,3) S:'HLDBLOCK HLDBLOCK=245 ;-- timer a S HLTIMA=$P(HLPARM,U,4) S:'HLTIMA HLTIMA=6 ;-- timer b S HLTIMB=$P(HLPARM,U,5) S:'HLTIMB HLTIMB=3 ;-- timer d S HLTIMD=$P(HLPARM,U,6) S:'HLTIMD HLTIMD=30 ;-- timer e S HLTIME=$P(HLPARM,U,7) S:'HLTIME HLTIME=180 N I,J,K F I=1:1 S J=$T(CTRLS+I) Q:J["END" D .S K=$P(J,";",3),@K=$P(J,";",4) .S HLCTRL(@K)=$P(J,";",5) I $G(HLTRACE) K ^TMP("HLLOG",$J) S HLLOG=0 ; XSETQ Q RESULT ; FILE ;-- file startup stats ; D NOW^%DTC L +^HLCS(870,HLDP,0):DTIME I '$T G FILE ;9=Time Started, 10=Time Stopped, 11=Task Number ;14=Shutdown LLP, 3=Shutdown LLP, 18=Gross Errors I '$D(ZTSK) S ZTSK="" S DIE="^HLCS(870,",DA=HLDP,DR="9////^S X=%;10////@;11////^S X=ZTSK;14////0;3////Y;18////@" D ^DIE K DIE,DA,DR L -^HLCS(870,HLDP,0) Q ; END ;-- file stats D NOW^%DTC D MONITOR^HLCSDR2("SHUTDOWN",5,HLDP) L +^HLCS(870,HLDP,0):DTIME I '$T G END ;10=Time Stopped,9=Time Started,11=Task Number , 3=Online ? S DIE="^HLCS(870,",DA=HLDP,DR="10////^S X=%;9////@;11////@;3////N" D ^DIE K DIE,DA,DR L -^HLCS(870,HLDP,0) Q ; EXIT ;-- exit cleanup D ^%ZISC X ^%ZOSF("EON") K HLMMS,HLBLOCK,HLTIMA,HLTIMB,HLTIMD,HLTIME,HLTERM,HLSOH,HLSTX,HLETB,HLETX,HLEOT,HLENQ,HLRINT,HLDLE,HLNAK,HLACK0,HLACK1,HLACK2,HLACK3,HLACK4,HLACK5,HLACK6,HLACK7 K HLDNODE,HLDEVPTR,HLDEVICE,HLRETPRM,HLDAPP,X,HLDEND,HLDSTRT,HLDVER,HLDREAD,HLDWRITE,HLDP,HLTRACE,ZTSK,HLDBSIZE Q ; ERROR ; ;-- on disconnect errors, trap and try to reconnect, all others, ; trap and shut down gracefully I $$EC^%ZOSV["DSCON" D MONITOR^HLCSDR2("Disconnect",5,HLDP) H 3 G EN1 D ^%ZTER D END G EXIT CTRLS ;X3.28 control settings ;;HLTERM;13; ;;HLSOH;1; ;;HLSTX;2; ;;HLETB;23; ;;HLETX;3; ;;HLEOT;4; ;;HLENQ;5; ;;HLRINT;60; ;;HLDLE;16; ;;HLNAK;21; ;;HLACK0;48; ;;HLACK1;49; ;;HLACK2;50; ;;HLACK3;51; ;;HLACK4;52; ;;HLACK5;53; ;;HLACK6;54; ;;HLACK7;55; ;;END HLCSDL1 HLCSDL1 ;ALB/MTC/JC - X3.28 LOWER LAYER PROTOCOL 2.2 - 2/28/95 ;04/25/96 10:51 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2**;Oct 13, 1995 ; ;This is an implemetation of the X3.28 LLP ; START ; N HLIND0,HLIND1,HLNXST,HLTRANS,HLCHK,HLACKBLK,HLDOUT0,HLDOUT1,X,HLRETRY N HLNXST,HLLINE,HLXOR,HLTOUT,HLLINE,HLC1,HLC2 N HLDLX,HLM S X=10 X ^%ZOSF("PRIORITY") S HLM=0,HLNXST=1 ;-- enter loop for polling for i/o D POLL ;-- exit and clean-up D EXIT Q ; ; POLL ;-- This function will check if any messages should be sent ; then if anything is in the buffer to read in. If there is data ; to write out then the system will bid for master status and if ; successful x-mit the message. If the system receives a request to ; receive data, then it will attemp to enter a slave mode and read ; data in. ; N HLFLAG S HLFLAG=1 D TRACE^HLCSDL2("Logging IO to ^XTMP('HL',N") ;-- enter loop F D MONITOR^HLCSDR2("POLLING",5,HLDP) Q:'HLFLAG D .; should we still be running . I '$$RUN^HLCSDL2 D MONITOR^HLCSDR2("SHUTDOWN",5,HLDP) S HLFLAG=0 Q .;-- check for data to read in . D TRACE^HLCSDL2("Slave Check"),SLAVE . I '$$RUN^HLCSDL2 D MONITOR^HLCSDR2("SHUTDOWN",5,HLDP) S HLFLAG=0 Q .;-- check for out going data . D TRACE^HLCSDL2("Master Check"),MASTER Q ; SLAVE ;-- this function will check if anything is ready to read in from ; the port. If nothing is ready then return to polling, else ; start slave process. ; N HLX ;-- check if anything is ready to read in. D TRACE^HLCSDL2("Slave Request") ;-- read for enq (request for slave) I '$$READENQ^HLCSDL2 G SLAVEQ ;-- ack0 D TRACE^HLCSDL2("Slave Ack0") D SENDACK^HLCSDL2(0) ;-- read data D TRACE^HLCSDL2("Slave Read Data") D READ ;-- exit and return to polling SLAVEQ ; Q ; READ ;-- This function will take the incoming data from the device and ; store in file 870. After each read an ack will be sent to the ; client application. Once an EOT has been received, return to ; polling. ; N HLX,HLI,HLBK,HLETXB,HLLINE,HLDATA,BTERM ;-- prepare for incoming data S HLLINE=1,HLI=0 LOOP ;-- main loop for reading in message ; ;-- update status D MONITOR^HLCSDR2("READING",5,HLDP) ;-- read block of data S HLX=$$READBK^HLCSDL2("HLDATA",.HLLEN,.HLBK,.HLCK,.BTERM) ;-- check for TIMEOUT I $G(HLDATA)["TIMEOUT" G READQ ;-- check for EOT I $G(HLDATA)=HLEOT G READQ ;-- check if vaild data I '$$VALID^HLCSDL2("HLDATA",HLLINE#8,HLLEN,HLBK,HLCK,BTERM) D G LOOP .;-- update status . D TRACE^HLCSDL2("Slave Write NAK") . D MONITOR^HLCSDR2("SEND NAK",5,HLDP) .;-- send nak . D SENDNAK^HLCSDL2 ; ;-- write data to file 870 S HLDOUT0=$$ENQUEUE^HLCSQUE(HLDP,"IN"),HLDOUT1=$P(HLDOUT0,U,2),HLDOUT0=+HLDOUT0 D APPEND^HLCSUTL("HLDATA",HLDOUT0,HLDOUT1) S HLLINE=HLLINE+1 ; ;-- If end of text set status I +BTERM=+HLETX D . D MONITOR^HLCSDR2("P",2,HLDOUT0,HLDOUT1,"IN") . D MONITOR^HLCSDR2("A",3,HLDOUT0,HLDOUT1,"IN") ;-- ack D SENDACK^HLCSDL2(HLBK) ;-- read next line of data G LOOP ; READQ Q ; MASTER ;-- if outgoing messages are present then establish m/s and begin ; transmission of message. ; N HLBID,HLDOUT0,HLDOUT1 ;-- check queue D TRACE^HLCSDL2("Master Check Queue") S HLDOUT0=$$DEQUEUE^HLCSQUE(HLDP,"OUT") ;-- nothing on queue quit I +HLDOUT0<0 D TRACE^HLCSDL2("*Out Queue Empty") G MASTERQ S HLDOUT1=$P(HLDOUT0,U,2),HLDOUT0=+HLDOUT0 ;-- have item in queue to write, bid for master status S HLBID=$$BID(5) ;-- if attemp fails quit I 'HLBID D PUSH^HLCSQUE(HLDOUT0,HLDOUT1) G MASTERQ ;-- if successful goto write state I HLBID D . D WRITE(HLDOUT0,HLDOUT1) . D EOT^HLCSDL2 ; MASTERQ Q ; BID(MAXTRY) ;-- This function will bid for Master status MAXTRY times ; and return a 1 if succesful, 0 if fails ; INPUT - MAXTRY - Maximum number of attemps before failing ; OUTPUT - 1 for ok; 0 fails ; N RESULT,HLTRIES,HLDLX S RESULT=0,HLTRIES=0 ;-- update status D MONITOR^HLCSDR2("BIDDING",5,HLDP) BIDRET ;-- bid for master status D TRACE^HLCSDL2("Master Bid") D ENQ^HLCSDL2 ;-- update status D TRACE^HLCSDL2("Master Bid Wait Ack0") D MONITOR^HLCSDR2("WAIT ACK",5,HLDP) ;-- if read ack if block 0 OK else fail I $$READACK^HLCSDL2(0) S RESULT=1 G BIDQ ;-- if nak or timeout S HLTRIES=HLTRIES+1 I HLTRIES>(MAXTRY-1) G BIDQ G BIDRET BIDQ ;-- exit Q RESULT ; WRITE(HLDOUT0,HLDOUT1) ;-- This function will take the message contained ; in file 870 specified by HLDOUT0 and HLDOUT1 and write the data out. ; after each write the system will wait for an ack. ; INPUT : HLDOUT0 - IEN of file #870 ; HLDOUT1 - IEN of out queue multiple ; N HLHEAD,HLTEXT1,HLFOOT,HLX1,HLX2,HLX3,HLTEMP ;-- loop to process message S HLX1="",HLX2="HLTEXT1" F HLI=1:1 K HLTEXT1 S HLX1=$$NEXTLINE^HLCSUTL(HLDOUT0,HLDOUT1,HLX1,HLX2,"OUT") Q:'HLX1 D I '$$SEND(HLX2,HLHEAD,HLFOOT,5,HLI#8) Q . S HLX3=$$NEXTLINE^HLCSUTL(HLDOUT0,HLDOUT1,HLX1,"HLTEMP","OUT") . D BUILD^HLCSDL2(HLX2,HLI,$S(HLX3:HLETB,1:HLETX),.HLHEAD,.HLFOOT) ; WRITEQ Q ; SEND(HLTEXT,HLHEAD,HLFOOT,HLRETRY,HLBK) ;-- This function will write the X3.28 formatted ; string out the port and wait for an ack. If this function fails ; 0 will be returned, else 1. ; ; Input - HLTEXT - Array containing segment to send ; - HLHEAD - Block header ; - HLFOOT - Block footer ; - HLRETRY- Maximum retries before failure ; - HLBK - Current block 0-7 ; Output- 0 Fails, 1 = OK ; N RESULT,HLTRY,X S RESULT=1,HLTRY=0 RETRY ;-- write data ;-- update status D TRACE^HLCSDL2("Master Write") D MONITOR^HLCSDR2("WRITING",5,HLDP) ; U IO ;-- write header W HLHEAD D LOG(HLHEAD,"WRITE: ") S X="" F S X=$O(@HLTEXT@(X)) Q:'X W @HLTEXT@(X) D LOG(@HLTEXT@(X),"Write: ") ;-- write footer W HLFOOT D LOG(HLFOOT,"WRITE: ") ;-- Wait for ack D TRACE^HLCSDL2("Master Wait for Ack"_HLBK) D MONITOR^HLCSDR2("WAITING ACK",5,HLDP) ;-- if ack I $$READACK^HLCSDL2(HLBK) S RESULT=1 D MONITOR^HLCSDR2("D",2,HLDP,HLDOUT1,"OUT") G SENDQ ;-- if nak then retry S HLTRY=HLTRY+1 I HLTRY>(HLRETRY-1) S RESULT=0 G SENDQ G RETRY SENDQ ;-- exit Q RESULT ; EXIT ;-- Cleanup Q ; LOG(ST1,OP) ;Log reads/writes (translates ctrls) ;ST1=string to file ;OP=operation "read" or "write" I $G(HLTRACE) D .N X S X=$G(^XTMP("HL",0)),$P(X,U)=DT+1,$P(X,U,2)=DT .S $P(X,U,3)="HL7 Debug Log",HLLOG=$P(X,U,4) .S HLN=$$TRANS(ST1) .S HLLOG=HLLOG+1,^XTMP("HL",HLLOG)=OP_HLN,$P(X,U,4)=HLLOG .S ^XTMP("HL",0)=X Q TRANS(ST) ;Translate controls in string ;ST=String containing embedded x3.28 control characters S ST2="" F I=1:1:$L(ST) S J=$E(ST,I) D .I $D(HLCTRL($A(J))) S J=HLCTRL($A(J)) .S ST2=$G(ST2)_J Q ST2 HLCSDL2 HLCSDL2 ;ALB/MTC/JC - X3.28 LOWER LAYER PROTOCOL UTILITIES 2.2 - 2/28/95 ;04/25/96 10:52 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2**;Oct 13, 1995 Q ; SENDNAK ;-- This function will send an nack for the block specified ; by the parameter HLBK. ; OUTPUT: NONE ; ; U IO W $C(HLNAK)_$C(HLTERM) D LOG^HLCSDL1($C(HLNAK)_$C(HLTERM),"WRITE: ") Q ; SENDACK(HLBK) ;-- This function will send an ack for the block specified ; by the parameter HLBK. ; INPUT : HLBK current sequence (block) ; OUTPUT: NONE ; N HLACKN ; S HLACKN="HLACK"_(HLBK#8) U IO W $C(HLDLE)_$C(@(HLACKN))_$C(HLTERM) D LOG^HLCSDL1($C(HLDLE)_$C(@(HLACKN))_$C(HLTERM),"WRITE: ") Q ; READACK(HLBK) ;-- This function will read the input device for an ackN ; specified by HLBK. ; INPUT : HLBK - Expected AckN ; OUTPUT: 1- Ok 0-Fails ; N HLACKN,X,Y,RESULT,HLTRM ; S RESULT=0,HLTRM="" S HLACKN=@("HLACK"_(HLBK#8)) ;-- do read for HLDLE S X=$$READ^HLCSUTL(HLTIMA,HLDBLOCK,.HLTRM) D LOG^HLCSDL1(X_$C(HLTRM),"READ: ") D TRACE^HLCSDL2("FINISHED READ FOR DLE:"_HLTRM_U_X_U) I HLTRM'=HLDLE G RDACKQ S X=$$READ^HLCSUTL(HLTIMA,HLDBLOCK,.HLTRM) D LOG^HLCSDL1(X_$C(HLTRM),"READ: ") I X'=$C(HLACKN),HLTRM'=HLTERM G RDACKQ S RESULT=1 ; RDACKQ Q RESULT ; READENQ() ;-- This function will read the input device for an ENQ ; ; INPUT : NONE ; OUTPUT: 1- Ok 0-Fails ; N X,Y,RESULT,HLTRM,HLX ; S HLX=0 RETRY S RESULT=0,HLTRM="" ;-- do read for HLENQ S X=$$READ^HLCSUTL(HLTIMA,HLDBLOCK,.HLTRM) D LOG^HLCSDL1(X_$C(HLTRM),"READ: ") D TRACE^HLCSDL2("FINISHED READ FOR ENQ:"_HLTRM_U_X_U) S HLX=HLX+1 I HLX>5 G RDENQ I HLTRM'=+HLENQ G RETRY ;-- do read for HLTERM S X=$$READ^HLCSUTL(HLTIMA,HLDBLOCK,.HLTRM) D LOG^HLCSDL1(X_$C(HLTRM),"READ: ") I HLTRM'=+HLTERM G RDENQ S RESULT=1 ; RDENQ Q RESULT ; READBK(HLTEXT,LEN,BLOCK,CHKSUM,BTERM) ; This function will read a block of data from the input device ; and store the result in the array specified by HLTEXT. ; INPUT : HLTEXT - Array reference to store data ; LEN - Passed by reference will get message lenght ; BLOCK - Passed by refence will get message block # ; CHKSUM - Passed by refence will get message BCC ; BTERM - Passed by reference will block termination char ; OUTPUT : 1 - OK, 0 - Fails ; If EOT is encountered HLTEXT=EOT ; If TimeOut is encountered then HLTEXT="-1^TIMEOUT" ; N RESULT,HLX,HLTRM S (RESULT,LEN,CHKSUM,BTERM,BLOCK)=0 ;-- read expect either SOH or STX will ignore header info S HLX=$$READ^HLCSUTL(HLTIMB,HLDBLOCK,.HLTRM) D LOG^HLCSDL1(HLX_$C(HLTRM),"READ: ") ;-- check for timeout I HLX["TIMEOUT" S @HLTEXT=HLX G READBKQ ;-- check for eot I HLTRM=+HLEOT S HLX=$$READ^HLCSUTL(HLTIMB,HLDBLOCK,.HLTRM),@HLTEXT=HLEOT,RESULT=1 D LOG^HLCSDL1(HLX_$C(HLTRM),"READ: ") G READBKQ ;-- if header read and ignore I HLTRM=+HLSOH S HLX=$$READ^HLCSUTL(HLTIMB,HLDBLOCK,.HLTRM) D LOG^HLCSDL1(HLX_$C(HLTRM),"READ: ") I HLX["TIMEOUT" S @HLTEXT=HLX ;-- start of data block I HLTRM'=+HLSTX G READBKQ ;-- read expect either HLDBLOCK characters or CR for end of data S HLX=$$READ^HLCSUTL(HLTIMB,HLDBLOCK,.HLTRM) D LOG^HLCSDL1(HLX_$C(HLTRM),"READ: ") ;-- check for timeout I HLX["TIMEOUT" S @HLTEXT=HLX G READBKQ ;-- get block and length -- S HLI=0 S BLOCK=$E(HLX),LEN=$E(HLX,2,6) ; BLOOP ;-- block read loop ; ;-- first pass get data leave blk and lenght I HLI=0 S HLX=$E(HLX,7,$L(HLX)) ;-- save data BLOOP2 S HLI=HLI+1,@HLTEXT@(HLI)=HLX ;-- long line I HLTRM=0 D . S HLDONE=0,HLJ=0 . F S HLX=$$READ^HLCSUTL(HLTIMB,HLDBLOCK,.HLTRM) D I HLDONE Q .. D LOG^HLCSDL1(HLX_$C(HLTRM),"READ: ") .. I +HLX<0 S HLDONE=1 Q .. S HLJ=HLJ+1,@HLTEXT@(HLI,HLJ)=HLX .. I HLTRM=+HLTERM S HLDONE=1 ; ;-- read upto next ctrl char S HLX=$$READ^HLCSUTL(HLTIMB,HLDBLOCK,.HLTRM) D LOG^HLCSDL1(HLX_$C(HLTRM),"READ: ") ;-- check for timeout I HLX["TIMEOUT" S @HLTEXT=HLX G READBKQ ;-- more data to read I (HLTRM=+HLTERM)!(HLTRM=0) G BLOOP2 ;-- read expect ETX or ETB I (HLTRM=+HLETB)!(HLTRM=+HLETX) S BTERM=HLTRM D .;-- read expect . S HLX=$$READ^HLCSUTL(HLTIMB,HLDBLOCK,.HLTRM) . D LOG^HLCSDL1(HLX_$C(HLTRM),"READ: ") .;-- get BCC . S CHKSUM=HLX ;-- OK S RESULT=1 ; READBKQ Q RESULT ; BUILD(HLTEXT,HLSEQ,HLEND,HLHEAD,HLFOOT) ;-- This function will build the block to write. ; INPUT : HLTEXT - Array to write/format ; : HLSEQ - Sequence in message ; : HLEND - ETX or ETB ; : HLHEAD - Passed by reference - will be the header portion ; : HLFOOT - Passed by reference - will be the footer portion ; ; OUTPUT: HLHEAD = ; HLFOOT = ; N HLBL,HLHEX,X,Y ;-- get checksum information S HLCHK=$$CHKSUM^HLCSUTL(HLTEXT) ;-- determine block number S HLBL=HLSEQ#8 ;-- determine length S HLLN=$P(HLCHK,U,2) S HLLN=$E("00000",1,5-$L(HLLN))_$P(HLCHK,U,2) S X=HLBL_HLLN_$C($P(HLCHK,U))_$C(HLEND) X ^%ZOSF("LPC") ;-- build two byte check sum S HLHEX=$$HEXCON(Y) ;-- build string S HLHEAD=$C(HLSTX)_HLBL_HLLN,HLFOOT=$C(HLEND)_HLHEX_$C(HLTERM) Q ; ENQ ;-- this function will send an ENQ to the secondary station ; to establish a master/slave relationship for transmissions. ; U IO W $C(HLENQ)_$C(HLTERM) D LOG^HLCSDL1($C(HLENQ)_$C(HLTERM),"WRITE: ") Q ; EOT ;-- this function will send an EOT to the secondary station ; to end the master/stave relationship. ; U IO W $C(HLEOT)_$C(HLTERM) D LOG^HLCSDL1($C(HLEOT)_$C(HLTERM),"WRITE: ") Q ; HEXCON(%) ;-- converts a decimal #<128 to a two byte hex # ; INPUT : % - Decimal to convert ; ; N H,H1,H2 ;-- error if # not between 0 - 127 I (%<0)!(%>127)!(%'=+%) S (H1,H2)=0 G HEXQ I %<10 S H1=0,H2=% G HEXQ S H=%\16 S:H>9 H=$E(" ABCDEF",H) S H1=H S H=%#16 S:H>9 H=$E(" ABCDEF",H) S H2=H HEXQ Q H1_H2 ; RUN() ;-- This function will determine if this occurance of the LLP ; should still be running. ; INPUT : NONE ;OUTPUT : 1 - Yes, 0 No ; N RESULT ;-- default to Yes S RESULT=1 ;-- check if should shut down I $P($G(^HLCS(870,HLDP,0)),U,15)=1 S RESULT=0 ;-- if running in forground ask I $G(HLTRACE) U IO(0) W !,"Type Q to Quit: " R X:1 I $G(X)'=""&("Qq"[X) S $P(^HLCS(870,HLDP,0),U,15)=1,RESULT=0 ; Q RESULT ; VALID(HLTEXT,HLBLK,LEN,BLOCK,CHKSUM,BTERM) ;-- This function will validate the incoming message as in should ; conform to the X3.28 protocol. No other error checking is perfomred ; for this validation. If this function is successful a ; 1 is returned else 0. ; INPUT : HLTEXT - The block that was read in from the device ; : HLBLK - Current block expected ; : LEN - xmitted length ; : BLOCK - xmitted block number ; : CHKSUM - xmitted checksum ; : BTERM - Block termination char (ETX or ETB) ; OUTPUT : 1 ok, 0 fails ; ; The following validation checks are made by this function: ; 1 - BCC matches calculated BCC ; 2 - Message lenght matches calculated message length ; 3 - Block matches the expected block number ; 4 - Block termination is either ETX or ETB ; N HLBCC,HLLEN,HLBCC1,RESULT,X,Y S RESULT=0 ;-- calculate checksum S HLBCC=$$CHKSUM2^HLCSUTL(HLTEXT) ;-- add in BLOCK LEN and BTERM S X=BLOCK_LEN_$C($P(HLBCC,U))_$C(BTERM) X ^%ZOSF("LPC") S HLBCC1=Y ;-- convert to hex S HLBCC1=$$HEXCON(HLBCC1) ;-- checksum I HLBCC1'=CHKSUM G VALIDQ ;-- length I $P(HLBCC,U,2)'=+LEN G VALIDQ ;-- block I HLBLK'=BLOCK G VALIDQ ;-- ok S RESULT=1 ; VALIDQ Q RESULT ; TRACE(HLSTATE) ;-- This function is used during for debug. It will print ; the current state of the X3.28 protocol. Each state is passed in ; through the variable HLSTATE ; ; INPUT - HLSTATE : Current state of FSM ; OUTPUT - If HLTRACE is defined then write HLSTATE to IO(0) ; I '$G(HLTRACE) Q U IO(0) W !,"In State : ",HLSTATE Q ; HLCSDR HLCSDR ;ALB/RJS - INITIALIZE VARIABLES AND OPEN DEVICE FOR RECEIVER ;04/29/96 10:24 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2**;Oct 13, 1995 ; INIT ; ;---- start of IHS change ;IHS/TUC/DLR 03/19/97 IHS PATCH 1 - no DSM or $ETRAP at IHS ;I ^%ZOSF("OS")["DSM" N $ETRAP S $ETRAP="" ;---- end of IHS change S X="ERROR^HLCSDR",@^%ZOSF("TRAP") I '$D(HLDP)&($G(%)'="") S HLDP=% ;LAUNCHED FROM VMS I '$D(HLDP) Q D DT^DICRW I HLDP'>0 S HLDP=$O(^HLCS(870,"B",HLDP,"")) I HLDP'>0 G EXIT ;HLDP IEN of LOGICAL LINK file #870 S HLDNODE=$G(^HLCS(870,HLDP,0)) ;-- get parameters from 869.2 S HLPARM=$G(^HLCS(869.2,+$P(HLDNODE,U,3),200)) ;pointer to DEVICE file S HLDEVPTR=$P(HLPARM,U) G EXIT:HLDEVPTR'>0 S HLDEVICE=$P($G(^%ZIS(1,HLDEVPTR,0)),"^",1) G EXIT:HLDEVICE="" FILE ; D NOW^%DTC L +^HLCS(870,HLDP,0):DTIME I '$T G FILE ;9=Time Started, 10=Time Stopped, 11=Task Number ;14=Shutdown LLP, 3=Shutdown LLP, 18=Gross Errors I '$D(ZTSK) S ZTSK="" S DIE="^HLCS(870,",DA=HLDP,DR="9////^S X=%;10////@;11////^S X=ZTSK;14////0;3////Y;18////@" D ^DIE K DIE,DA,DR L -^HLCS(870,HLDP,0) OPEN ; I $P($G(^HLCS(870,HLDP,0)),U,15) G END S HLST="OPEN" D STATUS(HLST,HLDP) S IOP=HLDEVICE D ^%ZIS I POP S HLST="OPENFAIL" D STATUS(HLST,HLDP) H 5 G OPEN INIT2 ; ;Re-transmission attempts, Node, Hang Time, Start character, ;End character, LLP Version Number S HLDAPP=$P(HLDNODE,U,1) S HLRETPRM=$P(HLPARM,U,2),HLDBSIZE=$P(HLPARM,U,3),HLDREAD=$P(HLPARM,U,4),HLDWRITE=$P(HLPARM,U,5),HLDSTRT=$P(HLPARM,U,6),HLDEND=$P(HLPARM,U,7),HLDVER=$P(HLPARM,U,8) ;Defaults I HLRETPRM="" S HLRETPRM=5 I HLDREAD="" S HLDREAD=10 I HLDWRITE="" S HLDWRITE=2 I HLDSTRT="" S HLDSTRT=11 I HLDEND="" S HLDEND=28 I HLDVER="" S HLDVER=21 I HLDBSIZE'>1 S HLDBSIZE=245 ;Set up Device Params ;---- start of IHS change ;IHS/TUC/DLR 03/19/97 IHS PATCH 1 - avoid wrap of long lines ;S X=255 U IO X ^%ZOSF("EOFF"),^%ZOSF("RM"),^%ZOSF("TRMON") S X=0 U IO X ^%ZOSF("EOFF"),^%ZOSF("RM"),^%ZOSF("TRMON") ;---- end of IHS change START ; D START^HLCSDR1(HLDP,HLRETPRM,HLDREAD,HLDWRITE,HLDSTRT,HLDEND,HLDVER,HLDBSIZE) END ; D NOW^%DTC L +^HLCS(870,HLDP,0):DTIME I '$T G END ;10=Time Stopped,9=Time Started,11=Task Number , 3=Online ? S DIE="^HLCS(870,",DA=HLDP,DR="10////^S X=%;9////@;11////@;3////N" D ^DIE K DIE,DA,DR L -^HLCS(870,HLDP,0) EXIT ; D ^%ZISC K HLDNODE,HLDEVPTR,HLDEVICE,HLRETPRM,HLDAPP,X,HLDEND,HLDSTRT,HLDVER,HLDREAD,HLDWRITE,HLDP,HLTRACE,ZTSK,HLDBSIZE,HLPARM Q STATUS(HLST,HLDP) ;Update field 4 ;HLST=Current Status ;HLDP=IEN of Logical Link S DIE="HLCS(870,",DA=HLDP,DR="4///^S X=HLST" D ^DIE K DIE,DA,DR Q ERROR ;Trap disconnect errors I $$EC^%ZOSV["DSCON" S HLST="DSCONECT" D STATUS(HLST,HLDP) H 3 G OPEN D ^%ZTER G END Q HLCSDR1 HLCSDR1 ;ALB/RJS - HYBRID LOWER LAYER PROTOCOL 2.2 - 9/13/94 ;03/18/97 08:46 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2,22,27**;Oct 13, 1995 ; ;This is an implemetation of the HL7 Hybrid Low Layer Protocol ; START(HLDP,HLRETPRM,HLDREAD,HLDWRITE,HLDSTRT,HLDEND,HLDVER,HLDBSIZE) ; N HLIND0,HLIND1,HLNXST,HLTRANS,HLCHK,HLACKBLK,HLDOUT0,HLDOUT1,X,HLRETRY N HLNXST,HLLINE,HLXOR,HLTOUT,HLLINE,HLC1,HLC2,HLNAK,HLTVV,HLWFLG ;S X=10 X ^%ZOSF("PRIORITY") ; above line commented-out patch 27, sys mgr will set as needed S HLNXST=1,HLWFLG=1 ; ; 1 ; Look to see if there is anything to read in D TRACE^HLCSDR2,MONITOR^HLCSDR2("IDLE",5,HLDP) S X=$$READ^HLCSUTL(HLDREAD,HLDBSIZE,.HLTRANS) D TRANS^HLCSDR2(X,.HLTRANS),INITIZE^HLCSDR2 S HLNXST=$S(HLTRANS="VT":"TVV",HLTRANS="TIMEOUT":14,1:1) ;---- start of IHS change ;IHS/TUC/DLR 3/31/97 IHS PATCH 1 - halt on timeout ;I HLNXST=14,'HLWFLG D PUSH^HLCSQUE(HLDOUT0,HLDOUT1),MONITOR^HLCSDR2("P",2,HLDOUT0,HLDOUT1,"OUT"),MONITOR^HLCSDR2("TIMEOUT",5,HLDP) I HLNXST=14,'HLWFLG D PUSH^HLCSQUE(HLDOUT0,HLDOUT1),MONITOR^HLCSDR2("P",2,HLDOUT0,HLDOUT1,"OUT"),MONITOR^HLCSDR2("TIMEOUT",5,HLDP) Q ;---- end of IHS change G @HLNXST ; TVV ;Read in tvv ;---- start of IHS change ;IHS/TUC/DLR 3/31/97 IHS PATCH 1 - reset wait flag S HLWFLG=1 ;---- end of IHS change D TRACE^HLCSDR2,MONITOR^HLCSDR2("READING",5,HLDP) S X=$$READ^HLCSUTL(HLDREAD,HLDBSIZE,.HLTRANS) D TRANS^HLCSDR2(X,.HLTRANS) I $L(X)=3&(HLTRANS="CR") S HLNXST=2,HLNAK=$E(X),HLTVV=X,X=$C(HLDSTRT)_X_$C(13) D CHKSUM^HLCSDR2 I HLNAK="D" S HLIND0=$$ENQUEUE^HLCSQUE(HLDP,"IN"),HLIND1=$P(HLIND0,U,2),HLIND0=+HLIND0 D MONITOR^HLCSDR2(HLTVV,4,HLDP,HLIND1,"IN") I HLIND0<0 D MONITOR^HLCSDR2(100,19,HLDP) G EXIT I HLNAK="N" S X=HLTVV K ^TMP("HLCSDR1",$J,HLDP) D SETNODE2^HLCSDR2 G 9 I HLNXST'=2 S HLNXST=5,HLTRANS="G" D MONITOR^HLCSDR2(105,19,HLDP) G @HLNXST ; 2 ; Read in message S HLNAK="" D TRACE^HLCSDR2,MONITOR^HLCSDR2("READING",5,HLDP) S X=$$READ^HLCSUTL(HLDREAD,HLDBSIZE,.HLTRANS) D TRANS^HLCSDR2(X,.HLTRANS) S HLNXST=$S(HLTRANS="FS":3,HLTRANS="TIMEOUT":5,1:2) I HLTRANS="CR" D SETNODE^HLCSDR2(HLIND0,HLIND1,HLTRANS) S X=X_$C(13) D CHKSUM^HLCSDR2 I HLTRANS="LONGLINE" D SETNODE^HLCSDR2(HLIND0,HLIND1,HLTRANS),CHKSUM^HLCSDR2 I HLTRANS="TIMEOUT" S HLTRANS="G" D MONITOR^HLCSDR2(106,19,HLDP) G @HLNXST ; ; 3 ; Check for Validity of data D TRACE^HLCSDR2,MONITOR^HLCSDR2("VALIDATE",5,HLDP) S HLCHK=$E(X,$L(X)-7,$L(X)),X=$E(X,1,$L(X)-8) S HLTRANS=$$VALID1^HLCSDR2("INCOMING MESSAGE",HLCHK,HLIND0,HLIND1) S HLNXST=$S(HLTRANS="VALID":4,1:5) I HLNXST=5 D MONITOR^HLCSDR2(107,19,HLDP) G @HLNXST ; ; 4 ; Valid message. D TRACE^HLCSDR2,MONITOR^HLCSDR2("DONE",5,HLDP),MONITOR^HLCSDR2("A",3,HLDP,HLIND1,"IN"),MONITOR^HLCSDR2("P",2,HLDP,HLIND1,"IN") D INITIZE^HLCSDR2 S HLNXST=6 G @HLNXST ; ; 5 ; Send NAK When This State is Reached D TRACE^HLCSDR2,MONITOR^HLCSDR2("NAK",5,HLDP),MONITOR^HLCSDR2(HLTRANS,3,HLDP,HLIND1,"IN"),MONITOR^HLCSDR2("P",2,HLDP,HLIND1,"IN") D NAK^HLCSDR2(HLTRANS) D INITIZE^HLCSDR2 S HLNXST=1 G @HLNXST ; ; 6 ;Check "OUT" queue D TRACE^HLCSDR2,MONITOR^HLCSDR2("OUT QUEUE",5,HLDP) S HLDOUT0=$$DEQUEUE^HLCSQUE(HLDP,"OUT") I +HLDOUT0<0 S HLNXST=1 E S HLNXST=7,HLDOUT1=$P(HLDOUT0,U,2),HLDOUT0=+HLDOUT0,HLRETRY=-1 G @HLNXST ; ; 7 ; Send Data to other Application I HLRETRY=HLRETPRM D MONITOR^HLCSDR2(103,19,HLDP),MONITOR^HLCSDR2("G",3,HLDP,HLDOUT1,"OUT"),MONITOR^HLCSDR2("D",2,HLDP,HLDOUT1,"OUT") S HLNXST=14 G @HLNXST D TRACE^HLCSDR2,MONITOR^HLCSDR2("WRITING",5,HLDP) D WRITE^HLCSDR2(HLDOUT0,HLDOUT1) ; ; set message status to 'done' D MONITOR^HLCSDR2("D",2,HLDP,HLDOUT1,"OUT") ; S HLNXST=1 G @HLNXST ; ; ; 9 ; Read in Neg Acknowledgement message D TRACE^HLCSDR2 S X=$$READ^HLCSUTL(HLDWRITE,HLDBSIZE,.HLTRANS) D TRANS^HLCSDR2(X,.HLTRANS),MONITOR^HLCSDR2("READ ACK",5,HLDP) S HLNXST=$S(HLTRANS="FS":10,HLTRANS="CR":9,1:7) I HLTRANS="CR" D SETNODE2^HLCSDR2 S X=X_$C(13) D CHKSUM^HLCSDR2 I HLTRANS="LONGLINE" D SETNODE2^HLCSDR2,CHKSUM^HLCSDR2 I HLNXST=7 S HLRETRY=HLRETRY+1 D MONITOR^HLCSDR2("P",2,HLDP,HLDOUT1,"OUT") G @HLNXST ; ; 10 ; Check Validity of Neg Acknowledgement D TRACE^HLCSDR2,MONITOR^HLCSDR2("VALIDATE NACK",5,HLDP) S HLCHK=$E(X,$L(X)-7,$L(X)),X=$E(X,1,$L(X)-8) S HLTRANS=$$VALID1^HLCSDR2("LLP-NACK",HLCHK) S HLNXST=$S(HLTRANS="VALID":12,1:7) I HLNXST=7 S HLRETRY=HLRETRY+1 D MONITOR^HLCSDR2("P",2,HLDP,HLDOUT1,"OUT") G @HLNXST ; ; ; 12 ; Process Negative Acknowlegement D TRACE^HLCSDR2 S HLACKBLK=$E(^TMP("HLCSDR1",$J,HLDP,2)) I HLACKBLK="C" D MONITOR^HLCSDR2("C",3,HLDP,HLDOUT1,"OUT") G NXT I HLACKBLK="X" D MONITOR^HLCSDR2("X",3,HLDP,HLDOUT1,"OUT") G NXT I HLACKBLK="B" D MONITOR^HLCSDR2("B",3,HLDP,HLDOUT1,"OUT") G NXT D MONITOR^HLCSDR2("G",3,HLDP,HLDOUT1,"OUT") NXT S HLNXST=7,HLRETRY=HLRETRY+1 D MONITOR^HLCSDR2("P",2,HLDP,HLDOUT1,"OUT") G @HLNXST ; ; ; ; 14 ; Make sure we should still be running D TRACE^HLCSDR2 G EXIT:$P($G(^HLCS(870,HLDP,0)),U,15)=1 ;SHUTDOWN RECEIVER I $D(HLTRACE) U IO(0) W !,"Type Q to Quit: " R X:1 I $G(X)'=""&("Qq"[X) S $P(^HLCS(870,HLDP,0),U,15)=1 G EXIT ;SHUTDOWN RECEIVER S HLNXST=6 G @HLNXST ; ; EXIT ; D MONITOR^HLCSDR2("SHUTDOWN",5,HLDP) Q HLCSDR2 HLCSDR2 ;ALB/RJS - HYBRID LOWER LAYER PROTOCOL UTILITIES 2.2 - ;06/26/96 10:31 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2,9**;Oct 13, 1995 Q ; WRITE(HLDOUT0,HLDOUT1) ; This function will write a message from the Logical ; Link file (#870) to the specified device. The write is in the ; following format: ; ; The data block is the complete HL7 message terminated by a . ; INPUT : HLDOUT0 - IFN of file 870 ; HLDOUT1 - IFN of Out Queue Multiple ; OUTPUT: None ; I HLDOUT0']""!(HLDOUT1']"") Q ;-- HLLINE,HLC1,HLC2 ARE INITIALIZED IN INITIZE N HLCLN,HLCHK,I,X D INITIZE ; ;-- write start block S X=$C(HLDSTRT)_"D"_HLDVER_$C(13) D CHKSUM U IO W X ; S HLWFLG=0 ;-- process and write data block F S HLLINE=$$NEXTLINE^HLCSUTL(HLDOUT0,HLDOUT1,HLLINE,"HLCLN","OUT") Q:'HLLINE D . S HLCHK=$$CHKSUM^HLCSUTL("HLCLN") . S HLC2=HLC2_$C($P(HLCHK,U)),HLC1=HLC1+$P(HLCHK,U,2) . S I=0 F S I=$O(HLCLN(I)) Q:'I S:$E(HLCLN(1),1,3)="MSA" HLWFLG=1 U IO W $G(HLCLN(I)) . K HLCLN,HLCHK ; D CHKSUM1 ;-- store checksum values D MONITOR(HLC1,4,HLDP,HLDOUT1,"OUT"),MONITOR(HLC2,5,HLDP,HLDOUT1,"OUT") ; S HLC1=$$FORMAT(HLC1,5)_HLC1 S HLC2=$$FORMAT(HLC2,3)_HLC2 ; ;-- write end block S X=HLC1_HLC2_$C(HLDEND)_$C(13) U IO W X ; Q ; SETNODE(HLD0,HLD1,CR) ; S HLLINE=HLLINE+1,^HLCS(870,HLD0,1,HLD1,1,HLLINE,0)=$G(X) I CR="CR" S HLLINE=HLLINE+1,^HLCS(870,HLD0,1,HLD1,1,HLLINE,0)="" Q ; SETNODE2 ; S HLLINE=HLLINE+1,^TMP("HLCSDR1",$J,HLDP,HLLINE)=$G(X) Q TRANS(HLTOUT,HLTRANS) ;-- This function will return the state of the read ; operation. ; INPUT : HLTOUT - Data returned from read (Will contain TIMEOUT) ; HLTRANS - Variable passed by reference containing how ; the read was terminated. ; OUTPUT: HLTRANS - Translation of read termination. ; S HLTRANS=$S($G(HLTOUT)["TIMEOUT":"TIMEOUT",HLTRANS=0:"LONGLINE",HLTRANS=1:"SOH",HLTRANS=4:"EOT",HLTRANS=HLDSTRT:"VT",HLTRANS=13:"CR",HLTRANS=HLDEND:"FS",1:"OTHER") I $D(HLTRACE) U IO(0) W !,"HLTRANS=",HLTRANS Q ; INITIZE ;Initialize Line counter and Checksum variables S HLLINE=0 S HLC1=0 S HLC2="" Q ; NAK(HLTRANS) ; Send NAK N HLDATA D INITIZE ;-- start block and data S (X,HLDATA)=$C(HLDSTRT)_"N"_HLDVER_$C(13)_HLTRANS D CHKSUM,CHKSUM1 S HLC1=$$FORMAT(HLC1,5)_HLC1 S HLC2=$$FORMAT(HLC2,3)_HLC2 ;-- end block S X=HLDATA_HLC1_HLC2_$C(HLDEND)_$C(13) U IO W X Q ; ACK ; Send ACK N HLDATA D INITIZE ;-- start block and data S (X,HLDATA)=$C(HLDSTRT)_"D"_HLDVER_$C(13) D CHKSUM,CHKSUM1 S HLC1=$$FORMAT(HLC1,5)_HLC1 S HLC2=$$FORMAT(HLC2,3)_HLC2 ;-- end block S X=HLDATA_HLC1_HLC2_$C(HLDEND)_$C(13) U IO W X Q ; DUMP ; Q:'$D(HLTRACE) U IO(0) W !,"DUMP" I '$D(HLC1) S HLC1=-1 I '$D(HLC2) S HLC2=-1 I '$D(HLBLOCK) S HLBLOCK=-1 I '$D(HLXOR) S HLXOR=-1 W !,"HLC1=",HLC1," ","HLBLOCK=",HLBLOCK W !,"HLC2=",HLC2," ","HLXOR=",HLXOR Q CHKSUM ; X ^%ZOSF("LPC") S HLC1=HLC1+$L(X),HLC2=HLC2_$C(Y) I ($L(HLC2)>240) D CHKSUM1 Q CHKSUM1 ; S X=HLC2 X ^%ZOSF("LPC") S HLC2=Y Q ; VALID1(FLAG,CHK,HLIND0,HLIND1) ; ;This function extracts the checksum sent with a message and then ;compares it to the checksums that have been calculated and stored ;in the HLC1 and HLC2 variables. HLC1 and HLC2 are not passed as ;parameters, their scope is "communication server-wide" ;FLAG tells the function what type of message this is, should the ;last block of data be written to an "in queue" ? or a TMP variable ? ;this depends on whether the incoming message is a message or just ;a lower level acknowledgement "LLP-ACK" ;CHK contains the 8 character cheksum that was sent with the message ;HLIND0,HLIND1 are just D0 and D1 for the "input queue" in file #870 ; N HLBLOCK,HLXOR,RESULT ;WRITE LAST BLOCK 'O DATA TO GLOBAL I $G(X)'=""&(FLAG="INCOMING MESSAGE") D SETNODE(HLIND0,HLIND1,HLTRANS) D CHKSUM I $G(X)'=""&(FLAG="LLP-ACK") D SETNODE2 D CHKSUM ;EXTRACT CHECKSUMS S HLBLOCK=+$E(CHK,1,5),HLXOR=+$E(CHK,6,8) D CHKSUM1,DUMP S X="$$CHK$$^"_CHK_"^HLCHK^"_$$FORMAT(HLC1,5)_HLC1_$$FORMAT(HLC2,3)_HLC2 I FLAG="INCOMING MESSAGE" D MONITOR(HLBLOCK,5,HLDP,HLIND1,"IN"),MONITOR(HLXOR,6,HLDP,HLIND1,"IN"),MONITOR(HLC1,7,HLDP,HLIND1,"IN"),MONITOR(HLC2,8,HLDP,HLIND1,"IN") I FLAG="LLP-ACK" D SETNODE2 I (HLXOR="999") S RESULT="VALID" G ENDVAL1 I (HLBLOCK=HLC1)&(HLC2=HLXOR) S RESULT="VALID" G ENDVAL1 I (HLBLOCK'=HLC1) S RESULT="C" G ENDVAL1 I (HLXOR'=HLC2) S RESULT="X" G ENDVAL1 S RESULT="G" ENDVAL1 Q RESULT ; TRACE ; ;When HLTRACE is instantiated this subroutine simply writes out the ;states that the finite state machine (Lower Layer Protocol) goes ;through I '$D(HLTRACE) Q U IO(0) W !,"IN STATE ",HLNXST Q MONITOR(VALUE,PIECE,HLD0,HLD1,QUEUE) ; ;This subroutine simply updates a particular piece in a global node ;in file #870. It can be a zero node, or a node in a queue multiple ; I '$D(^HLCS(870,HLD0,0)) Q I $G(QUEUE)="IN" S QUEUE=1 I $G(QUEUE)="OUT" S QUEUE=2 I $G(HLD1)']"" S $P(^HLCS(870,HLD0,0),U,PIECE)=VALUE Q S $P(^HLCS(870,HLD0,QUEUE,HLD1,0),U,PIECE)=VALUE Q FORMAT(HLC,LENGTH) ; ;Function to stuff leading zeroes for checksums ;HLC is the checksum, Length is self-documenting N HLVAR S HLVAR=$L(HLC),HLVAR=LENGTH-HLVAR Q $E("00000",1,HLVAR) ; HLCSFMN HLCSFMN ;ALB/JRP - INCOMING/OUTGOING FILER MONITOR;19-MAY-95 ;01/16/97 09:53 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**15**;Oct 13, 1995 MONITOR ;Main entry point ;Declare variables N INFILER,OUTFILER,INCOUNT,OUTCOUNT,INTOP,OUTTOP,STOP N X S X=0 X ^%ZOSF("RM") ; Turn off terminal line wrap S (INTOP,OUTTOP)=0 ;Get screen attributes used D GETATTR^HLCSFMN1 ;Initial clear screen W @IOF ;Continually display updated information until user chooses to quit F S STOP=0 D Q:(STOP) .;Get incoming filer information .S INCOUNT=$$GETINFO^HLCSFMN1("IN","INFILER") .;Set pointer to top of filer lists - if needed .S:('INTOP) INTOP=+$O(INFILER("")) .;Get outgoing filer information .S OUTCOUNT=$$GETINFO^HLCSFMN1("OUT","OUTFILER") .;Set pointer to top of filer lists - if needed .S:('OUTTOP) OUTTOP=+$O(OUTFILER("")) .;Display incoming filer information .D DISPLAY("IN","INFILER",INCOUNT,INTOP) .;Display outgoing filer information .D DISPLAY("OUT","OUTFILER",OUTCOUNT,OUTTOP) .;Prompt/execute action .S STOP=$$PROMPT^HLCSFMN0() ;Delete screen attributes S X=IOM X ^%ZOSF("RM") ; Turn terminal line wrap back on D KILL^%ZISS Q DISPLAY(FLRTYPE,ARRAY,COUNT,PTRTOP) ;Display filer information ;INPUT : FLRTYPE - Flag indicating type of filer header is for ; IN = Incoming filer (default) ; OUT = Outgoing filer ; ARRAY - Array containing filer information (full global ref) ; ARRAY(PtrSubEntry) = TaskNumber ^ Last$H ^ StopFlag ^ ; Printable$H ^ ErrorMessage ; PtrSubEntry = Pointer to subentry in file 869.3 ; TaskNumber = Task number of filer ; Last$H = Last known $H (field #.03 of subentry) ; StopFlag = Whether or not filer has been asked to stop ; (field #.02 of subentry) ; Yes - Filer has been asked to stop ; No - Filer has not been asked to stop ; Error - Task stopped due to error ; Printable$H = Last$H in printable format ; ErrorMessage = Printable error message - only used when ; task stopped due to error ; COUNT - Number of filers running ; Defaults to 0 ; PTRTOP - Pointer to first filer in list to display ; Defaults to 0 ; The following screen attributes ; IOINORM, IOINHI, IOUON, IOUOFF, IOBON, IOBOFF ; IORVON, IORVOFF, IOF, IOHOME, IOELEOL ;OUTPUT : None ; ;Check input S FLRTYPE=$G(FLRTYPE) S:(FLRTYPE'="OUT") FLRTYPE="IN" Q:($G(ARRAY)="") S COUNT=+$G(COUNT) S PTRTOP=+$G(PTRTOP) ;Declare variables N PTRSUB,LOOP,FLRINFO,LASTDH,ASK2STOP,TASKNUM,ERRMSG N DAY,TIME,HOUR,MIN,SEC,PASTTOL,BLANKS,FLRDH,TMP S BLANKS=$J(" ",20) ;Incoming filer is at top of screen I (FLRTYPE="IN") D .;Check for IOHOME & IOELEOL - used to keep from clearing screen .W:((IOHOME'="")&(IOELEOL'="")) IOHOME .;IOHOME & IOELEOL can't be used - clear screen .W:((IOHOME="")!(IOELEOL="")) @IOF .W IOELEOL,! ;Display filer information D HEADER^HLCSFMN0(FLRTYPE) I ('COUNT) D Q .;No filers running .W IOBON,IOINHI,"** No " .W $S(FLRTYPE="OUT":"outgoing",1:"incoming") .W " filers are running **",IOBOFF,IOINORM .W IOELEOL,!,IOELEOL,!,IOELEOL,!,IOELEOL,! .;Whitespace between display areas - use less if dashes where used .; in header .W:((IOUON'="")&(IOUOFF'="")) IOELEOL,!,IOELEOL,! .W:((IOUON="")!(IOUOFF="")) IOELEOL,! ;Loop through filers (print no more than 4) ; Back up one entry in list so that pointer to top entry is ; first entry displayed S PTRSUB=+$O(@ARRAY@(PTRTOP),-1) F LOOP=1:1:4 S PTRSUB=+$O(@ARRAY@(PTRSUB)) Q:('PTRSUB) D .;Get info from array .S FLRINFO=@ARRAY@(PTRSUB) .;Get task number .S TASKNUM=$P(FLRINFO,"^",1) .;Get last known $H .S FLRDH=$P(FLRINFO,"^",2) .;Get asked to stop flag .S ASK2STOP=$P(FLRINFO,"^",3) .;Get printable last known $H .S LASTDH=$P(FLRINFO,"^",4) .;Get error message .S ERRMSG=$P(FLRINFO,"^",5) .;Calculate time difference .S TMP=$$DIFFDH^HLCSFMN1(FLRDH,$H) .S DAY=+TMP .S TIME=$P(TMP,"^",2) .S HOUR=$P(TIME,":",1) .S MIN=$P(TIME,":",2) .S SEC=$P(TIME,":",3) .;Last known $H not set yet .I (FLRDH="") D ..S LASTDH="--------- @ --:--:--" ..S DAY="-" ..S (HOUR,MIN,SEC)="--" .;Print information .; Print task number .W TASKNUM,$E(BLANKS,1,(15-$L(TASKNUM)+3)) .;Print stop flag .W ASK2STOP,$E(BLANKS,1,(7-$L(ASK2STOP)+3)) .;Problem with task - error message defined .I (ERRMSG'="") D Q ..;Not an error with task - don't use special attributes ..I (ASK2STOP'="Error") W ERRMSG,IOELEOL,! Q ..W IOELEOL S DX=0,DY=$Y X ^%ZOSF("XY") W IOINHI,IOBON,ERRMSG,IOBOFF,IOINORM,! .;Task still running - determine if time difference is within .; tolerance level .S PASTTOL=0 .S:((DAY)!(HOUR)!(MIN>5)) PASTTOL=1 .;Bold on (if outside tolerance level) .W:(PASTTOL) IOINHI .;Print last known $H .W LASTDH,$E(BLANKS,1,3) .;Print time lapse .W IOELEOL S DX=0,DY=$Y X ^%ZOSF("XY") W DAY," Day ",HOUR," Hr ",MIN," Min ",SEC," Sec",! .;Bold off (if outside tolerance level) .W:(PASTTOL) IOINORM ;End of list reached I ((LOOP'=4)!('PTRSUB)) D .W IORVON,"[End of list - total of ",COUNT,"]",IORVOFF,IOELEOL,! .F TMP=1:1:(4-LOOP) W IOELEOL,! ;Whitespace between display areas - use less if dashes where used ; in header W:((IOUON'="")&(IOUOFF'="")) IOELEOL,!,IOELEOL,! W:((IOUON="")!(IOUOFF="")) IOELEOL,! Q HLCSFMN0 HLCSFMN0 ;ALB/JRP - INCOMING/OUTGOING FILER MONITOR;19-MAY-95 ;01/16/97 09:53 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**15**;Oct 13, 1995 HEADER(FLRTYPE) ;Display column header ;INPUT : FLRTYPE - Flag indicating type of filer header is for ; IN = Incoming filer (default) ; OUT = Outgoing filer ; The following screen attributes: ; IOELEOL, IOUON, IOUOFF ;OUTPUT : None ;NOTES : Existance of IOUON & IOUOFF is assumed ; : Header begins on current line (i.e. calling application ; must put cursor at beginning of line) ; : Cursor will be put at the beginning of line after header ; when completed ; ;Check input N X S X=0 X ^%ZOSF("RM") ;Turn off terminal line wrap S FLRTYPE=$G(FLRTYPE) N WHTESPCE,DASHES ;Set whitespace between columns S WHTESPCE=$J(" ",3) ;Convert filer type to long format S FLRTYPE=$S(FLRTYPE="OUT":"Outgoing",1:"Incoming") ;Print column headers W "Task Number of ",WHTESPCE,"Asked" W IOELEOL,! W IOUON,FLRTYPE," Filer ",IOUOFF,WHTESPCE W IOUON,"To Stop",IOUOFF,WHTESPCE W IOUON,"Last Known Date/Time",IOUOFF,WHTESPCE W IOUON,"Time Difference",$J(" ",13),IOUOFF W IOELEOL,! ;Screen attributes have no value - print dashes I ((IOUON'="")&(IOUOFF'="")) S X=IOM X ^%ZOSF("RM") QUIT ;Turn terminal line wrap back on ;Set longest set of dashes used S DASHES=$TR($J(" ",28)," ","-") ;Print dashes W $E(DASHES,1,15),WHTESPCE,$E(DASHES,1,7),WHTESPCE W $E(DASHES,1,20),WHTESPCE,DASHES W IOELEOL,! S X=IOM X ^%ZOSF("RM") ;Turn terminal line wrap back on Q PROMPT() ;Prompt user for action and execute the selected action ;INPUT : INFILER(PtrSubEntry) = TaskNumber ^ Last$H ^ StopFlag ^ ; Printable$H ^ ErrorMessage ; OUTFILER(PtrSubEntry) = TaskNumber ^ Last$H ^ StopFlag ^ ; Printable$H ^ ErrorMessage ; PtrSubEntry = Pointer to subentry in file 869.3 ; TaskNumber = Task number of filer ; Last$H = Last known $H (field #.03 of subentry) ; StopFlag = Whether or not filer has been asked to stop ; (field #.02 of subentry) ; Yes - Filer has been asked to stop ; No - Filer has not been asked to stop ; Error - Task stopped due to error ; Printable$H = Last$H in printable format ; ErrorMessage = Printable error message - only used when ; task stopped due to error ; INTOP = Pointer to first incoming filer in list to display ; OUTTOP = Pointer to first outgoing filer in list to display ; The following screen attributes ; IOINORM, IOINHI, IOELEOL ;OUTPUT : 0 = User didn't choose to quit ; 1 = User choose to quit ; INTOP & OUTTOP will be adjusted accordingly ; NEXT action - INTOP & OUTTOP will be moved down 4 entries ; in the list. If the end of a list is ; reached, INTOP/OUTTOP will be set to the ; last entry in the list. ; BACKUP action - INTOP & OUTTOP will be moved up 4 entries ; in the list. If the top of a list is ; reached, INTOP/OUTTOP will be set to the ; first entry in the list. ; START actions - INTOP & OUTTOP will not be changed ; STOP actions - INTOP & OUTTOP will not be changed ; DELETE actions - INTOP & OUTTOP will not be changed ;NOTES : Prompt will be displayed at current cursor position ; : All input is assumed ; : When the STOP action is choosen, the first filer in the ; list of filers will be stopped ; ;Declare variables N ANS,ANS1,LOOP,TMP,ARRAYREF,TMPARR,NEWTOP ;Turn off terminal line wrap N X S X=0 X ^%ZOSF("RM") ;Display prompt W "(",IOINHI,"+I",IOINORM,") Start incoming filer " W "(",IOINHI,"-I",IOINORM,") Stop incoming filer " W "(",IOINHI,"*I",IOINORM,") Delete incoming filer" W IOELEOL,! W "(",IOINHI,"+O",IOINORM,") Start outgoing filer " W "(",IOINHI,"-O",IOINORM,") Stop outgoing filer " W "(",IOINHI,"*O",IOINORM,") Delete outgoing filer" W IOELEOL,! W " (",IOINHI,"N",IOINORM,") Next 4 lines in list " W " (",IOINHI,"B",IOINORM,") Back 4 lines in list " W " (",IOINHI,"Q",IOINORM,") Quit" W IOELEOL,! W "Type selection: ",IOELEOL ;Get users response R ANS#1:5 Q:('$T) 0 ;User hit Q:(ANS="") 0 ;User choose to quit I ("Qq^"[ANS) D Q 1 .;Echo rest of response .W:(ANS="Q") "UIT" .W:(ANS="q") "uit" .W:(ANS="^") " QUIT" .H 1 ;NEXT action I ("Nn"[ANS) D Q 0 .;Echo rest of response .W:(ANS="N") "EXT" .W:(ANS="n") "ext" .H 1 .F ARRAYREF="INFILER","OUTFILER" D ..;Move down 4 entries in list ..S NEWTOP=$S(ARRAYREF="INFILER":INTOP,1:OUTTOP) ..F LOOP=1:1:4 S NEWTOP=+$O(@ARRAYREF@(NEWTOP)) Q:('NEWTOP) ..;Went past bottom of list - set to last entry in list ..I ('NEWTOP) S NEWTOP="" S NEWTOP=+$O(@ARRAYREF@(NEWTOP),-1) ..;Save new value into appropriate variable ..S:(ARRAYREF="INFILER") INTOP=NEWTOP ..S:(ARRAYREF="OUTFILER") OUTTOP=NEWTOP ;BACKUP action I ("Bb"[ANS) D Q 0 .;Echo rest of response .W:(ANS="B") "ACKUP" .W:(ANS="b") "ackup" .H 1 .F ARRAYREF="INFILER","OUTFILER" D ..;Move up 4 entries in list ..S NEWTOP=$S(ARRAYREF="INFILER":INTOP,1:OUTTOP) ..F LOOP=1:1:4 S NEWTOP=+$O(@ARRAYREF@(NEWTOP),-1) Q:('NEWTOP) ..;Went past top of list - set to first entry in list ..I ('NEWTOP) S NEWTOP="" S NEWTOP=+$O(@ARRAYREF@(NEWTOP)) ..;Save new value into appropriate variable ..S:(ARRAYREF="INFILER") INTOP=NEWTOP ..S:(ARRAYREF="OUTFILER") OUTTOP=NEWTOP ;START/STOP/DELETE action I ("+-*"[ANS) D Q 0 .;Remember action .S ANS1=ANS .;Get type of filer .R ANS#1:3 Q:('$T) .;Invalid response .S ANS=$TR(ANS,"io","IO") .Q:("IO"'[ANS) .;Echo complete selection .W " ",$S(ANS1="+":"START",ANS1="-":"STOP",1:"DELETE")," " .W $S(ANS="O":"OUTGOING",1:"INCOMING")," FILER" .H 1 .;START action .I (ANS1="+") D Q ..;Start incoming filer ..I (ANS="I") S TMP=$$TASKFLR^HLCS1("IN") ..;Start outgoing filer ..I (ANS="O") S TMP=$$TASKFLR^HLCS1("OUT") .;STOP action .I (ANS1="-") D Q ..S ARRAYREF=$S(ANS="I":"INFILER",1:"OUTFILER") ..;Get first filer in list that hasn't been asked to stop ..S TMP=0 ..F S TMP=+$O(@ARRAYREF@(TMP)) Q:('TMP) Q:($P(@ARRAYREF@(TMP),"^",3)="No") ..;No filer to stop ..Q:('TMP) ..;Stop incoming filer ..I (ANS="I") D STOPFLR^HLCSUTL1(TMP,"IN") ..;Stop outgoing filer ..I (ANS="O") D STOPFLR^HLCSUTL1(TMP,"OUT") .;DELETE action .S ARRAYREF=$S(ANS="I":"INFILER",1:"OUTFILER") .;Find all tasks that have stopped due to error .K TMPARR .S LOOP=0 .F S LOOP=+$O(@ARRAYREF@(LOOP)) Q:('LOOP) D ..;Make sure task stopped due to error ..S TMP=@ARRAYREF@(LOOP) ..Q:($P(TMP,"^",3)'="Error") ..;Get task number ..S TMP=+TMP ..;Store by task number ..S TMPARR(TMP)=LOOP .;No selection required .Q:('$O(TMPARR(""))) .;Make selection - autoselects on single entry .S TMP=$$SELECT^HLDTIWU0("TMPARR","filer task number") .;Delete selection .I (TMP>0) D ..;Delete incoming filer ..I (ANS="I") D DELFLR^HLCSUTL1(TMPARR(TMP),"IN") ..;Delete outgoing filer ..I (ANS="O") D DELFLR^HLCSUTL1(TMPARR(TMP),"OUT") .;Whitespace - needed for screen refreshing .W !!!!! ;Invalid response Q 0 HLCSIN HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2**;Oct 13, 1995 STARTIN ;Main entry point for incoming background filer ;Create/find entry denoting this filer in the INCOMING FILER TASK ; NUMBER multiple (field #20) of the HL COMMUNICATION SERVER PARAMETER ; file (#869.3) S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"IN") ;Loop through Logical Links and check for incoming messages S HLXX=0 S HLCSLOOP=0 F S HLXX=+$O(^HLCS(870,HLXX)) D Q:(+$$CHK4STOP^HLCSUTL2(HLPTRFLR,"IN")) .;Update LAST KNOWN $H (field #.03) for filer every 5th iteration .D:('(HLCSLOOP#5)) SETFLRDH^HLCSUTL1(HLPTRFLR,"IN") .;Increment loop counter (reset to 0 when greater than 1000) .S HLCSLOOP=HLCSLOOP+1 .S:(HLCSLOOP>1000) HLCSLOOP=0 .;Went past last Logical Link .I ('HLXX) H 1 Q .;Check Logical Link's queue for received message .S HLD0=$$DEQUEUE^HLCSQUE(HLXX,"IN") .I ((+HLD0)<0) H 1 Q .;Make sure message is ready to be received .S HLD1=$P(HLD0,"^",2) .S HLD0=+HLD0 .I ($P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A") D Q ..;Set status to DONE ..D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") .;Process received message .D RECEIVE^HLMA0(HLD0,HLD1) .;Set status to DONE .D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") .;Update LAST KNOWN $H (field #.03) for filer .D SETFLRDH^HLCSUTL1(HLPTRFLR,"IN") ;Asked to stop S ZTSTOP=1 ;Delete entry denoting this filer D DELFLR^HLCSUTL1(HLPTRFLR,"IN") ;Clean up and QUIT K HLD0,HLD1,HLOGLINK,HLNODE,HLPARENT K HLST1,HLXX,TMP,TMP1,HLPTRFLR,HLCSLOOP S ZTREQ="@" Q HLCSLNCH HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;05/07/96 10:13 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**6**;Oct 13, 1995 ; ;This program is callable from a menu ;It allows the user to Start and Stop the Lower Layer ;Protocol in the Background or in the foreground ; ;Required or Optional INPUT PARAMETERS ; None ; ; ;Output variables ; HLDP=IEN of Logical Link in file #870 ;(optional)HLTRACE=if SET it launches the LLP in the Foreground ;(optional) ZTSK=if defined LLP was launched in the ;background ; ; START ; Start up the lower level protocol N DA,DIE,DIRUT,DTOUT,DUOUT,DR,HLDP,HLDAPP,ZTSK,HLTRACE,DIC N HLPARM,HLTYPTR,HLBGR ;S X="STARTQ^HCSLNCH",@^%ZOSF("TRAP") W !!,"This option is used to launch the lower level protocol for the" W !,"appropriate device. Please select the node with which you want" W !,"to communicate",! S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC G:Y<0 STARTQ S HLDP=+Y,HLDAPP=Y(0,0) ;-- get 0 node of paramter file S HLPARM=$G(^HLCS(869.2,+$P(Y(0),U,3),0)) ;-- get pointer to LLP type S HLTYPTR=$P(HLPARM,U,2) ;-- get routine (background job for LLP) S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)) ;-- get environment check routine (HLQUIT should be defined in fails) S HLENV=$G(^HLCS(869.1,HLTYPTR,200)) ; ;-- check if parameter have been setup I HLPARM="" W !,*7,"No Parameters have been set up for this logical link." G STARTQ ;-- check for LLP type I 'HLTYPTR W !,*7,"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ I HLBGR="" W !,*7,"No routine has been specified for this LLP." G STARTQ ; ;-- execute environment check routine if HLQUIT is defined then terminate I HLENV'="" K HLQUIT X HLENV G:$D(HLQUIT) STARTQ ; I $P(Y(0),U,10) W !,*7,"The LLP was last started on ",$$DAT2^HLUTIL1($P(Y(0),U,10)),"." I $P(Y(0),U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(Y(0),U,11)),"." I $P(Y(0),U,4)="Y" W !,"The LLP appears to be online already !" I $$TASK^HLUTIL1($P(Y(0),U,12)) W !,*7,"NOTE: The lower level protocol for this application is already running." G STARTQ ; W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT" S DIR("A")="Method for running the receiver" S DIR("B")="B" S DIR("?",1)="Enter F for Foreground (and trace)" S DIR("?",2)=" B for Background (normal) or" S DIR("?")=" Q to quit without starting the receiver" D ^DIR K DIR Q:(Y=U)!(Y="Q") ; S HLX=$G(^HLCS(870,HLDP,0)) ;-- foreground I Y="F" S HLTRACE=1 D G STARTQ . X HLBGR ;-- background I Y="B" D G STARTQ .S ZTRTN=$P(HLBGR," ",2) .S HLTRACE="",ZTIO="" .S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="" .S ZTDTH=$H D ^%ZTLOAD .W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.") ; Q ; ; STARTQ ; I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running." Q ; STOP ; Shut down a lower level protocol.. N DA,DIE,DIRUT,DR,DTOUT,DUOUT,HLDP,HLDAPP,X,Y,DIC W !!,"This option is used to shut down the lower level protocol for the" W !,"appropriate device. Please select the node which you would" W !,"like to shutdown.",! S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0 S HLDP=+Y,HLDAPP=Y(0,0) ; I $P(Y(0),U,10) W !,*7,"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(Y(0),U,10)),"." ; W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q ; D MONITOR^HLCSDR2("SHUTTING DOWN",5,HLDP) D NOW^%DTC S DIE=870,DA=HLDP,DR="10///^S X=%;9////@;11////@;3////N;14////1" D ^DIE W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down." ; STOPQ Q HLCSMM HLCSMM ;ISC/MTC-Create Mail Message and Entry in the HL7 Transmission File ;10/25/96 11:39 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**17**;Oct 13, 1995 Q ; EN(HLD0,HLD1) ; This routine will send a Message from the Out Queue to the ; MailGroup Specified in the Logical Link file (#870). It is called ; from HLCSMM1 routine that monitors the queue for a link. The MM LLP ; uses stuffing to indicate the end of segments. The message ; will use the following format within the XMB global. ; ^XMB(3.9,..1)=Segment 1 ; ^XMB(3.9,..2)="" - End of segment 1 ; ^XMB(3.9,..3)=Segment 2 ; ^XMB(3.9,..4)=Continuation of segment 2 ; ^XMB(3.9,..5)="" - End of segment 2 ; " " ; This processing will enable segment greater than 245. ; ; INPUT : HLD0 - IEN of Logical Link file (#870) ; : HLD1 - IEN of OutQueue Mutiple (Message) ; ; OUTPUT: NONE ; N HLI,HLI0,HLSERV,HLFAC,HLERR,HLOGLINK,HLMSTXT,HLPARENT,HLPTXT N HLPARM ; S HLERR="",HLOGLINK=$G(^HLCS(870,HLD0,0)) ;-- get MailMan LLP parameters S HLPARM=$G(^HLCS(869.2,+$P(HLOGLINK,U,3),100)) ;-- set monitor to Pending D MONITOR^HLCSDR2("PENDING",5,HLD0) ; ;-- Check for valid MailGroup I '$P(HLPARM,U)!$G(^XMB(3.8,$P(HLPARM,U),0)) D G EXIT . S HLERR1=1,HLERR="Unable to determine receipients for mail message.",XMY(.5)="" ;-- facility ;---- start of IHS change ;IHS/TUC/DLR 01/11/96 IHS PATCH 1 - replace VA call with IHS call ;S HLFAC=$P($$SITE^VASITE,"^",2) S HLFAC=$P($$SITE^HLZFUNC,"^",2) ;---- end of IHS change ;-- date D NOW^%DTC S Y=% X ^DD("DD") S HLDT=Y ;-- application name S HLDAN=$P(HLOGLINK,U) ; ;-- Build MailMan variables ; MM S XMSUB="HL7 Message "_HLDT_" from Station "_HLFAC,XMDUZ=.5 D XMZ^XMA2 ;-- if error exit I XMZ<1 G MM S HLXMZ=XMZ ; ;-- set status to Writing D MONITOR^HLCSDR2("WRITING",5,HLD0) ; ;-- Take message text from file (#870) load into MailMan (#3.9) S HLI0=0 K HLX N X S HLI=0 F S HLI=$O(^HLCS(870,HLD0,2,HLD1,1,HLI)) Q:HLI="" S X=^(HLI,0) D .S HLI0=HLI0+1,HLX(HLI,0)=X I HLI0#100=0 D ..M ^XMB(3.9,HLXMZ,2)=HLX K HLX .;S HLI0=HLI0+1,^XMB(3.9,HLXMZ,2,HLI0,0)=^HLCS(870,HLD0,2,HLD1,1,HLI,0) MRG ;Merge last block into 3.9 I $D(HLX) M ^XMB(3.9,HLXMZ,2)=HLX K HLX ; S ^XMB(3.9,HLXMZ,2,0)="^3.92A^"_HLI0_U_HLI0_U_$$DT^XLFDT,XMDUN="POSTMASTER" ;-- Mail Group S X=$G(^XMB(3.8,$P(HLPARM,U),0)),XMY("G."_$P(X,U))="" ; ;-- Send Mail D ENT1^XMD ;-- Set message status do 'done' S $P(^HLCS(870,HLD0,2,HLD1,0),"^",2)="D" ; ;-- set monitor to Idle D MONITOR^HLCSDR2("IDLE",5,HLD0) ; EXIT ; ;-- if error I HLERR'="" D .;-- send Mail Message indicating error .D GET^XMA2 .S HLXMZ=HLZ .S ^XMB(3.9,HLXMZ,2,1,0)="Unable to transmit HL7 message due to the following Application Error:",^XMB(3.9,HLXMZ,2,2,0)=HLERR,^XMB(3.9,HLXMZ,2,0)="^3.92A^2^2^"_DT .S XMY(.5)="" D ENT1^XMD ; K XMDUZ,XMDUN,XMSUB,XMY,XMZ Q ; HLCSMON1 HLCSMON1 ;ALB/RJS-Utilities for Driver Program ;10/02/96 09:50 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**15**;Oct 13, 1995 ; ;This routine contains several entry points called from HLCSMON ;no input parameters are required. All variables used which are ;not newed here are newed in HLCSMON ; DISPLAY ; N HLXX ;DISPLAY LINK INFO S HLXX=0 F S HLXX=$O(HLARY(HLXX)) Q:(HLXX'>0) D WLINE(HLXX) ;DISPLAY INCOMING FILER STATUS S HLXX=$$CNTFLR^HLCSUTL2("IN") ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED I (HLXX'=+HLRUNCNT) D .D WDATA^HLCSMON1(5,18,IOELALL,"","Number of incoming filers running => ",45) .I (HLXX) D WDATA(42,18,"","",HLXX) .I ('HLXX) D WDATA(42,18,IOINHI,IOINORM,"Zero") .S $P(HLRUNCNT,"^",1)=HLXX ;DISPLAY OUTGOING FILER STATUS S HLXX=$$CNTFLR^HLCSUTL2("OUT") ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED I (HLXX'=+$P(HLRUNCNT,"^",2)) D .D WDATA^HLCSMON1(5,19,IOELALL,"","Number of outgoing filers running => ",45) .I (HLXX) D WDATA(42,19,"","",HLXX) .I ('HLXX) D WDATA(42,19,IOINHI,IOINORM,"Zero") .S $P(HLRUNCNT,"^",2)=HLXX Q WLINE(HLXX) ; ; ;Piece out the data ; S HLNODE=$P(HLARY(HLXX),U,1),HLIBKPTR=$P(HLARY(HLXX),U,7),HLIFRPTR=$P(HLARY(HLXX),U,6) S HLOBKPTR=$P(HLARY(HLXX),U,9),HLOFRPTR=$P(HLARY(HLXX),U,8),HLONLINE=$P(HLARY(HLXX),U,4) S HLSTATE=$P(HLARY(HLXX),U,5),HLGERROR=$P(HLARY(HLXX),U,19) ; ;Only if it has changed do we change it on the screen.This keeps the ;display from flickering ; I HLNODE'=$G(HLRNODE(HLXX))!(HLGERROR="") D WDATA(5,HLXX,IOBOFF_IORVOFF,"",HLNODE,8) S HLRNODE(HLXX)=HLNODE I HLGERROR'="" D WDATA(5,HLXX,IOBON_IORVON,IOBOFF_IORVOFF,HLNODE,8) I HLIBKPTR'=$G(HLIBK(HLXX)) D WDATA(16,HLXX,"","",HLIBKPTR,8) S HLIBK(HLXX)=HLIBKPTR I HLIFRPTR'=$G(HLIFR(HLXX)) D WDATA(26,HLXX,"","",HLIFRPTR,8) S HLIFR(HLXX)=HLIFRPTR I HLOBKPTR'=$G(HLOBK(HLXX)) D WDATA(37,HLXX,"","",HLOBKPTR,8) S HLOBK(HLXX)=HLOBKPTR I HLOFRPTR'=$G(HLOFR(HLXX)) D WDATA(47,HLXX,"","",HLOFRPTR,8) S HLOFR(HLXX)=HLOFRPTR I HLONLINE'=$G(HLRONLN(HLXX)) D WDATA(60,HLXX,"","",HLONLINE,1) S HLRONLN(HLXX)=HLONLINE I HLSTATE'=$G(HLRSTATE(HLXX)) D WDATA(66,HLXX,"","",HLSTATE,10) S HLRSTATE(HLXX)=HLSTATE Q WDATA(DX,DY,IO1,IO2,HLDATA,HLENGTH) ; ; ;First erase the data block then write to it. Attributes are ;contained in IO1 & IO2 ; N X S X=0 X ^%ZOSF("RM") X ^%ZOSF("XY") ;Turn off terminal line wrap & inform O/S where cursor is located I '$D(HLENGTH) S HLENGTH=$L(HLDATA) X IOXY W IOSC,$E($J(" ",79),1,HLENGTH),IORC W IO1,$E(HLDATA,1,HLENGTH),IO2 S X=IOM X ^%ZOSF("RM") ;Turn terminal line wrap back on Q HLCSOUT HLCSOUT ;ALB/JRP - OUTGOING FILER;2/25/97 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**25**;Oct 13, 1995 STARTOUT ;Main entry point for outgoing background filer ;Create/find entry denoting this filer in the OUTGOING FILER TASK ; NUMBER multiple (field #30) of the HL COMMUNICATION SERVER PARAMETER ; file (#869.3) S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"OUT") ;Check if any outgoing messages are in the pending transmission queue S HLPTRLL=0 S HLCSLOOP=0 F S HLPTRLL=+$O(^HL(772,"A-XMIT-OUT",HLPTRLL)) D Q:($$CHK4STOP^HLCSUTL2(HLPTRFLR,"OUT")) .;Update LAST KNOWN $H (field #.03) for filer every 5th iteration .D:('(HLCSLOOP#5)) SETFLRDH^HLCSUTL1(HLPTRFLR,"OUT") .;Increment loop counter (reset to 0 when greater than 1000) .S HLCSLOOP=HLCSLOOP+1 .S:(HLCSLOOP>1000) HLCSLOOP=0 .I ('HLPTRLL) H 1 Q .;Check for pending messages .S HLXX=+$O(^HL(772,"A-XMIT-OUT",HLPTRLL,0)) .;No pending messages .I ('HLXX) H 1 Q .;Lock main node of Message Text .L +^HL(772,HLXX,0):1 I ('$T) H 1 Q .;Make sure status hasn't changed .I ('$D(^HL(772,"AF",1,HLXX))) L -^HL(772,HLXX,0) Q .;Get Logical Link and parent message .; Set status to ERROR DURRING TRANSMISSION if not present .S HLNODE=^HL(772,HLXX,0) .S HLOGLINK=$P(HLNODE,"^",11) .I (HLOGLINK'>0) D Q ..D STATUS^HLTF0(HLXX,4,"","Logical Link not available") ..L -^HL(772,HLXX,0) .S HLPARENT=$P(HLNODE,"^",8) .I (HLPARENT'>0)!('$G(^HL(772,HLPARENT,0))) D Q ..D STATUS^HLTF0(HLXX,4,"","Parent Message not available") ..L -^HL(772,HLXX,0) .;Build message header or batch header .S HLHDRBLD=$P(^HL(772,HLPARENT,0),U,14) .I (HLHDRBLD'="B")&(HLHDRBLD'="M")&(HLHDRBLD'="F") D Q ..D STATUS^HLTF0(HLXX,4,"","Message Type (field #772,14) Error") ..L -^HL(772,HLXX,0) .S HLERROR="" .I (HLHDRBLD="M") D HEADER^HLCSHDR(HLXX,.HLERROR) .I (HLHDRBLD'="M") D BHSHDR^HLCSHDR(HLXX) S:($E(HLHDR(1),1,2)="-1") HLERROR=$P(HLHDR(1),"^",2) .;If error set status ERROR DURING TRANSMISSION .I ($G(HLERROR)'="") D STATUS^HLTF0(HLXX,4) L -^HL(772,HLXX,0) Q .S HLD0=$$ENQUEUE^HLCSQUE(HLOGLINK,"OUT") .;If error set status ERROR DURING TRANSMISSION .I ((+HLD0)<0) D STATUS^HLTF0(HLXX,4) L -^HL(772,HLXX,0) Q .S HLD1=$P(HLD0,"^",2) .S HLD0=+HLD0 .;Move Message Header and Message Text to file 870 .D MERGEOUT^HLTF2(HLPARENT,HLD0,HLD1,"HLHDR") .K HLHDR .;Status in queue to "PENDING" .D MONITOR^HLCSDR2("P",2,HLD0,HLD1,"OUT") .;Determine status, default to "Awaiting Ack" .S HLST1=$$FNDSTAT^HLUTIL3(HLXX) .S:('HLST1) HLST1=2 .;Update status .D STATUS^HLTF0(HLXX,HLST1) .;Unlock main node of Message Text .L -^HL(772,HLXX,0) .;Update LAST KNOWN $H (field #.03) for filer .D SETFLRDH^HLCSUTL1(HLPTRFLR,"OUT") ;Asked to stop S ZTSTOP=1 ;Delete entry denoting this filer D DELFLR^HLCSUTL1(HLPTRFLR,"OUT") ;Clean up and QUIT K HLD0,HLD1,HLOGLINK,HLNODE,HLPARENT,HLXX,HLST1,HLPTRLL K HLERROR,HLHDRBLD,HLHDR,TMP,TMP1,HLPTRFLR,HLCSLOOP S ZTREQ="@" Q HLCSUTL HLCSUTL ;ALB/MTC - CS Utility Routines - 5/10/95 ;04/25/96 10:59 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2**;Oct 13, 1995 ; Q ; READ(HLDHANG,HLDBSIZE,HLTRM) ; This function will perform a read on the device and ; return the characters read and the termination character. ; ; INPUT : HLDHANG - TimeOut for read ; HLDBSIZE- Block Size for read ; HLTRM - Passed by reference to return termination char ; OUTPUT: - Ok ; -1^TIMEOUT : fails ; N RESULT,X,Y ; K HLTOUT ;-- do read U IO R X#HLDBSIZE:HLDHANG I '$T S RESULT="-1^TIMEOUT" G READQ X ^%ZOSF("TRMRD") S HLTRM=Y S RESULT=X ; READQ Q RESULT ; NEXTLINE(LL0,LL1,LINE,ARR,QUE) ; This function will return the next line from the ; Logical Link file #870 specified by LL0 and the position in the queue ; specified by QUE at the position LL1. This function will return the ; line in the array specifed by ARR. And the position in the WP ; field where the last part of the segment was found. ; Lastly a will be appended to the end of the segment ; ; INPUT : ; LL0 - IFN of logical link ; LL1 - Position in QUE to begin search for next line ; LINE- Last line position, "" will return first line ; ARR - Array to store next line. The output will be in the ; following format ARR(1), ARR(2) ; QUE - Will specify "IN" or "OUT" queue to pull data from ; ; OUTPUT: ; ARR - As specified above ; RESULT - Position last segment was found or "" if no line ; was found. ; ; N RESULT,HLQUE,X,I S RESULT="",HLQUE=$S(QUE="IN":1,QUE="OUT":2,1:"") ;-- start looking for next line S X=+LINE,I=0 F S X=$O(^HLCS(870,LL0,HLQUE,LL1,1,X)) Q:'X D I $G(^HLCS(870,LL0,HLQUE,LL1,1,X,0))="" S RESULT=X,@ARR@(I)=@ARR@(I)_$C(13) Q . I $D(^HLCS(870,LL0,HLQUE,LL1,1,X,0)),^(0)'="" S I=I+1,@ARR@(I)=$G(^HLCS(870,LL0,HLQUE,LL1,1,X,0)) ; Q RESULT ; CHKSUM(HLTEXT) ; This function will return the checksum for the segment ; contained in the array ARR. If no checksum can be calculated an -1 ; will be returned. ; ; INPUT - HLTEXT the name of the array to be used in the calulation ; of the checksum. The format is ARR(1,N),...ARR(M,N) ; OUTPUT - Decimal checksum %ZOSF("LPC")^Lenght of segment ; N RESULT,LEN,X,X1,X2,X3,Y,I S RESULT="",LEN=0,X1=0 ; F S X1=$O(@HLTEXT@(X1)) Q:'X1 S X=@HLTEXT@(X1),X2=$D(@HLTEXT@(X1)),LEN=LEN+$L(X) D . X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y) . I X2=11 S X3=0 F S X3=$O(@HLTEXT@(X1,X3)) Q:'X3 D .. S X=@HLTEXT@(X1,X3),LEN=LEN+$L(X) X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y) ; S X=RESULT X ^%ZOSF("LPC") S RESULT=Y Q RESULT_"^"_LEN ; CHKSUM2(HLTEXT) ; *** Add in *** This function will return the checksum for the segment ; contained in the array ARR. If no checksum can be calculated an -1 ; will be returned. ; ; INPUT - HLTEXT the name of the array to be used in the calulation ; of the checksum. The format is ARR(1,N),...ARR(M,N) ; OUTPUT - Decimal checksum %ZOSF("LPC")^Lenght of segment ; N RESULT,LEN,X,X1,X2,X3,Y,I S RESULT="",LEN=0,X1=0 ; F S X1=$O(@HLTEXT@(X1)) Q:'X1 S X=@HLTEXT@(X1),X2=$D(@HLTEXT@(X1)),LEN=LEN+$L(X) D . X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y) . I X2=1 S RESULT=RESULT_$C(13),LEN=LEN+1 Q . I X2=11 S X3=0 F S X3=$O(@HLTEXT@(X1,X3)) Q:'X3 D .. S X=@HLTEXT@(X1,X3),LEN=LEN+$L(X) X ^%ZOSF("LPC") S RESULT=RESULT_$C(Y) ..I $O(@HLTEXT@(X1,X3))="" S RESULT=RESULT_$C(13),LEN=LEN+1 ; S X=RESULT X ^%ZOSF("LPC") S RESULT=Y Q RESULT_"^"_LEN ; APPEND(HLTEXT,LL0,LL1) ; This function will append the data contained in ; the HLTEXT array into the IN queue multiple (LL1) of the Logical ; Link (LL0) file 870. ; INPUT : HLTEXT - Array containing text to append ; LL0 - IEN of File 870 ; LL1 - IEN of IN queue multiple ; N HLI,X,X1,X2,X3 S X="" S HLI=$P($G(^HLCS(870,LL0,1,LL1,1,0)),U,3) S:'HLI HLI=0 F S X=$O(@HLTEXT@(X)) Q:'X S HLI=HLI+1,^HLCS(870,LL0,1,LL1,1,HLI,0)=@HLTEXT@(X),X2=$D(@HLTEXT@(X)) D . I X2=11 S ^HLCS(870,LL0,1,LL1,2,HLI,0)="" S X3=0 F S X3=$O(@HLTEXT@(X,X3)) Q:'X3 D .. S HLI=HLI+1,^HLCS(870,LL0,1,LL1,1,HLI,0)=$G(@HLTEXT@(X,X3)) . S HLI=HLI+1,^HLCS(870,LL0,1,LL1,1,HLI,0)="" Q ; ;-- update 0 node S ^HLCS(870,LL0,1,LL1,1,0)="^^"_HLI_"^"_HLI_"^"_DT_"^" Q ; HLNEXT ;-- This routine is used to return the next segment from file 772 ; during processing of an inbound message. The following variables ; are used for the processing. ; HLMTIEN - Entry in 772 where message is ; HLQUIT - Curent ien of "IN" wp field ; HLNODE - Data is returned in HLNODE=Segment and HLNODE(n) if ; segmemt is greater than 245 chars. ; K HLNODE N HLI,HLDONE S HLNODE="",HLDONE=0 I HLQUIT="" S HLQUIT=0 S HLQUIT=$O(^HL(772,HLMTIEN,"IN",HLQUIT)) Q:'HLQUIT S HLNODE=$G(^(HLQUIT,0)) I HLQUIT D . S HLI=0 F S HLQUIT=$O(^HL(772,HLMTIEN,"IN",HLQUIT)) Q:'HLQUIT D Q:HLDONE .. I ^HL(772,HLMTIEN,"IN",HLQUIT,0)="" S HLDONE=1 Q .. S HLI=HLI+1,HLNODE(HLI)=$G(^HL(772,HLMTIEN,"IN",HLQUIT,0)) Q Q ; HLCSUTL2 HLCSUTL2 ;ALB/JRP - COMMUNICATION SERVER UTILITIES;15-MAY-95 ;10/25/96 11:01 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**18**;Oct 13, 1995 CHK4STOP(PTRSUB,FLRTYPE) ;DETERMINE IF FILER SHOULD STOP ;INPUT : PTRSUB - Pointer to incoming or outgoing filer subentry ; FLRTYPE - Indicates type of filer ; IN = Incoming (default) ; OUT = Outgoing ;OUTPUT : 0 - Filer/task has not been asked to stop ; 1 - Filer/task has been asked to stop ;NOTES : This checks the STOP FILER field (#.02) of the INCOMING ; FILER TASK NUMBER and OUTGOING FILER TASK NUMBER multiples ; (fields 20 & 30) of the HL COMMUNICATION SERVER PARAMETER ; file (#869.3). If this field is set to YES, the filer ; has been asked to stop. After checking this, TaskMan ; will be asked if the task has been asked to stop [by ; calling $$S^%ZTLOAD]. ; : FileMan is not used when determining if the STOP FILER field ; has been set to YES ; ;Check input S PTRSUB=+$G(PTRSUB) S FLRTYPE=$G(FLRTYPE) ;Declare variables N PTRMAIN,NODE,STOP S STOP=0 S NODE=$S(FLRTYPE="OUT":3,1:2) ;Get entry in parameter file S PTRMAIN=+$O(^HLCS(869.3,0)) I (PTRMAIN) D .;Lock/unlock zero node of multiple - force buffer update .L +^HLCS(869.3,PTRMAIN,NODE,0):1 .L -^HLCS(869.3,PTRMAIN,NODE,0) .;If subentry doesn't exist, filer won't die off .I '$D(^HLCS(869.3,PTRMAIN,NODE,PTRSUB)) S STOP=1 Q .;Get subentry zero node .S NODE=$G(^HLCS(869.3,PTRMAIN,NODE,PTRSUB,0)) .;STOP FILER field is piece 2 .S STOP=+$P(NODE,"^",2) ;Filer asked to stop Q:(STOP) 1 ;Check if filer asked to stop via TaskMan S STOP=+$$S^%ZTLOAD Q STOP CNTFLR(FLRTYPE) ;RETURN NUMBER OF INCOMING/OUTGOING FILERS CURRENTLY RUNNING ;INPUT : FLRTYPE - Indicates type of filer ; IN = Incoming (default) ; OUT = Outgoing ;OUTPUT : X - Number of incoming/outgoing filers that are currently ; running. This will typically be the number of entries ; in the INCOMING FILER TASK NUMBER or OUTGOING FILER ; TASK NUMBER multiples (fields 20 & 30) of the HL ; COMMUNICATION SERVER PARAMETER file (#869.3). The ; tasks associated with the entries will be checked to ; determine if they have errored out - if so, they will ; not be included in the count. ; -1 - Error ; ;Check input S FLRTYPE=$G(FLRTYPE) ;Declare variables N PTRMAIN,NODE,COUNT,PTRSUB,ZTSK S NODE=$S(FLRTYPE="OUT":3,1:2) ;Get entry in parameter file S PTRMAIN=+$O(^HLCS(869.3,0)) Q:('PTRMAIN) -1 ;Lock/unlock zero node of multiple - force buffer update L +^HLCS(869.3,PTRMAIN,NODE,0):1 L -^HLCS(869.3,PTRMAIN,NODE,0) ;Count number of subentries S PTRSUB=0 S COUNT=0 F S PTRSUB=+$O(^HLCS(869.3,PTRMAIN,NODE,PTRSUB)) Q:('PTRSUB) D .;Get task number .K ZTSK .S ZTSK=+$G(^HLCS(869.3,PTRMAIN,NODE,PTRSUB,0)) .Q:('ZTSK) .;Check status of task .D STAT^%ZTLOAD .;Task not defined, is inactive, or errored out .Q:("12"'[ZTSK(1)) .;Increment count .S COUNT=COUNT+1 Q COUNT GETFLRS(FLRTYPE,ARRAY) ;RETURN LIST OF FILERS ;INPUT : FLRTYPE - Indicates type of filer ; IN = Incoming (default) ; OUT = Outgoing ; ARRAY - Array to return list of filers in (full global ref) ;OUTPUT : ARRAY will have the following format ; ARRAY(PtrSubEntry)=TaskNumber ^ LastKnown$H ^ Stop ; PtrSubEntry - Pointer to subentry in HL COMMUNICATION ; SERVER PARAMETER file (#869.3) ; TaskNumber - Task number of filer ; LastKnown$H - Value of LAST KNOWN $H (field #.03) for ; subentry ; Stop - Flag indicating if filer was asked to stop ; (field #.02 for subentry) ; 1 = YES ; 0 = NO ;NOTES : ARRAY will be initialized (KILLed) upon entry. If no ; entries are found in ARRAY() then no filers are running. ; : ARRAY() will not be defined on bad input ; ;Check input Q:($G(ARRAY)="") S FLRTYPE=$G(FLRTYPE) ;Declare variables N PTRMAIN,NODE,PTRSUB,ZERONODE,TASKNUM,LASTDH,STOP S NODE=$S(FLRTYPE="OUT":3,1:2) ;Initialize output array K @ARRAY ;Get entry in parameter file S PTRMAIN=+$O(^HLCS(869.3,0)) Q:('PTRMAIN) ;Lock/unlock zero node of multiple - force buffer update L +^HLCS(869.3,PTRMAIN,NODE,0):1 L -^HLCS(869.3,PTRMAIN,NODE,0) ;Get list of filers S PTRSUB=0 F S PTRSUB=+$O(^HLCS(869.3,PTRMAIN,NODE,PTRSUB)) Q:('PTRSUB) D .;Get filer information .S ZERONODE=$G(^HLCS(869.3,PTRMAIN,NODE,PTRSUB,0)) .S TASKNUM=+ZERONODE .S STOP=+$P(ZERONODE,"^",2) .S LASTDH=$P(ZERONODE,"^",3) .;Put info into output array .S @ARRAY@(PTRSUB)=TASKNUM_"^"_LASTDH_"^"_STOP Q HLDTIWU3 HLDTIWU3 ;ALB/JRP - INTERFACE WORKBENCH UTILITIES;14-FEB-95 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;;Oct 13, 1995 ALL4APP(PTRAPP,OUTARR,DOTS) ;GET EVERYTHING FOR AN HL7 APPLICATION ;INPUT : PTRAPP - Pointer to HL7 APPLICATION PARAMETER file (#771) ; OUTARR - Output array (full global reference) ; - defaults to ^TMP("HL",$J) ; DOTS - Flag indicating if progress info should be printed ; 0 = No, don't print anything (default) ; 1 = Yes, print progress information ;OUTPUT : M^N^O - Number of protocols found ; M = Number of server protocols found ; N = Number of client protocols found ; O = Number of logical links found ; OUTARR("SRVR",Match,Ptr)=Name^MessageType^EventType ; OUTARR("CLNT",Match,Ptr)=Name^MessageType^EventType ; OUTARR("LINK",Match,Ptr)= ; Match = Unique match number (starting value of 1) ; Ptr = Pointer to relevant file ;NOTES : It is the responsibility of the calling application to ; initialize (KILL) OUTARR ; : 0 is returned on bad input ; ;CHECK INPUT S PTRAPP=+$G(PTRAPP) Q:('PTRAPP) 0 Q:('$D(^HL(771,PTRAPP,0))) 0 S:($G(OUTARR)="") OUTARR="^TMP(""HL"","_$J_")" S DOTS=+$G(DOTS) S:((DOTS<0)!(DOTS>1)) DOTS=0 ;DECLARE VARIABLES N SRVRFND,CLNTFND,LINKFND ;FIND SERVER & CLIENT PROTOCOLS S SRVRFND=$$PROT4APP^HLDTIWU1(PTRAPP,0,OUTARR,DOTS) S CLNTFND=$P(SRVRFND,"^",2) S SRVRFND=+SRVRFND ;FIND LOGICAL LINKS S LINKFND=$$LINK4APP^HLDTIWU2(PTRAPP,OUTARR,DOTS) ;DONE Q SRVRFND_"^"_CLNTFND_"^"_LINKFND APPLOOK(NOECHO,X,LEARN,STUB) ;APPLICATION LOOKUP ;INPUT : NOECHO - Flag indicating interactive lookup ; 0 = Interactive [echo] (default) ; 1 = Non-interactive [no echo] ; X - If defined [not NULL], will use this value for lookup ; LEARN - Flag indicating if new entry may be created ; 0 = New entry may not be created (default) ; 1 = New entry may be created ; STUB - Flag indicating if user will be prompted for other ; fields when creating a new entry ; 0 = No - prompt for rest of fields (default) ; 1 = Yes - do not prompt for rest of fields ; (automatic default values only) ;OUTPUT : Ptr^Value^New - Success ; Ptr = Pointer to entry ; Value = Value of entry selected ; New = Will be set to 1 if a new entry was created ; -1 - Unsuccessful lookup / bad input ; -2 - Timeout / abort ;NOTES : Value for lookup must be passed for non-interactive lookup ; : Exact match done for non-interactive lookup ; : Entries can not be created in non-interactive mode ; : When creating a new entry, default values will automatically ; be placed into the following fields ; ACTIVE/INACTIVE (#2) -> INACTIVE ; FACILITY NAME (#3) -> Current facility number ; COUNTRY CODE (#7) -> USA ; ;CHECK INPUT S NOECHO=+$G(NOECHO) S:((NOECHO<0)!(NOECHO>1)) NOECHO=0 S X=$G(X) Q:((NOECHO)&(X="")) -1 S LEARN=+$G(LEARN) S:((LEARN<0)!(LEARN>1)!(NOECHO)) LEARN=0 S STUB=+$G(STUB) S:((STUB<0)!(STUB>1)) STUB=0 ;DECLARE VARIABLES N DIC,Y,DTOUT,DUOUT,DINUM,DLAYGO S DIC="^HL(771," ;[NON]INTERACTIVE CALL S DIC(0)="AEMQ" I (X'="") S DIC(0)=$S(NOECHO:"MX",1:"EMQ") I (LEARN) D .S DIC(0)=DIC(0)_"L" .S DLAYGO=771 .;STUB ENTRY - DEFAULTS ONLY .;---- start of IHS change .;IHS/TUC/DLR 03/19/97 IHS PATCH 1 - replace VA call with IHS call .;S DIC("DR")="3///"_+$P($$SITE^VASITE(),"^",3)_";7Country Code///USA;2///INACTIVE" .S DIC("DR")="3///"_+$P($$SITE^HLZFUNC(),"^",3)_";7Country Code///USA;2///INACTIVE" .;---- end of IHS change .Q:(STUB) .;PROMPT FOR FIELDS .;---- start of IHS change .;IHS/TUC/DLR 03/19/97 IHS PATCH 1 - replace VA call with IHS call .;S DIC("DR")="3Facility Name~R//"_+$P($$SITE^VASITE(),"^",3)_";7Country Code//USA;4Mail Group~R;2///INACTIVE;100HL7 Field Separator;101HL7 Encoding Characters" .S DIC("DR")="3Facility Name~R//"_+$P($$SITE^HLZFUNC(),"^",3)_";7Country Code//USA;4Mail Group~R;2///INACTIVE;100HL7 Field Separator;101HL7 Encoding Characters" .;---- end of IHS change ;MAKE CALL TO DIC D ^DIC ;TIMEOUT/ABORT Q:(($D(DTOUT))!($D(DUOUT))) -2 ;RETURN OUTPUT OF CALL [Y] Q Y HLFNC HLFNC ;AISC/SAW-Routine of Functions and Other Calls Used for HL7 Messages ;12/9/94 14:44 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;;Oct 13, 1995 HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format ; INPUT: X - Name in DHCP format ; Optional - HLECDE - HL7 encoding chars ;**** NOTE: **** ;If this function is called without HLECDE as parameter than HLECH ;must be define. ; Q:'$D(X) "" Q:X="" "" I '$D(HLECH),'$D(HLECDE) Q "" I $D(HLECDE) N HLECH S HLECH=HLECDE I '$D(HLECH) Q "" N %,X1,X2,Y S X1=$P(X,",",2),X2=$L(X1," "),Y=$P(X,",")_$E(HLECH)_$P(X1," ") I X2 F %=2:1:X2 Q:$P(X1," ",%)']"" S Y=Y_$E(HLECH)_$P(X1," ",%) Q Y ; FMNAME(X,HLECDE) ;Convert a name in HL7 format to DHCP format ; INPUT: X - Name in HL7 format ; Optional - HLECDE - HL7 encoding chars ;**** NOTE: **** ;If this function is called without HLECDE as parameter than HLECH ;must be define. ; Q:'$D(X) "" Q:X="" "" I '$D(HLECH),'$D(HLECDE) Q "" I $D(HLECDE) N HLECH S HLECH=HLECDE I '$D(HLECH) Q "" ;---- start of IHS change ;IHS/TUC/DLR 03/19/97 IHS PATCH 1 - fix name conversion bug ;N %,X1 S X1=$L(X,$E(HLECH)),Y="" F %=1:1:X1 I $P(X,$E(HLECH),%)]"",$P(X,$E(HLECH),%)'="""""" S Y=Y_$P(X,$E(HLECH),%)_$S(%=1:",",$P(X,$E(HLECH),(%+1))]""&($P(X,$E(HLECH),(%+1))'=""""""):" ",1:"") N %,X1 S X1=$L(X,$E(HLECH)),Y="" F %=1:1:X1 I $P(X,$E(HLECH),%)]"",$P(X,$E(HLECH),%)'="""""" S Y=Y_$S(%=1:"",%=2:",",1:" ")_$P(X,$E(HLECH),%) ;---- end of IHS change Q Y ; HLDATE(X,Y) ;Convert date, date/time or time only in FM format to HL7 format ;Optional Variables: ;Y = The type of format to be returned if you want to force return of a ; specific format. Y must be equal to one of the following: ; DT - Date only ; TM - Time only ; TS - Date and time I X="" Q "" I '$D(Y) S Y="" N %,Z S %=$S($L(X)<7:X,1:$P(X,".",2)),%=$S(%="":"",$E(%,1,4)=2400:"0000"_$E(%,5,6),$L(%)<4:$E(%_"000",1,4),1:%) S:$L(%)=5 %=%_0 S Z=$E(X)+17_$E(X,2,7) Q $S($L(X)<7!(Y="TM"):%,Y="DT":Z,1:Z_%) FMDATE(X) ;Convert a date, date/time or time only in HL7 format to FM format I X="" Q "" S X=$P($TR(X,"+-","^"),"^") I $L(X)<7 Q X N % S %=$E(X,9,14) Q $E(X,1,2)-17_$E(X,3,8)_$S(+%:+("."_%),1:"") M10(X,HLECDE) ;Calculate M10 checksum ; INPUT : X - String to calc checksum ; Optional HLECDE - Encoding chars ;**** NOTE: **** ;If this function is called without HLECDE as parameter than HLECH ;must be define. ; Q:'$D(X) "" I '$D(HLECH),'$D(HLECDE) Q "" I $D(HLECDE) N HLECH S HLECH=HLECDE I '$D(HLECH) Q "" N %,Y S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%) Q X_$E(HLECH)_(Y#10)_$E(HLECH)_"M10" ; M11(X) ;Calculate M11 checksum ; INPUT : X - String to calc checksum ; Optional HLECDE - Encoding chars ;**** NOTE: **** ;If this function is called without HLECDE as parameter than HLECH ;must be define. ; Q:'$D(X) "" I '$D(HLECH),'$D(HLECDE) Q "" I $D(HLECDE) N HLECH S HLECH=HLECDE I '$D(HLECH) Q "" N %,Y S Y=0 F %=1:1:$L(X) S Y=Y+$E(X,%) Q X_$E(HLECH)_(Y#11)_$E(HLECH)_"M11" UPPER(X) ;Convert lowercase letters to uppercase Q:'$D(X) "" Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") HLPHONE(X,B,C) ;Convert DHCP Phone Number to HL7 Format ;Required parameters: ;X = Seven digit phone number at a minimum. Optionally, in addition, ; a three digit area code, two digit country code and other ; formatting characters (e.g., dashes) ;Optional Variables: ;B = Beeper number ;C = Comments Q:'$D(X) "" Q:$L(X)<7 "" N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C) S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z="" I $L(Y)<7 Q "" S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q "" I $L(Y)=8,189[$E(Y) S Y=$E(Y,2,8) I $L(Y)=11,189[$E(Y) S Y=$E(Y,2,11) I $L(Y)=7 Q $E($E(Y,1,3)_"-"_$E(Y,4,7)_Y1_B_C,1,40) I $L(Y)=10 Q $E("("_$E(Y,1,3)_")"_$E(Y,4,6)_"-"_$E(Y,7,10)_Y1_B_C,1,40) I $L(Y)=12 Q $E($E(Y,1,2)_" ("_$E(Y,3,5)_")"_$E(Y,6,8)_"-"_$E(Y,9,12)_Y1_B_C,1,40) Q "" HLADDR(AD,GL,HLECDE) ;Convert DHCP address fields to HL7 address format ;Required parameters: ;AD = One to four street address lines separated by uparrows (^). ;GL = Three to four geographic location components separated by ; uparrows (^). City^State or Province^Zip Code^Country Code. ; If the fourth component is not defined, it will be set to 'USA'. ; The second component must be null or an IEN in the ; State file (#5). The third component must be null or pattern ; match 5N, 9N or 5N1"-"4N. ; ; Optional HLECDE - Encoding chars ;**** NOTE: **** ;If this function is called without HLECDE as parameter than HLECH ;must be define. ; ; ;A string will be returned with six components separated by the HL7 ;component separator. The length of the string (including separators) ;may exceed 106 characters. ; Q:'$D(AD) "" Q:'$D(GL) "" I '$D(HLECH),'$D(HLECDE) Q "" I $D(HLECDE) N HLECH S HLECH=HLECDE I '$D(HLECH) Q "" I $D(XRTL) D T0^%ZOSV N I,X,Y I $P(GL,"^",4)="" S $P(GL,"^",4)="USA" I $P(GL,"^",4)="USA" S X=$P(GL,"^",3) S:X?9N X=$E(X,1,5)_"-"_$E(X,6,9) S $P(GL,"^",3)=$S(X?5N!(X?5N1"-"4N):X,1:"") S X=+$P(GL,"^",2) S $P(GL,"^",2)=$S('X:"",$P($G(^DIC(5,X,0)),"^",2)]"":$E($P(^(0),"^",2),1,2),1:"") S Y=$E(HLECH)_$P(GL,"^")_$E(HLECH)_$P(GL,"^",2)_$E(HLECH)_$P(GL,"^",3)_$E(HLECH)_$P(GL,"^",4) S X=$P(AD,"^",1,4) F I=1,2 I X["^^" S X=$P(X,"^^")_"^"_$P(X,"^^",2,3) I $E(X,$L(X))="^" S X=$E(X,1,($L(X)-1)) I $D(XRT0) S XRTN="HLFNC" D T1^%ZOSV I $L(X,"^")=1 Q $P(X,"^")_$E(HLECH)_Y I $L(X,"^")=2 Q $P(X,"^")_$E(HLECH)_$P(X,"^",2)_Y I $L(X,"^")=3 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_Y I $L(X,"^")=4 Q $P(X,"^")_", "_$P(X,"^",2)_$E(HLECH)_$P(X,"^",3)_", "_$P(X,"^",4)_Y HLFNC2 HLFNC2 ;AISC/SAW-Continuation of HLFNC, Additional Functions/Calls Used for HL7 Messages ;3/9/95 14:54 [ 05/05/97 4:02 PM ] ;;1.6;HEALTH LEVEL SEVEN;**1,3**;MAY 05, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2**;Oct 13, 1995 INIT(EID,HL,INT) ;Initialize Variables in HL array for Building a Message ; ;This is a subroutine call with parameter passing that returns an ;array of values in the variable specified by the parameter HL. If no ;error occurs, the array of values is returned. Otherwise, the single ;value HL is returned equal to the following: error code^error message ; ;Required Input Parameters ; EID = Name or IEN of the event driver or subscriber protocol in ; Protocol file for which the initialization variables are ; to be returned ; HL = The variable in which the array of values will be returned ; This parameter must be passed by reference ;Optional Input Parameter ; INT = 1 indicates that only array values for internal DHCP ; to DHCP message exchange should be initialized ; ;Check for required input parameter I $G(EID)="" S HL="7^Missing EID Input Parameter" Q I '$D(INT) S INT=0 ;Convert EID to IEN if necessary I 'EID S EID=$O(^ORD(101,"B",EID,0)) I 'EID S HL="1^"_$G(^HL(771.7,1,0)) Q N X,X1,X2 ;Get node 770 from file 101 and node 0 from file 771 S X=$G(^ORD(101,EID,770)),X1=$G(^HL(771,+X,0)) I X1']"" S HL="14^"_$G(^HL(771.7,14,0)) Q ;Set HL array variables S HL("Q")="""""",HL("FS")=$G(^HL(771,+X,"FS")),HL("ECH")=$G(^("EC")) S:HL("FS")']"" HL("FS")="^" S:HL("ECH")']"" HL("ECH")="~|\&" S HL("SAN")=$P(X1,"^"),HL("SAF")=$P(X1,"^",3) S:$P(X1,"^",7) HL("CC")=$P($G(^HL(779.004,$P(X1,"^",7),0)),"^") S HL("MTN")=$P($G(^HL(771.2,+$P(X,"^",3),0)),"^"),HL("ETN")=$P($G(^HL(779.001,+$P(X,"^",4),0)),"^") S HL("PID")=$TR($P(X,"^",6),"dtp","DTP"),HL("VER")=$P($G(^HL(771.5,+$P(X,"^",10),0)),"^") S:$P(X,"^",9) HL("APAT")=$P($G(^HL(779.003,$P(X,"^",9),0)),"^") I 'INT S:$P(X,"^",8) HL("ACAT")=$P($G(^HL(779.003,$P(X,"^",8),0)),"^") ;-- Set variables for backwards compatablity S HLQ=HL("Q"),HLFS=HL("FS"),HLECH=HL("ECH") Q MSH(HL,MID,RESULT,SECURITY) ;Create an MSH Segment for an Outgoing HL7 ;Message ; ;This is a subroutine call with parameter passing that returns an HL7 ;Message Header (MSH) segment in the variable RESULT (and possibly ;RESULT(1) if the MSH segment is longer than 245 characters). If the ;required input parameters HL or MID are missing, RESULT is returned ;equal to null ; ;Required Input Parameters ; HL = The array of values returned by the call to INIT^HLFNC2 ; MID = The Message Control ID to be included in the MSH segment. ; The Batch Control ID for the batch is returned by the ; call to CREATE^HLTF. The application concatenates a ; sequential number to the batch ID to create the MID ; RESULT = The variable that will be returned to the calling ; application as described above ;Optional Input Parameter ;SECURITY = Security to be included in field #8 of the MSH segment ; ;Check for required parameters ;---- start of IHS change ;IHS/TUC/DLR 05/05/97 IHS PATCH 3 - fix parameter return bug ;I '$D(HL)#2!('$D(MID)) Q "" I '$D(HL)#2!('$D(MID)) S RESULT="" Q ;---- end of IHS change N X,X1,X2 ;Build MSH segment from HL array variables and other input parameters S X="MSH"_HL("FS")_HL("ECH")_HL("FS")_HL("SAN")_HL("FS")_HL("SAF")_HL("FS")_$S($D(HL("RAN")):HL("RAN"),1:"")_HL("FS")_$S($D(HL("RAF")):HL("RAF"),1:"")_HL("FS")_$S($D(HL("DTM")):HL("DTM"),1:"")_HL("FS") S X=X_$S($G(SECURITY)]"":SECURITY,1:"")_HL("FS")_HL("MTN")_$E(HL("ECH"))_HL("ETN")_HL("FS")_MID_HL("FS")_HL("PID")_HL("FS")_HL("VER") S:$D(HL("SN")) $P(X,HL("FS"),13)=HL("SN") S:$D(HL("ACAT")) $P(X,HL("FS"),15)=HL("ACAT") S:$D(HL("APAT")) $P(X,HL("FS"),16)=HL("APAT") S:$D(HL("CC")) $P(X,HL("FS"),17)=HL("CC") ;If continuation pointer variable exists, insert it in piece 14 and ;create new variable X1 if length of X will be greater than 245 I $D(HL("CP")) D .I $L(X)+$L(HL("CP"))+2'>245 S $P(X,HL("FS"),14)=HL("CP") Q .S $P(X,HL("FS"),14)="",X1=HL("FS")_$P(X,HL("FS"),15,17),X=$P(X,HL("FS"),1,14) .S X2=$L(X),X=X_$E(HL("CP"),1,(245-X2)),X1=$E(HL("CP"),(246-X2),245)_X1 .S X2=$L(X) I $L(X2)<245 S X=X_$E(X1,1,(245-X2)),X1=$E(X1,(246-X2),245) S RESULT=X S:$L($G(X1)) RESULT(1)=X1 Q HLLP HLLP ;AISC/SAW-HL7 Hybrid Lower Level Protocol Receiver/Sender ;9/5/96 10:50 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**1,12**;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 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 HLNTEG HLNTEG ;INTEGRITY CHECKER;MAY 05, 1997 ;;1.6;HEALTH LEVEL SEVEN;**3**;MAY 05, 1997 ; START ; NEW BYTE,COUNT,RTN K ^UTILITY($J) F I=1:1 S X=$T(LIST+I) Q:X="" S X=$P(X,";;",2),R=$P(X,"^",1),B=$P(X,"^",2),C=$P(X,"^",3),^UTILITY($J,R)=B_"^"_C F I=1:1:6 S X=$P($T(@("LINE"_I)),";;",2,99),@("XBSUMBLD("_I_")=X") X XBSUMBLD(1) Q ; LINE1 ;;X XBSUMBLD(2),XBSUMBLD(6) LINE2 ;;S RTN="" F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" W !,RTN ZL @RTN S (BYTE,COUNT)=0 S X=$T(+1),X=$P(X," [ ",1) X XBSUMBLD(4),XBSUMBLD(3),XBSUMBLD(5) LINE3 ;;F I=2:1 S X=$T(+I) Q:X="" X XBSUMBLD(4) LINE4 ;;F J=1:1 S Y=$E(X,J) Q:Y="" S BYTE=BYTE+1,COUNT=COUNT+$A(Y) LINE5 ;;S B=$P(^UTILITY($J,RTN),"^",1),C=$P(^(RTN),"^",2) I B'=BYTE!(C'=COUNT) W " has been modified" LINE6 ;;K XBSUMBLD,B,C,I,J,R,X,Y ; LIST ; ;;HLCHK^4851^325741 ;;HLCS^6943^548127 ;;HLCS1^6994^541705 ;;HLCSDL^3783^261754 ;;HLCSDL1^6478^479189 ;;HLCSDL2^7647^553490 ;;HLCSDR^2692^180904 ;;HLCSDR1^5096^346841 ;;HLCSDR2^5133^365752 ;;HLCSFMN^5405^394914 ;;HLCSFMN0^7290^528986 ;;HLCSFMN1^5549^402467 ;;HLCSHDR^5718^420845 ;;HLCSIN^1523^111308 ;;HLCSLNCH^3664^272907 ;;HLCSMM^2826^202609 ;;HLCSMM1^2802^204009 ;;HLCSMON^4716^344325 ;;HLCSMON1^2529^176374 ;;HLCSORA1^1872^122012 ;;HLCSORA2^902^57020 ;;HLCSORAT^2913^200851 ;;HLCSOUT^2874^205545 ;;HLCSQUE^4021^282445 ;;HLCSQUE1^1400^98502 ;;HLCSQUED^1677^113843 ;;HLCSRE1^1230^80061 ;;HLCSREP^784^52059 ;;HLCSREQ^1726^115411 ;;HLCSRES^1590^106264 ;;HLCSRQ^847^56070 ;;HLCSRV^270^20954 ;;HLCSTERM^1204^78945 ;;HLCSUTL^4990^355802 ;;HLCSUTL1^4550^325136 ;;HLCSUTL2^4781^345724 ;;HLDTIW01^2648^171389 ;;HLDTIW02^2197^144044 ;;HLDTIW03^6138^408680 ;;HLDTIW04^6145^410046 ;;HLDTIW05^4517^308429 ;;HLDTIW2A^3699^256201 ;;HLDTIW2B^4583^310401 ;;HLDTIW2C^5307^345624 ;;HLDTIWP0^5317^357344 ;;HLDTIWP1^5236^348416 ;;HLDTIWP2^5266^363705 ;;HLDTIWP3^5392^371693 ;;HLDTIWP4^3133^219026 ;;HLDTIWP5^3074^209806 ;;HLDTIWP6^5008^338275 ;;HLDTIWU0^3501^245728 ;;HLDTIWU1^5555^389079 ;;HLDTIWU2^3958^275386 ;;HLDTIWU3^4298^308376 ;;HLDTIWU4^5309^375917 ;;HLDTIWU5^3058^214968 ;;HLFNC^5674^385917 ;;HLFNC1^3517^264569 ;;HLFNC2^4283^309914 ;;HLFNC3^2271^167829 ;;HLINI001^4701^298693 ;;HLINI002^4677^310547 ;;HLINI003^4728^348717 ;;HLINI004^1198^82301 ;;HLINI005^4742^321663 ;;HLINI006^4736^333161 ;;HLINI007^4682^346348 ;;HLINI008^3590^259607 ;;HLINI009^4719^327465 ;;HLINI00A^4716^343413 ;;HLINI00B^2337^156473 ;;HLINI00C^4738^316381 ;;HLINI00D^4708^318873 ;;HLINI00E^350^21603 ;;HLINI00F^4744^286606 ;;HLINI00G^4722^304636 ;;HLINI00H^4701^283540 ;;HLINI00I^4687^282502 ;;HLINI00J^4761^301577 ;;HLINI00K^4684^327056 ;;HLINI00L^4747^305948 ;;HLINI00M^4757^284582 ;;HLINI00N^4687^280081 ;;HLINI00O^4684^280493 ;;HLINI00P^4682^281425 ;;HLINI00Q^4700^282158 ;;HLINI00R^4722^283848 ;;HLINI00S^4679^280935 ;;HLINI00T^4701^282863 ;;HLINI00U^4709^283745 ;;HLINI00V^4733^283617 ;;HLINI00W^4725^282543 ;;HLINI00X^4741^283766 ;;HLINI00Y^4698^282557 ;;HLINI00Z^4705^283502 ;;HLINI010^4733^299053 ;;HLINI011^4719^332873 ;;HLINI012^4703^297284 ;;HLINI013^4711^321333 ;;HLINI014^4679^311227 ;;HLINI015^4679^312946 ;;HLINI016^4681^325556 ;;HLINI017^4714^306944 ;;HLINI018^4704^323497 ;;HLINI019^4700^300247 ;;HLINI01A^4751^307323 ;;HLINI01B^4736^275537 ;;HLINI01C^4692^313436 ;;HLINI01D^4712^300588 ;;HLINI01E^4702^313878 ;;HLINI01F^4715^308201 ;;HLINI01G^4677^307484 ;;HLINI01H^4680^296064 ;;HLINI01I^3752^246208 ;;HLINI01J^2310^142032 ;;HLINI01K^4693^306345 ;;HLINI01L^240^13593 ;;HLINI01M^3662^241921 ;;HLINI01N^4693^294382 ;;HLINI01O^4698^302547 ;;HLINI01P^2177^137680 ;;HLINI01Q^3408^224837 ;;HLINI01R^3161^197195 ;;HLINI01S^1890^110866 ;;HLINI01T^400^23290 ;;HLINI01U^1767^111851 ;;HLINI01V^2725^194820 ;;HLINI01W^1763^111563 ;;HLINI01X^4710^344148 ;;HLINI01Y^3061^218877 ;;HLINI01Z^1387^83268 ;;HLINI020^604^39174 ;;HLINI021^4733^314276 ;;HLINI022^4713^322682 ;;HLINI023^4682^325382 ;;HLINI024^4189^292516 ;;HLINI025^1433^93682 ;;HLINI026^2036^121158 ;;HLINI027^4721^293526 ;;HLINI028^4695^301747 ;;HLINI029^1423^90745 ;;HLINI02A^2259^137032 ;;HLINI02B^1617^108750 ;;HLINI02C^2152^129093 ;;HLINI02D^924^56810 ;;HLINI02E^2125^129384 ;;HLINI02F^488^29259 ;;HLINI02G^1834^114718 ;;HLINI02H^596^35806 ;;HLINI02I^4756^318511 ;;HLINI02J^4185^282415 ;;HLINI02K^4684^301142 ;;HLINI02L^318^18487 ;;HLINI02M^4692^330781 ;;HLINI02N^4743^348842 ;;HLINI02O^4732^326406 ;;HLINI02P^3167^216547 ;;HLINI02Q^4778^322065 ;;HLINI02R^4737^319596 ;;HLINI02S^4732^349652 ;;HLINI02T^4698^315261 ;;HLINI02U^4686^316608 ;;HLINI02V^4687^321184 ;;HLINI02W^4713^316985 ;;HLINI02X^4696^275483 ;;HLINI02Y^2840^164701 ;;HLINIS^1605^111436 ;;HLINIT^3173^198212 ;;HLINIT1^1861^115612 ;;HLINIT2^1581^96969 ;;HLINIT3^4795^281925 ;;HLINIT4^1226^69099 ;;HLINIT5^1447^95387 ;;HLLM^4571^287853 ;;HLLM1^1676^106317 ;;HLLP^4221^275313 ;;HLMA^3502^264067 ;;HLMA0^1099^86998 ;;HLMA1^3453^258012 ;;HLMA2^1760^142431 ;;HLONI001^4678^307348 ;;HLONI002^4721^323712 ;;HLONI003^4745^300501 ;;HLONI004^4677^318360 ;;HLONI005^4711^321001 ;;HLONI006^4697^317763 ;;HLONI007^4707^333218 ;;HLONI008^4747^326833 ;;HLONI009^4734^323020 ;;HLONI010^4730^325594 ;;HLONI011^405^23768 ;;HLONIT^521^34328 ;;HLONIT1^578^36541 ;;HLONIT2^173^10507 ;;HLONIT3^3605^214017 ;;HLPOST^3118^218191 ;;HLPOST16^4370^309074 ;;HLPOSTQ^2700^198177 ;;HLPRE16^917^64558 ;;HLSERV^1034^69238 ;;HLTASK^823^59049 ;;HLTF^7853^571287 ;;HLTF0^4201^316875 ;;HLTF1^5703^407607 ;;HLTF2^4152^307804 ;;HLTP^3465^257618 ;;HLTP0^3159^222455 ;;HLTP01^2973^210704 ;;HLTP1^3153^234415 ;;HLTP2^1582^122901 ;;HLTPCK1^2583^191287 ;;HLTPCK1A^5732^384628 ;;HLTRANS^4286^299063 ;;HLUOPT^3115^214956 ;;HLUOPT1^4377^311587 ;;HLUPDATE^1921^132203 ;;HLUTIL1^2337^169084 ;;HLUTIL2^4679^326029 ;;HLUTIL3^1363^97526 ;;HLZFUNC^225^13813 HLTF HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;2/22/95 16:32 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**1**;Oct 13, 1995 FILE ;Create Entries in files 772 and 773 for Version 1.5 Interface Only N %,%H,%I,DA,HLMID,MTIEN,X,Y L +^HL(772,0) F D NOW^%DTC Q:'$D(^HL(772,"C",%)) D MA(%) L -^HL(772,0) D MT(HLMID,HLDT) S HLDA=MTIEN Q CREATE(HLMID,MTIEN,HLDT,HLDT1) ;Create entries in Message Administration ; (#773) and Message Text (#772) files ; ;Input : HLMID = Variable in which value of message ID will be ; returned (pass by reference) ; MTIEN = Variable in which IEN of Message Text file entry ; will be returned (pass by reference) ; HLDT = Variable in which current date/time in FM internal ; format will be returned (pass by reference) ; HLDT1 = Variable in which current date/time in HL7 format ; will be returned (pass by reference) ; ;Output : See above ; ;Notes : If HLMID has a value [upon entry], the created entries will ; be given that value for their message IDs ; : If HLDT has a value [upon entry], the created entries will ; be given that value for their date/time (value of .01) ; : Current date/time used if HLDT is not passed or invalid ; ;Make entry in Message Administration file ; (use of HLDT & HLMID checked there) S HLDT=$G(HLDT) D MA(HLDT) ;Make associated entry in Message Text file D MT(HLMID,HLDT) Q MA(HLX) ;Create entry in Message Administration file (#773) ; ;Input : HLX = Date/time entry in file should be given (value of .01) ; Defaults to current date/time ; HLMID = Value to use as the message ID ; Default value will be calculated ; ;Output : HLMID = Value used as message ID ; HLDT = Date/time of created entry (value of .01) ; ;Notes : HLMID is not contained within the parameter list ; : HLX must be in FileMan format (default value used if not) ; : HLDT will be in FileMan format ; ;Check for input S HLX=$G(HLX) S HLMID=$G(HLMID) ;Declare variables N %,%H,%I,DIC,X,Y,PTRMAF,DR,DA,DIE MAL ;Determine date/time (if needed) I (HLX'?7N.1".".6N) D NOW^%DTC S HLX=% ;Make entry S (HLDT,X)=HLX S DIC="^HLMA(" S DIC(0)="L" K DD,DO D FILE^DICN ;Entry not created - try again I (Y<0) S HLX="" G MAL ;Remember entry number S PTRMAF=+Y ;Determine message ID (if needed) I (HLMID="") S HLMID=PTRMAF ;Store message ID S DIE="^HLMA(" S DA=PTRMAF S DR="2///"_HLMID D ^DIE Q MT(HLMID,HLDT) ;Create entry in Message Text file (#772) ; ;Input : HLMID = Message ID of entry in Message Administration ; file (#773) to associate created entry with ; HLDT = Date/time of entry in Message Administration ; file (#773) to associate created entry with ; ;Output : HLDT1 = HLDT in HL7 format ; ;Notes : HLDT must be in FileMan format ; : HLDT1 will be NULL if associated entry in 773 is not found ; ;Check for required parameters Q:(($G(HLMID)="")!($G(HLDT)="")) Q:(HLDT'?7N.1".".6N) ;Declare variables N PTRMAF,DIC,X,Y,NODE,FOUND S HLDT1="" ;Determine entry number of associated entry in Message Admin file (773) S PTRMAF=0 S FOUND=0 F S PTRMAF=+$O(^HLMA("B",HLDT,PTRMAF)) Q:('PTRMAF) D Q:(FOUND) .;Compare message IDs .S NODE=$G(^HLMA(PTRMAF,0)) .S:($P(NODE,"^",2)=HLMID) FOUND=1 ;Entry not found Q:('PTRMAF) MTL ;Make entry S X=PTRMAF S DIC="^HL(772," S DIC(0)="L" S DIC("DR")="6///"_HLMID K DD,DO D FILE^DICN ;Entry not created - try again I (Y<0) G MTL ;Remember entry number S MTIEN=+Y ;Convert date/time to HL7 format S HLDT1=$$HLDATE^HLFNC(HLDT) Q CHNGMID(PTRMT,NEWID) ;Change message ID for entry in Message Text file ;Input : PTRMT - Pointer to entry in Message Text file (#772) ; NEWID - New message ID ;Output : 0 = Success ; -1^ErrorText = Error/Bad input ;Notes : Message ID of associated entry in Message Administration ; file (#773) will also be changed ; ;Check input S PTRMT=+$G(PTRMT) S NEWID=$G(NEWID) Q:('$D(^HL(772,PTRMT,0))) "-1^Did not pass valid pointer to Message Text file (#772)" Q:(NEWID="") "-1^Did not pass new value for message ID" ;Declare Variables N DIE,DA,DR ;Change message ID for entry in Message Text file S DIE="^HL(772," S DA=PTRMT S DR="6///"_NEWID D ^DIE ;Find associated entry in Message Admin file S DA=+$G(^HL(772,PTRMT,0)) ;No associated entry - done Q:('DA) 0 ;Change message ID for entry in Message Admin file S DIE="^HLMA(" S DR="2///"_NEWID D ^DIE ;Done Q 0 OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message ;Version 1.5 Interface Only Q:'$D(HLFS) ; I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"I") Q ; ;-- if message contained MSA find inbound message I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D . N HLDAI . S HLDAI=0 . F S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I") . I 'HLDAI K HLDAI ; D STUFF^HLTF0("O") ; N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN)) ; ;-- update status if MSA and found inbound message I $D(HLMSA),$D(HLDAI) D .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) .S HLAC=$P(HLMSA,HLFS,2) .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG)) Q ; IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message ;Version 1.5 Interface Only Q:'$D(HLFS) I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA) D ACK(HLMSA,"O",$G(HLDA)) Q ; N HLDAI S HLDA=0 I $D(HLNDAP),HLMID]"" D .F S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I") .I HLDA D ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT=+^HLMA(HLDT,0),HLDT1=$$HLDATE^HLFNC(HLDT) ..K ^HL(772,HLDA,"IN") .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D ..S HLDAI=0 ..F S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O") ..I 'HLDAI K HLDAI ; I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ ; D STUFF^HLTF0("I") N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) ; D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME) ; I '$D(HLERR),$D(HLMSA),$D(HLDAI) D .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4) .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG)) Q ; ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only ; To determine the correct message to link the ACK, HLIO is used. ; For an ack from DHCP (original message from remote system) then ; HLIO should be "I" so that the correct inbound message is ack-ed. For ; an inbound ack (original message outbound from DHCP) HLIO should be ; "O". This distinction must be made due to the possible duplicate ; message ids from a bi-direction interface. ; ; Input : MSA - MSA from ACK message. ; HLIO - Either "I" or "O" : See note above. ;Output : None ; N HLAC,HLMIDI ;-- set up required vars S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3) ;-- quit Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP)) ;-- find message to ack I '$G(HLDA) S HLDA=0 D . F S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO) ;-- quit if no message Q:'$D(^HL(772,+HLDA,0)) ;-- check for error I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4) I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR ;-- update status S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG)) Q HLTF0 HLTF0 ;AISC/SAW,JRP - File Data in Message Text File ;1/26/95 10:39 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**12**;Oct 13, 1995 STATUS(MTIEN,STATUS,ERR,ERRTEXT) ;Update Status of Entry in Message Text File ; ;This is a subroutine call with parameter passing. No output ;parameters are returned ; ;Required Input Parameters ; MTIEN = IEN of entry in Message Text file to be updated ; STATUS = IEN of new status (pointer to Message Status file) ;Optional Parameters ; ERR = IEN of error message (pointer to Error Message file) ; ERRTEXT = An error message of up to 200 characters ; ;Check for required parameters I '$G(MTIEN)!('$G(STATUS)) Q ;File new status info N %,%H,%I,DA,DIC,DIE,DR D NOW^%DTC S (DIC,DIE)="^HL(772,",DA=MTIEN S DR="20////"_STATUS_";21////"_$S(STATUS=1:"@",1:%)_$S($G(ERR):";23////"_ERR,1:"")_";22////"_$S('$D(ERRTEXT):"@",ERRTEXT']"":"@",1:$E(ERRTEXT,1,200)) L +^HL(772,DA) D ^DIE L -^HL(772,DA) Q STATS(MTIEN,HLCHAR,HLEVN) ;Enter Statistics for an Entry in Message ;Text File ; ;This is a subroutine call with parameter passing. No output ;parameters are returned ; ;Required Input Parameters ; MTIEN = The IEN from the Message Text file of the entry to be ; updated ; HLCHAR = The number of characters in the message ; HLEVN = The number of HL7 events in the message ; ;Check for required parameters I '$G(MTIEN)!('$D(HLCHAR))!('$D(HLEVN)) Q I '$D(^HL(772,MTIEN,0)) Q ;File statistical info L +^HL(772,MTIEN) S ^HL(772,MTIEN,"S")=HLCHAR_"^"_$G(HLEVN) L -^HL(772,MTIEN) Q STUFF(HLMT) ;Update Fields on Zero Node of the Message Text File for ;Version 1.5 Interface Only ; ;This is a subroutine call with parameter passing. No output ;parameters are returned ; ;Required Input Parameter ; HLMT = Message type, O for outgoing or I for incoming ; ;Check for required parameter Q:HLMT']"" ;File zero node data N DA,DIC,DIE,DR S (DIC,DIE)="^HL(772,",DA=HLDA S DR="4////"_HLMT_$S('$G(HLDAP):"",1:";2////"_HLDAP)_$S('$G(HLXMZ):"",1:";5////"_HLXMZ)_$S('$G(HLDAI):"",1:";7////"_HLDAI)_";Q"_$S('$P($G(HLNDAP0),U,12):"",1:";3////"_$P($G(HLNDAP0),U,12)) L +^HL(772,DA) D ^DIE L -^HL(772,DA) Q UPDATE(MTIEN,MTIENP,HLMT,EID,CLIENT,SERVER,PRIORITY,REPLYTO,LOGLINK,HLP) ; ;Update Fields on Zero Node of the Message Text File for Version 1.6 ; ;This is a subroutine call with parameter passing. No output ;parameters are returned ; ;Required Input Parameters ; MTIEN = The IEN from the Message Text file of the entry to be ; updated ; MTIENP = The IEN from the Message Text file of the parent entry ; to which this entry (MTIEN) should be linked ; HLMT = The type of message, I for Incoming or O for Outgoing ;NOTE: Either Client or Server must be passed. Both parameters may ; be passed ; CLIENT = The IEN of the client (subscriber) application from ; the Application Parameter file ; SERVER = The IEN of the server (event driver) application from ; the Application Parameter file ;Optional parameters ; EID = The IEN from the Protocol file of the event related to this ; Message Text file entry ;PRIORITY = I for immediate or D for deferred ; REPLYTO = The IEN from the Message Text file of the message being ; acknowledged. (Only used for acknowledgement messages.) ; LOGLINK = The IEN of the logical link from the Logical Link file ; HLP("SECURITY") = A 1 to 40 character string ; HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string ; HLP("MSGTYPE") = M for Single Message or B for Batch of Messages ; ;Check for required parameters I '$G(MTIEN)!('$G(MTIENP))!($G(HLMT)']"") Q ;File zero node data N DA,DIC,DIE,DR S (DIC,DIE)="^HL(772,",DA=MTIEN S DR="4////"_HLMT_$S($G(SERVER):";2////"_SERVER,1:"")_$S($G(CLIENT):";3////"_CLIENT,1:"")_$S($G(REPLYTO):";7////"_REPLYTO,1:"")_";8////"_MTIENP_$S($G(PRIORITY)]"":";9////"_PRIORITY,1:"") S DR=DR_$S($G(EID):";10////"_EID,1:"")_$S($G(LOGLINK):";11////"_LOGLINK,1:"")_$S($G(HLP("SECURITY"))]"":";12///"_HLP("SECURITY"),1:"")_$S($G(HLP("MSGTYPE"))]"":";14///"_HLP("MSGTYPE"),1:"") I $G(HLP("CONTPTR"))]"" S DR(1,772,1)="13///"_HLP("CONTPTR") L +^HL(772,DA) D ^DIE L -^HL(772,DA) Q HLTF1 HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;02/24/97 13:56 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25**;Oct 13, 1995 MERGE15(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into ;Message Text File ; ;This is a routine call with parameter passing. There are no output ;parameters returned by this call. ; ;** Merges incoming data for v1.5 applications only ** ; ;Required input parameters ; MTIEN = The IEN from the Message Text file of the entry to be ; updated ; ARAYTYPE = Array type, G for global or L for local ; SUB1 = The first level subscript of the array. Must be ; either HLS or HLA ;Optional input parameter ; SUB2 = A second subscript associated with the array ; ;Check for required parameters I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MRGE15X ; N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0 ; ;Merge data from a global array with two subscript I ARAYTYPE="G",$G(SUB2)'="" D . S X="",I=0 . F S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 ; ;Merge data from a global array with one subscripts I ARAYTYPE="G",$G(SUB2)="" D . S X="",I=0 . F S X=$O(^TMP(SUB1,$J,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 ; ;Merge data from a local array with one subscript I ARAYTYPE="L" D . S X="",I=0 . F S X=$O(HLA(SUB1,X)) Q:'X S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1 ; ;-- update 0 node for message text S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" ; ;File message statistics D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) ; MRGE15X ;-- exit merge Q ; MERGE(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into ;Message Text File ; ;This is a routine call with parameter passing. There are no output ;parameters returned by this call. ; ;Required input parameters ; MTIEN = The IEN from the Message Text file of the entry to be ; updated ; ARAYTYPE = Array type, G for global or L for local ; SUB1 = The first level subscript of the array. Must be ; either HLS or HLA ;Optional input parameter ; SUB2 = A second subscript associated with the array ; ;Check for required parameters I "GL"'[$G(ARAYTYPE)!($G(SUB1)']"")!('$G(MTIEN)) G MERGEX ; N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0 ; ;Merge data from a global array with two subscript I ARAYTYPE="G",$G(SUB2)'="" D . S X="",I=0 . F S X=$O(^TMP(SUB1,$J,SUB2,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,SUB2,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,SUB2,X)) D .. I X2=11 S X3="" F S X3=$O(^TMP(SUB1,$J,SUB2,X,X3)) Q:'X3 D ... S I=I+1,X1=$G(^TMP(SUB1,$J,SUB2,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q ; ;Merge data from a global array with one subscripts I ARAYTYPE="G",$G(SUB2)="" D . S X="",I=0 . F S X=$O(^TMP(SUB1,$J,X)) Q:'X S I=I+1,X1=^TMP(SUB1,$J,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(^TMP(SUB1,$J,X)) D .. I X2=11 S X3="" F S X3=$O(^TMP(SUB1,$J,X,X3)) Q:'X3 D ... S I=I+1,X1=$G(^TMP(SUB1,$J,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q ; ;Merge data from a local array with one subscript I ARAYTYPE="L" D . S X="",I=0 . F S X=$O(HLA(SUB1,X)) Q:'X S I=I+1,X1=HLA(SUB1,X),HLCHAR=HLCHAR+$L(X1) S:$E(X1,1,3)="MSH" HLFS=$E(X1,4),$P(X1,HLFS,8)="",HLEVN=HLEVN+1 S ^HL(772,MTIEN,"IN",I,0)=X1,X2=$D(HLA(SUB1,X)) D .. I X2=11 S X3="" F S X3=$O(HLA(SUB1,X,X3)) Q:'X3 D ... S I=I+1,X1=$G(HLA(SUB1,X,X3)),HLCHAR=HLCHAR+$L(X1),^HL(772,MTIEN,"IN",I,0)=X1 .. S I=I+1,^HL(772,MTIEN,"IN",I,0)="" Q ; ;-- write batch trailer seg (BTS) if batch message type S:HLEVN=0 HLEVN=1 I $P(^HL(772,$P(^HL(772,MTIEN,0),U,8),0),U,14)="B" S I=I+1,^HL(772,MTIEN,"IN",I,0)="BTS^"_HLEVN,I=I+1,^HL(772,MTIEN,"IN",I,0)="" ; ;-- update 0 node for message text S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" ; ;File message statistics D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) ; MERGEX ;-- exit merge Q ; MRGINT(MTOUT,MTIN,HDR) ;Merge Internal to Internal Message from the ; Outbound message in 772 (MTOUT) to an Inbound entry (MTIN). The process ; will involve Moving the Header and Text into 772. ; ;Required input parameters ; MTOUT= Internal entry number of the Outbound message ; MTIN = Internal entry number of the Inbound message ; HDR = Name of the array that contains HL7 Header segment ; format: HLHDR - Used with indirection to build message in out ; queue ; This routine will first take the header information in the array ; specified by HDR and merge into the Message Text field of file 870. ; Then it will move the message contained in 772 (MTIEN) into 870. ; ;Check for required parameters I '$G(MTOUT)!('$G(MTIN))!(HDR="") Q ; ;-- initilize N I,X S I=0 ; ;-- move header into 772 from HDR array S X="" F S X=$O(@HDR@(X)) Q:'X D . S I=I+1,^HL(772,MTIN,"IN",I,0)=@HDR@(X) S I=I+1,^HL(772,MTIN,"IN",I,0)="" ; ;Move data from Message Text (MTOUT) file TO Message Text 772 (MTIN) S X=0 F S X=$O(^HL(772,MTOUT,"IN",X)) Q:X="" S I=I+1 D . S ^HL(772,MTIN,"IN",I,0)=$G(^HL(772,MTOUT,"IN",X,0)) ; ;-- update 0 node of message and format arrays S ^HL(772,MTIN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" ; Q HLTF2 HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;02/24/97 13:56 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**25**;Oct 13, 1995 MERGEIN(LLD0,LLD1,MTIEN,HDR,MSA) ;Merge Data From Communication Server ;Module Logical Link File into Message Text File ; ;This is a subroutine call with parameter passing. The output ;parameters HDR (and optionally) MSA are returned by this call. ; ;Required input parameters ; LLD0 = Internal entry number where message is stored in Logical Link ; file or XM if message is stored in MailMan ; LLD1 = Internal entry number of IN QUEUE multiple entry in Logical ; Link file (Only required for messages stored in Logical ; Link file) ; MTIEN = Internal entry number where message is to be copied to in ; Message Text file ; HDR = The variable in which the message header segment will ; be returned ; MSA = The variable in which the message acknowledgement segment ; will be returned, if one exists for this message ; ;Check for required parameters I $G(LLD0)']""!('$G(MTIEN)) Q I LLD0'="XM",'$G(LLD1) Q N FLG,HLCHAR,HLEVN,HLFS,I,X,X1,HLDONE S (FLG,HLCHAR,HLEVN,X)=0 ; ;Move data from Logical Link file to Message Text file I LLD0'="XM" D .S I=0 F S X=$O(^HLCS(870,LLD0,1,LLD1,1,X)) Q:X'>0 S X1=$G(^(X,0)) S:"FHS,BHS,MSH"[$E(X1,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(X1) D ..;If header segment, process it and set HDR equal to it ..I X1'="","FHS,BHS,MSH"[$E(X1,1,3) D ...I '$D(HDR) S HDR=X1,HLFS=$E(X1,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2) ...S $P(X1,HLFS,8)="" ...S:$E(X1,1,3)="MSH" HLEVN=HLEVN+1 ..;If acknowledgement segment, set MSA equal to it ..I $E(X1,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=X1 ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=X1 ; ;Move data from MailMan Message file to Message Text file I LLD0="XM" D .S I=0 F X XMREC Q:XMER<0 S:"FHS,BHS,MSH"[$E(XMRG,1,3) FLG=1 I FLG S HLCHAR=HLCHAR+$L(XMRG) D Q:XMER<0 ..;If header segment, process it and set HDR equal to it ..I XMRG'="","FHS,BHS,MSH"[$E(XMRG,1,3) D ...I '$D(HDR) S HDR=XMRG,HLFS=$E(XMRG,4) I $E(HDR,1,3)="BHS" S MSA="MSA"_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),1)_HLFS_$P(HDR,HLFS,12)_HLFS_$P($P(HDR,HLFS,10),$E(HDR,5),2) ...S $P(XMRG,HLFS,8)="" ...S:$E(XMRG,1,3)="MSH" HLEVN=HLEVN+1 ..;If acknowledgement segment, set MSA equal to it ..I $E(XMRG,1,3)="MSA",'$D(MSA),$E($G(HDR),1,3)="MSH" S MSA=XMRG ..S I=I+1,^HL(772,MTIEN,"IN",I,0)=XMRG S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" ;Update statistics in Message Text file for this entry D STATS^HLTF0(MTIEN,HLCHAR,HLEVN) Q MERGEOUT(MTIEN,LLD0,LLD1,HDR) ;Merge Text in Message Text File into ;Communication Server Module Logical Link File ; ;This is a routine call with parameter passing. There are no output ;parameters returned by this call. ; ;Required input parameters ; MTIEN = Internal entry number where message is stored in Message ; Text file ; LLD0 = Internal entry number where message is to be copied to in ; Logical Link file ; LLD1 = Internal entry number of IN QUEUE multiple entry in Logical ; Link file ; HDR = Name of the array that contains HL7 Header segment ; format: HLHDR - Used with indirection to build message in out ; queue ; This routine will first take the header information in the array ; specified by HDR and merge into the Message Text field of file 870. ; Then it will move the message contained in 772 (MTIEN) into 870. ; ;Check for required parameters I '$G(MTIEN)!('$G(LLD0))!('$G(LLD1))!(HDR="") Q ; ;-- initilize N I,X S I=0 ; ;-- move header into 870 from HDR array S X="" F S X=$O(@HDR@(X)) Q:'X D . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=@HDR@(X) S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)="" ; ;Move data from Message Text file to Logical Link file S X=0 F S X=$O(^HL(772,MTIEN,"IN",X)) Q:X="" D . S I=I+1,^HLCS(870,LLD0,2,LLD1,1,I,0)=$G(^HL(772,MTIEN,"IN",X,0)) ; ;-- update 0 node of message and format arrays S ^HLCS(870,LLD0,2,LLD1,1,0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^" ; Q HLTP0 HLTP0 ;AISC/SAW,JRP - Transaction Processor Module (Cont'd) ;2/22/95 11:13 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**25**;Oct 13, 1995 PROCESS(HLMTIEN,HLLD0,HLLD1,HLRESLT) ;Process an incoming message ; ;INPUT : HLMTIEN - One of two values ; 1) Pointer to entry in MESSAGE TEXT file (#772) ; that requires processing (internal message) ; 2) Pointer to entry in MESSAGE TEXT file (#772) ; that external message will be placed into ; HLLD0 - One of three values ; 1) Pointer to LOGICAL LINK file (#870) that ; contains the message ; 2) 'XM' if the message was received through MailMan ; 3) 'DHCP' if the message is from an internal ; application ; HLLD1 - Pointer to entry in IN QUEUE multiple (#19) of ; the LOGICAL LINK file (#870) ; - Only used for messages received through the ; LOGICAL LINK file (#870) ; HLRESLT - Variable to return error text in (pass by reference) ;OUTPUT : On successful completion, HLRESLT will be set to NULL ; On error, HLRESLT will be set to ErrorCode^ErrorText ; ;Check parameters S HLRESLT="7^"_$G(^HL(771.7,7,0))_" at PROCESS^HLTP0 entry point" Q:('$G(HLMTIEN)) S HLLD0=$G(HLLD0) Q:(HLLD0="") Q:((HLLD0'="XM")&(HLLD0'="DHCP")&('$D(^HLCS(870,+HLLD0,0)))) S HLLD1=+$G(HLLD1) Q:((+HLLD0)&('$D(^HLCS(870,+HLLD0,1,HLLD1,0)))) S HLRESLT="" N HLEXROU,CHARCNT,EVNTCNT,HDRFND,FLDSPRTR,LINE,TEXT,SEGNAME,HDRTYPE N HLENROU,HLNEXT,HLNODE,HLPROU,HLQUIT,HLMTIENS ; ;Prepare to process internal message I (HLLD0="DHCP") D Q:(HLRESLT'="") .;Determine statistics for message .S LINE=0 .S TEXT="" .S HDRFND=0 .S CHARCNT=0 .S EVNTCNT=0 .S HLMSA="" .S HLHDR="" .S SEGNAME="" .S HDRTYPE="" .;Order through message text .F S LINE=+$O(^HL(772,HLMTIEN,"IN",LINE)) Q:('LINE) D ..S TEXT=$G(^HL(772,HLMTIEN,"IN",LINE,0)) ..;Determine if header found yet (skip lines until it is) ..S:"FHS,BHS,MSH"[$E(TEXT,1,3) HDRFND=1 ..Q:('HDRFND) ..;Increment character count ..S CHARCNT=CHARCNT+$L(TEXT) ..;Get segment name ..S SEGNAME=$E(TEXT,1,3) ..;If header segment, process it and set HLHDR equal to it ..I "FHS,BHS,MSH"[SEGNAME D ...I (HLHDR="") S HLHDR=TEXT,FLDSPRTR=$E(TEXT,4),HDRTYPE=SEGNAME ...S $P(TEXT,FLDSPRTR,8)="" ...S:(SEGNAME="MSH") EVNTCNT=EVNTCNT+1 ..;If acknowledgement segment, set HLMSA equal to it ..S:((SEGNAME="MSA")&(HLMSA="")&(HDRTYPE="MSH")) HLMSA=TEXT .;Update statistics .D STATS^HLTF0(HLMTIEN,CHARCNT,EVNTCNT) .S:(HLHDR="") HLRESLT="12^"_$G(^HL(771.7,12,0)) ; ;Prepare to process external message I (HLLD0'="DHCP") D Q:(HLRESLT'="") .;Store message in Message Text file .D MERGEIN^HLTF2(HLLD0,$S($G(HLLD1):HLLD1,1:""),HLMTIEN,.HLHDR,.HLMSA) .S:('$D(HLHDR)) HLRESLT="12^"_$G(^HL(771.7,12,0)) ; ;Process message D ^HLTP01 ; ;Update status of subscriber message I (HLMTIENS) D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S($D(HLERR):HLERR,HLRESLT:$P(HLRESLT,"^",2),1:"")) ; ;Execute exit action of client protocol X:$G(HLEXROU)]"" HLEXROU Q HLTP01 HLTP01 ;AISC/SAW-Transaction Processor Module (Cont'd) ;2/22/95 11:22 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2,25**;Oct 13, 1995 ; ;Validate message header D CHK^HLTPCK1(HLHDR,.HL,$S($G(HLMSA)'="":$P(HLMSA,$E(HLHDR,4),2,4),1:"")) ; ;Change stored message ID to match that of the incoming message S HL("TMP")=$$CHNGMID^HLTF(HLMTIEN,HL("MID")) ; ;Remember new message ID if it was changed I ('HL("TMP")) S HLMID=HL("MID") ; ;Update zero node in Message Text file of incoming message D UPDATE^HLTF0(HLMTIEN,$S($D(HL("MTIENS")):HL("MTIENS"),1:HLMTIEN),"I",$G(HL("EID")),"",$G(HL("SAP")),"I") ; ;Update status of incoming message D STATUS^HLTF0(HLMTIEN,$S($G(HL):4,1:9),$S($G(HL):+HL,1:""),$S($G(HL):$P(HL,"^",2),1:"")) ; ;Update Logical Link file statistics for message received through MailMan I HLLD0="XM",$G(HL("LL"))]"" D . S X=$$ENQUEUE^HLCSQUE(HL("LL"),"IN") . D MONITOR^HLCSDR2("P",2,HL("LL"),$P(X,U,2),"IN") ; ;Quit if this is acknowledgment to acknowledgement message I $G(HL("ACK")) D G EXIT .;Update status of original acknowledgment message to successfully .; completed if no error occurred .I '$G(HL) D STATUS^HLTF0(HL("MTIENS"),3) ; ;Create message ID and Message Text IEN for subscriber entry in Message ; Text file - carry over message ID of original message S HLMIDS=HLMID D CREATE^HLTF(.HLMIDS,.HLMTIENS,.HLDTS,.HLDT1S) K HLDTS,HLDT1S,HLMIDS ; ;Update zero node in Message Text file of subscriber entry D UPDATE^HLTF0(HLMTIENS,HLMTIEN,"I",$G(HL("EIDS")),$G(HL("RAP")),"","I") ; ;Create and send acknowledgment message if required I $G(HLMSA)="" D .I '$D(HL("ACAT")),'$D(HL("APAT")),'HL Q .I $G(HL("ACAT"))="NE" Q .I $G(HL("ACAT"))="ER",'HL Q .I $G(HL("ACAT"))="SU",HL Q .S HLA("HLA",1)="MSA"_HL("FS")_$S(HL:$S(HL("VER")=2.1:"AR",1:"CR"),1:"CA")_HL("FS")_HL("MID")_HL("FS")_$P(HL,"^",2) .;I $D(HLA("HLA")) S HLP("MSACK")=1 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLT,"",.HLP) .S HLP("MSACK")=1 .D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLT,"",.HLP) ; ;Quit processing if error with header I HL'="" S HLRESLT=HL G EXIT ; ;Set special HL variables S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" ; ;Check if message is an acknowledgement I ($G(HLMSA)'="") D G EXIT .;Update status of original subscriber message .D STATUS^HLTF0(HL("MTIENS"),$S("AA,CA"[$P(HLMSA,HL("FS"),2):3,1:7),$S("AA,CA"[$P(HLMSA,HL("FS"),2):"",1:$P(HLMSA,HL("FS"),3))) .D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL) ; ;Get entry action, exit action and processing routine K HLHDR,HLLD0,HLLD1,HLMSA I $G(HL("EIDS"))="",$G(HLEIDS)]"" S HL("EIDS")=HLEIDS ;**CIRN** D EVENT^HLUTIL1(HL("EIDS"),"15,20,771",.HLN) S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)) S HLPROU=$G(HLN(771)) I HLPROU']"" S HLRESLT="10^"_$G(^HL(771.7,10,0)) G EXIT ; ;Execute entry action of client protocol X:HLENROU]"" HLENROU K HLENROU ; ;Execute processing routine X HLPROU S HLRESLT=0 S:($D(HLERR)) HLRESLT="9^"_$G(^HL(771.7,9,0)) EXIT K HL,HLHDR,HLMSA Q HLTPCK1 HLTPCK1 ;AISC/SAW-Message Header Validation Routine for HL7 ;06/07/96 14:34 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**8**;Oct 13, 1995 CHK(HDR,ARY,MSA) ;Validate Data in Header Segment (MSH, BHS or FHS) of ;an HL7 Message ; ;This entry point is a subroutine call with parameter passing that ;will return an array (ARY()) consisting of values extracted from ;the message header segment subscripted by the mnemonics for each of ;the message header fields and components ;If an error is encountered during validation, the array parameter ;(ARY) will be set equal to two pieces, error #^error text and the ;rest of the array will not be returned ; ;Required input parameters ; HDR = Message header segment ;Note: The ARY parameter must be passed by reference ; ARY = The array in which the message header values will be ; returned ;Optional input parameter ; MSA = A variable which contains the message acknowledgement values: ; acknowledgement code^message control ID^text message ; ;Check for required parameters N ERR S ERR="" I $G(HDR)']"" S ERR="7^"_$G(^HL(771.7,7,0))_" at CHK^HLTPCK1 entry point" G EXIT N ECH,HLN,FS,X,X1,X2 S ARY="",ARY("Q")="""""" ; ;Validate field separator and encoding characters S (ARY("FS"),FS)=$E(HDR,4) I FS']"" S ERR="Field Separator Missing" G EXIT I FS?.C S ERR="Invalid Field Separator" G EXIT S (ARY("ECH"),ECH)=$P(HDR,FS,2) I ECH']"" S ERR="Encoding Characters Missing" G EXIT I ECH?.C S ERR="Invalid Encoding Characters" G EXIT ; ;Validate Message Header Type I "FHS,BHS,MSH"'[$E(HDR,1,3) S ERR="Invalid Message Header Segment" G EXIT ; ;Extract data from message header segment I $E(HDR,1,3)="BHS"!($E(HDR,1,3)="FHS") D .S ARY("DTM")=$P(HDR,FS,7),ARY("MID")=$P(HDR,FS,11),X=$P(HDR,FS,9),ARY("PID")=$P(X,$E(ECH),2),ARY("MTN")=$P($P(X,$E(ECH),3),$E(ECH,2)),ARY("ETN")=$P($P(X,$E(ECH),3),$E(ECH,2),2),ARY("VER")=$P(X,$E(ECH),4) .;S:$P(HDR,FS,10)]"" MSA=$P(HDR,FS,10),$P(MSA,$E(ECH),2)=$P(HDR,FS,12) .S:$P(HDR,FS,10)]"" MSA=$P($P(HDR,FS,10),$E(ECH),1),$P(MSA,FS,2)=$P(HDR,FS,12),$P(MSA,FS,3)=$P($P(HDR,FS,10),$E(ECH),2) I $E(HDR,1,3)="MSH" D .S ARY("DTM")=$P(HDR,FS,7),ARY("MID")=$P(HDR,FS,10),ARY("PID")=$P(HDR,FS,11),ARY("MTN")=$P($P(HDR,FS,9),$E(ECH)),ARY("ETN")=$P($P(HDR,FS,9),$E(ECH),2),ARY("VER")=$P(HDR,FS,12) .S:$P(HDR,FS,15)]"" ARY("ACAT")=$P(HDR,FS,15) S:$P(HDR,FS,16)]"" ARY("APAT")=$P(HDR,FS,16) S:$P(HDR,FS,17)]"" ARY("CC")=$P(HDR,FS,17) K:$G(MSA)']"" MSA ; ;Invoke continuation routine to perform remaining validation checks D ^HLTPCK1A ; EXIT I ERR]"" S ARY=$S('ERR:"13^"_ERR,1:ERR) Q HLTPCK1A HLTPCK1A ;SAW/AISC-Message Header Validation Routine for HL7 (Con't) ;2/25/97 17:52 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2,25**;Oct 13, 1995 S ERR="" ;Validate message type I (ARY("MTN")="") S:(ERR="") ERR="Invalid Message Type" S ARY("MTP")=0 S:(ARY("MTN")'="") ARY("MTP")=+$O(^HL(771.2,"B",ARY("MTN"),0)) I ('ARY("MTP")) S:(ERR="") ERR="Invalid Message Type" ; ;Determine if message is an acknowledgement type I (("ACK,ADR,MCF,MFK,MFR,ORF,ORR,RRA,RRD,RRE,RRG"[ARY("MTN"))&($G(MSA)="")) S:(ERR="") ERR="MSA Segment Missing" ; ;Validate accept ack type and application ack type I ($G(ARY("ACAT"))'="") I ("AL,NE,ER,SU"'[ARY("ACAT")) S:(ERR="") ERR="Invalid accept ack type" I ($G(ARY("APAT"))'="") I ("AL,NE,ER,SU"'[ARY("APAT")) S:(ERR="") ERR="Invalid application ack type" ; ;Validate country code ;I ($G(ARY("CC"))'="") I ('$O(^HL(779.004,"B",ARY("CC"),0))) S:(ERR="") ERR="Invalid country code" ; ;Validate event type ;-- if no event type the use message id to resolve event type I ARY("ETN")="",$G(MSA)'="" D . N HLZMID,HLZEP,HLZ770 . S HLZMID=$O(^HL(772,"C",+$P(MSA,FS,2),0)) . I HLZMID D .. I '$G(^HL(772,HLZMID,0)) S:(ERR="") ERR="Original Outgoing Message not found" Q .. S HLZEP=$P($G(^HL(772,HLZMID,0)),U,10) .. I HLZEP'>0 S:(ERR="") ERR="Event Protocol pointer (field #772,10) missing" Q .. S HLZ770=$G(^ORD(101,HLZEP,770)) .. S ARY("ETN")=$P($G(^HL(779.001,+$P(HLZ770,U,4),0)),U) . K HLZMID,HLZEP,HLZ770 ; I (ARY("ETN")="") S:(ERR="") ERR="Missing Event Type" S ARY("ETP")=0 S:(ARY("ETN")'="") ARY("ETP")=+$O(^HL(779.001,"B",ARY("ETN"),0)) I ('ARY("ETP")) S:(ERR="") ERR="Invalid Event Type" ; ;Validate receiving application S ARY("RAN")=$P(HDR,FS,5) I (ARY("RAN")="") S:(ERR="") ERR="Invalid Receiving Application" S ARY("RAP")=0 S:(ARY("RAN")'="") ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0)) I (('ARY("RAP"))&(ARY("RAN")'="")) D .S X=$$UPPER^HLFNC(ARY("RAN")) .S ARY("RAP")=+$O(^HL(771,"B",ARY("RAN"),0)) I ('ARY("RAP")) S:(ERR="") ERR="Invalid Receiving Application" S X2=$G(^HL(771,ARY("RAP"),0)) I (X2="") S:(ERR="") ERR="Invalid Receiving Application" I ($P(X2,"^",2)'="a") S:(ERR="") ERR="Receiving Application is Inactive" ; ;Validate sending application S ARY("SAN")=$P(HDR,FS,3) I (ARY("SAN")="") S:(ERR="") ERR="Invalid Sending Application" S ARY("SAP")=0 S:(ARY("SAN")'="") ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0)) I (('ARY("SAP"))&(ARY("SAN")'="")) D .S X=$$UPPER^HLFNC(ARY("SAN")) .S ARY("SAP")=+$O(^HL(771,"B",ARY("SAN"),0)) I ('ARY("SAP")) S:(ERR="") ERR="Invalid Sending Application" ; ;Get receiving application data from Protocol file I (ARY("SAP")) D .I $D(MSA) D Q ..;Message is an acknowledgement - deliver to Server Protocol that ..; message came from ..S ARY("MTIENS")=0 ..F S ARY("MTIENS")=+$O(^HL(772,"AH",ARY("SAP"),$P(MSA,FS,2),ARY("MTIENS"))) Q:'ARY("MTIENS")!($P($G(^HL(772,+ARY("MTIENS"),0)),U,4)="O") ..S X=$G(^HL(772,+ARY("MTIENS"),0)) ..S ARY("EIDS")=$P(X,"^",10) ..I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment" Q ..S ARY("MTIEN")=+$P(X,"^",8) ..S ARY("ACK")=$P(X,"^",7) ..S X=$G(^HL(772,+$P(X,"^",8),0)) ..S ARY("EID")=$P(X,"^",10) ..I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q ..D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) .I ((ARY("MTP"))&(ARY("ETP"))) D ..;Find Server Protocol - based on message and event type ..S ARY("EID")=+$O(^ORD(101,"AHL1",ARY("SAP"),ARY("MTP"),ARY("ETP"),0)) ..I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q ..;Find Client Protocol - in ITEM multiple of Server Protocol ..S ARY("EIDS")=0 ..S X=0 ..S X1=0 ..F S ARY("EIDS")=+$O(^ORD(101,ARY("EID"),10,"B",ARY("EIDS"))) Q:('ARY("EIDS")) D Q:(X1) ...S X=$G(^ORD(101,ARY("EIDS"),770)) ...S:(($P(X,"^",2)=ARY("RAP"))&($P(X,"^",3)=ARY("MTP"))&($P(X,"^",4)=ARY("ETP"))) X1=1 ..I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Receiving Application for this Event" Q ..D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN) ; ;Validate receiving facility ;S ARY("RAF")=$P(HDR,FS,6) ;S X=$G(^HL(771,ARY("RAP"),0)) ;S:(ARY("RAF")'=$P(X,"^",3)) ARY("RAF")=$$UPPER^HLFNC(ARY("RAF")) ;I ((ARY("RAF")'=$P(X,"^",3))&($P($G(HLN(773)),"^",2))) S:(ERR="") ERR="Invalid Receiving Facility" ; ;Validate date/time of message ;I (('ARY("DTM"))&($P($G(HLN(773)),"^",4))) S:(ERR="") ERR="Date/Time of Message Missing" ; ;Validate sending facility ;S ARY("SAF")=$P(HDR,FS,4) ;S X=$P($G(^HL(771,ARY("SAP"),0)),"^",3) ;S:(ARY("SAF")'=X) ARY("SAF")=$$UPPER^HLFNC(ARY("SAF")) ;I ((ARY("SAF")'=X)&($P($G(HLN(773)),"^"))) S:(ERR="") ERR="Invalid Sending Facility" ; ;Get logical link pointer S ARY("LL")=$P($G(HLN(770)),"^",7) ; ;Validate version number I (ARY("VER")="") S:(ERR="") ERR="Missing HL7 Version" S X=0 S:(ARY("VER")'="") X=+$O(^HL(771.5,"B",ARY("VER"),0)) I ('X) S:(ERR="") ERR="Invalid HL7 Version" I (X'=$P($G(HLN(770)),"^",10)) S:(ERR="") ERR="Invalid HL7 Version for Receiving Application" ; ;Validate processing ID I ("DTP"'[ARY("PID")) S:(ERR="") ERR="Inappropriate HL7 Processing ID" ; ;Validate security field - access code and electronic signature I ($P($G(HLN(773)),"^",3)) D .S X=$P($P(HDR,FS,8),$E(ECH)) .S X=$$UPPER^HLFNC(X) .D ^XUSHSH .I ((X="")&('$D(MSA))) S:(ERR="") ERR="Invalid access code" Q .S ARY("DUZ")=0 .S:(X'="") ARY("DUZ")=+$O(^VA(200,"A",X,0)) .I ('ARY("DUZ")) S:(ERR="") ERR="Invalid access code" Q .I (($P($G(^VA(200,ARY("DUZ"),.1)),"^")="")&('$D(MSA))) S ARY("DUZ")=0 S:(ERR="") ERR="Invalid access code" Q .S X=$P($P(HDR,FS,8),$E(ECH),3) I (X'="") D ..S X1=$G(^VA(200,ARY("DUZ"),20)) ..I (X1="") S:(ERR="") ERR="No Signature Code on File" Q ..S X=$$UPPER^HLFNC(X) ..D HASH^XUSHSHP ..I ((X'=$P(X1,"^",4))!($P(X1,"^",2)="")) S:(ERR="") ERR="Invalid Electronic Signature Code" Q ..S ARY("ESIG")=$P(X1,"^",2) Q HLUOPT1 HLUOPT1 ;AISC/SAW-Main Menu for HL7 Module (Con't) ;12/06/96 11:08 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**10,13,21**;Oct 13, 1995 PURGE ;Purge data of the HL7 message text in file #772 and #773 ;If you schedule this option on a recurring basis the purge will ;retain the last seven days. This can be changed by entering a ;number in the TASK PARAMETERS field of the OPTION SCHEDULING FILE ;TASK PARAMETERS field may contain THREE pieces of data separated by ';' ;a negative number in the first piece represents the retaining days ;of 'successfully transmitted' messages ;a negative number in the second piece is days to retain ;'awaiting acknowledgment' messages ;the 'awaiting acknowledgment' messages will not be purged if the ;second piece data is missing or is not submitted ;a negative number in the 3rd piece is a VAPORIZATION DATE for ;all messages N HLPDT2,HLPFLG,HLMADT,HLPDTX2,HLALL,HLTMALL,HLOOP2,HLINK,HLIEN,HLIEN2 I $D(ZTQUEUED) G DQ S X1=DT,X2=0 D C^%DTC S DIR(0)="D^:"_X_":EX" S DIR("A")="Enter the cutoff date for all messages REGARDLESS OF STATUS" S DIR("?")="Purges ALL messages prior to this date" S DIR("B")="T-90" D ^DIR G Q:$D(DIRUT) S HLALL=Y_.9 K DIR S X1=DT,X2=0 D C^%DTC S DIR(0)="D^:"_X_":EX",DIR("A")="Enter last INCLUSIVE date for status SUCCESSFULLY TRANSMITTED",DIR("?")="The suggested cutoff date is seven days prior to today" S DIR("B")="T-7" D ^DIR G Q:$D(DIRUT) S HLPDT=Y_.9 K DIR S DIR(0)="YA",DIR("B")="NO",DIR("A")="Purge entries with an ERROR STATUS? ",DIR("?",1)="Enter 'Yes' to purge entries whose status is 'error in transmission'." S DIR("?",2)="If you have reviewed/resolved the cause of the problem of those entries",DIR("?")="with an 'error' status answer 'Yes'. Otherwise answer 'No'." W ! D ^DIR G Q:$D(DIRUT) K DIR S HLPERR=Y S X1=DT,X2=0 D C^%DTC S DIR(0)="D^:"_X_":EX" S DIR("A")="Cutoff date for AWAITING ACKNOWLEDGEMENT status" S DIR("B")="T-30" S DIR("?",1)="Enter last INCUSIVE date to purge HL7 messages with 'Awaiting" S DIR("?")="Acknowledgment' status" W ! D ^DIR G Q:$D(DIRUT) K DIR S HLPDT2=Y_.9 S DIR(0)="YA",DIR("B")="YES",DIR("A")="Would you like to queue this purge? ",DIR("?")="If run in the foreground, you will see dots and a total count." W ! D ^DIR G Q:$D(DIRUT) K DIR S HLNOQ='Y I HLNOQ G DQ S ZTRTN="DQ^HLUOPT1",ZTSAVE("HLPERR")="",ZTSAVE("HLPDT")="",ZTSAVE("HLPDT2")="",ZTSAVE("HLALL")="" S ZTIO="",ZTDTH=DT,ZTDESC="Purge HL7 message text on or before "_$E(HLPDT,4,5)_"/"_$E(HLPDT,6,7)_"/"_$E(HLPDT,2,3) D ^%ZTLOAD W !!,"Purge queued to run in background." G Q DQ ;entry point for running purge of HL7 message text I $D(ZTQPARAM) D .S X2=+ZTQPARAM I X2'<0 S X2=0 .S HLPDTX2=+$P(ZTQPARAM,";",2) .S HLTMALL=+$P(ZTQPARAM,";",3) S:'$D(HLPERR) HLPERR=0 I '$D(HLPDT) S X1=DT,X2=$S($G(X2):X2,1:-7) D C^%DTC S HLPDT=X_.9 I '$D(HLPDT2),+$G(HLPDTX2)<0 S X1=DT,X2=+$G(HLPDTX2) D C^%DTC S HLPDT2=X_.9 I $G(HLTMALL)<0 S X1=DT,X2=HLTMALL D C^%DTC S HLALL=X_.9 I '$D(HLPDT2),+$G(HLPDTX2)'<0 S HLPDT2=HLPDT,HLPFLG=1 I '$D(HLALL) S X1=DT,X2=-90 D C^%DTC S HLALL=X_.9 S HLDELCNT=0 F HLOOP2=1:1:2 D .S HLPTR=0 F Q:($$S^%ZTLOAD) S HLPTR=$O(^HL(772,"B",HLPTR)) Q:HLPTR'>0 S HLIEN=0 F S HLIEN=$O(^HL(772,"B",HLPTR,HLIEN)) Q:'HLIEN D ..S HLMADT=+$G(^HLMA(HLPTR,0)) ..Q:(HLMADT>HLPDT)&(HLMADT>HLPDT2) ..I $G(HLALL),HLMADTHLPDT Q ..I (HLY=2),HLMADT>HLPDT2 Q ..I 'HLPERR,HLY>3,HLY<8 Q ..I HLY=1!(HLY>7) Q ..I $O(^HL(772,"AI",HLIEN,HLIEN)) Q ..D KILL ;Check for orphans in HLMA S HLMADT=0 F S HLMADT=$O(^HLMA("B",HLMADT)) Q:HLMADT<1 D .Q:HLMADT>HLALL .S DA=$O(^HLMA("B",HLMADT,0)) Q:DA<1 .S DIK="^HLMA(" D ^DIK S HLINK=0 F S HLINK=$O(^HL(772,"A-XMIT-OUT",HLINK)) Q:'HLINK D .S HLIEN2=0 .F S HLIEN2=$O(^HL(772,"A-XMIT-OUT",HLINK,HLIEN2)) Q:'HLIEN2 D ..I '$D(^HL(772,HLIEN2)) K ^HL(772,"A-XMIT-OUT",HLINK,HLIEN2) I '$D(ZTQUEUED) W !,HLDELCNT," entries purged." I $D(ZTQUEUED) S ZTREQ="@" Q K %H,DA,DIR,DIRUT,DIK,HLPDT,HLPERR,HLPTR,HLX,X1,X2,XMDUZ,XMK,XMZ,HLY,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,HLDELCNT,HLALL Q KILL ; S HLX=$G(^HL(772,HLIEN,0)) S XMZ=$P(HLX,"^",5) I XMZ S XMK=1,XMDUZ=.5 D KLQ^XMA1B S DA=HLIEN,DIK="^HL(772," D ^DIK S DA=HLPTR,DIK="^HLMA(" D ^DIK S HLDELCNT=HLDELCNT+1 I '$D(ZTQUEUED) W:('(HLDELCNT#5)) "." Q HLUPDATE HLUPDATE ; IHS/TUC/DLR - UPDATE HL FILE ENTRIES ; [ 04/16/97 11:07 AM ] ;;1.6;HEALTH LEVEL SEVEN;**3**;APR 16, 1997 ; ; This routine updates the HL package file entries ; to support the current version of the HL7 standard. ; It is run from the M prompt, after HLINIT. It takes ; no input variables and produces no output variables. ; N %,DA,DIC,GBL,I,V,VER,VSET,X,Y D ^XBKVAR ; W !,"Creating New HL7 Message Definitions.",! ; S X="VXU",DIC="^HL(771.2,",DIC(0)="L",DLAYGO=771.2 S DIC("DR")="2///Unsolicited Vaccination Record Update" D DEFINE I Y<0 D ABTMSG Q ; S X="V04",DIC="^HL(779.001,",DIC(0)="L",DLAYGO=779.001 S DIC("DR")="2///Unsolicited Vaccination Record Update" D DEFINE I Y<0 D ABTMSG Q ; S VSET="" F I=2.1,2.2,2.3 S VER(I)="",VSET=VSET_$TR(I,".")_":"_I_";" ; ; update data dictionary for file 869.2 ; I $P(^DD(869.2,200.08,0),U,3)'["2.3" S $P(^(0),U,3)=VSET,^("DT")="2970416" ; ; update entries in file 771.5 ; S DIC="^HL(771.5," S DIC(0)="L" S DLAYGO=771.5 S DIC("DR")="2///HEALTH LEVEL SEVEN" S V=0 F S V=$O(VER(V)) Q:'V S X=V D DEFINE I Y<0 D ABTMSG Q Q:(Y<0) K DR,DLAYGO,DIC ; W !,"Adding New HL7 Versions to All Message and Event Types.",! ; S V=0 F S V=$O(VER(V)) Q:'V S VER(V)=$O(^HL(771.5,"B",V,0)) I 'VER(V) D ABTMSG Q Q:V ; D ADD(771.2,3,"V") Q:(Y<0) D ADD(779.001,100,1) Q:(Y<0) ; W !,"HL File Update is Complete.",! Q ; ADD(FILE,FIELD,SUB) ; Add new versions to one file ; S DIC(0)="L" S DIC("P")=$P(^DD(FILE,FIELD,0),U,2) S I=0 F S I=$O(^HL(FILE,I)) Q:'I S DA(1)=I,DIC="^HL(FILE,"_DA(1)_","""_SUB_"""," D ADDVER I Y<0 D ABTMSG Q Q ; ADDVER ; Add new HL versions to one message or event type ; S V=0 F S V=$O(VER(V)) Q:'V S X=VER(V) D DEFINE Q:(Y<0) Q ; DEFINE ; define one file entry (if it doesn't already exist) ; S GBL=DIC_"""B"","""_X_""")" I $D(@GBL) S Y=0 Q K DD,DO,Y D FILE^DICN Q ; ABTMSG ; write abort message ; W !,*7,"*** Aborting due to Fileman error ***" W !,"*** Update is not complete. ***" Q HLUTIL3 HLUTIL3 ;ALB/MTC - VARIOUS HL7 UTILITIES - 2/1/95 ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;HEALTH LEVEL SEVEN;**2**;Oct 13, 1995 ; Q ; FNDSTAT(IEN) ;- This function will return the appropriate status based ; on the Accept Ack, Application Ack and version of the protocol ; being utilized. ; ; INPUT : IEN of the HL7 Message File (#772) ; OUTPUT: Pointer to HL7 Message Status File (#771.6) OR NULL if ; Not valid IEN or No parent. ; N PROTOCOL,PARENTP,PARENT,PROT N CHILD,RESULT N HLCA,HLAA ; S RESULT="" G:'IEN EXIT ;-- Find Parent S CHILD=$G(^HL(772,IEN,0)) I CHILD="" G EXIT S PARENTP=$P(CHILD,"^",8) I (PARENTP="") G EXIT S PARENT=$G(^HL(772,PARENTP,0)) ; S PROT=$P(PARENT,"^",10) S PROTOCOL=$$TYPE^HLUTIL2(PROT) S HLCA=$P(PROTOCOL,U,7) S HLAA=$P(PROTOCOL,U,8) ; ;-- if this is a responce (ack) message set to "sucessful" I $P(PARENT,U,7) S RESULT=3 G EXIT ;-- HLCA and HLAA assume original ack rules set to "awaiting ack" I HLCA="",HLAA="" S RESULT=2 G EXIT ;-- if HLCA=NE and HLAA=NE set to "sucessful" I HLCA="NE",HLAA="NE" S RESULT=3 G EXIT ;-- else set to "awaiting ack" S RESULT=2 ; EXIT ; Q RESULT ; DOMAIL(HLLINK) ; This function will determine if the MailMan LLP should ; be used to x-mit the outgoing message. ; INPUT - IEN of HL LOGICAL LINK (#870) ; OUTPUT - 1=Yes, 0=N ; N X S X=$P($G(^HLCS(870,+HLLINK,0)),U,22) Q $S(X:1,1:0) ; HLZFUNC HLZFUNC ;IHS/OHPRD/DWG - IHS HL7 FUNCTIONS; ;;1.6;HEALTH LEVEL SEVEN;**1**;APR 04, 1997 ;;1.6;DHCP HEALTH LEVEL SEVEN;;OCT 13, 1995 ; ; SITE() ; N X S X=DUZ(2)_"^"_$P(^DIC(4,DUZ(2),0),U)_"^"_$P(^AUTTLOC(DUZ(2),0),U,10) Q X ;