- HLTRANS ;AISC/SAW-Create Mail Message and Entry in the HL7 Transmission File ;03/24/2004 16:22
- ;;1.6;HEALTH LEVEL SEVEN;**108**;Oct 13, 1995
- ;This routine is used for the Version 1.5 Interface Only
- EN ;Compile 'MSH' Segment
- I '$D(HLERR1) S HLEVN=1,HLSDATA(0)=$$MSH^HLFNC1($G(HLMTN),$G(HLSEC)) I $D(HLSDT) S ^TMP("HLS",$J,HLSDT,0)=HLSDATA(0) K HLSDATA
- EN1 ;Create Mail Message (Package Supplies MSH Segment(s))
- S XMSUB="HL7 Message "_HLDT_" from "_HLDAN_" at Station "_$P(HLNDAP0,"^",2),XMDUZ=.5 D GET^XMA2 G EN1:XMZ<1 S HLXMZ=XMZ
- I '$D(HLERR1) N X,Y D
- .I '$D(HLSDT) S HLI="",HLCHAR=0 F HLI0=1:1 S HLI=$O(HLSDATA(HLI)) Q:HLI="" S ^XMB(3.9,HLXMZ,2,HLI0,0)=HLSDATA(HLI),HLCHAR=HLCHAR+$L(HLSDATA(HLI)) S X=HLSDATA(HLI) I $E(X,1,3)="MSA"!($E(X,1,3)="BHS") D:'$D(HLMSA)
- ..I $E(X,1,3)="MSA" S HLMSA=X
- ..I $E(X,1,3)="BHS",$P(X,HLFS,10)]"" S HLMSA=$P(X,HLFS,10)
- .I $D(HLSDT) S HLI="",HLCHAR=0 F HLI0=1:1 S HLI=$O(^TMP("HLS",$J,HLSDT,HLI)) Q:HLI="" S X=^TMP("HLS",$J,HLSDT,HLI),^XMB(3.9,HLXMZ,2,HLI0,0)=X,HLCHAR=HLCHAR+$L(X) I $E(X,1,3)="MSA"!($E(X,1,3)="BHS") D:'$D(HLMSA)
- ..I $E(X,1,3)="MSA" S HLMSA=X
- ..I $E(X,1,3)="BHS",$P(X,HLFS,10)]"" S HLMSA=$P(X,HLFS,10)
- .S HLI0=HLI0-1,^XMB(3.9,HLXMZ,2,0)="^3.92A^"_HLI0_"^"_HLI0_"^"_DT,XMDUN="POSTMASTER"
- .I $P(HLNDAP0,"^",10) D
- ..S X=$G(^XMB(3.8,$P(HLNDAP0,"^",10),0)) I $P(X,"^")]"" S XMY("G."_$P(X,"^"))=""
- ..E K XMY S HLERR1=1,HLERR="Unable to determine receipients for mail message.",XMY(.5)="" K ^XMB(3.9,HLXMZ,2)
- .I '$P(HLNDAP0,"^",10) S XMY(.5)=""
- .I '$D(HLERR1) D ENT1^XMD
- EN2 ;Enter Data into HL7 Transmission File/Record Error Messages
- S:$D(HLERR) HLMSG="Application Error" D OUT^HLTF(HLDA,HLDT,HLMTN) I $D(HLERR1) D
- .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
- EXIT K HLERR1,HLI,HLI0,HLMSA,HLXMZ,VAT,VATERR,VATNAME,XMDUN,XMDUZ,XMSUB,XMY,XMZ Q
- INIT ;Initialize Variables for Creating HL7 Segments
- ;The following variables are returned by this entry point:
- ;HLNDAP - Non-DHCP Application Pointer from file 770
- ;HLNDAP0 - Zero node from file 770 corresponding to HLNDAP
- ;HLDAP - DHCP Application Pointer from file 771
- ;HLDAN - The DHCP Application Name (.01 field, file 771) for HLDAP
- ;HLPID - HL7 processing ID from file 770
- ;HLVER - HL7 version number from file 770
- ;HLFS - HL7 Field Separater from the 'FS' node of file 771
- ;HLECH - HL7 Encoding Characters from the 'EC' node of file 771
- ;HLQ - Double quotes ("") for use in building HL7 segments
- ;HLERR - if an error is encountered, an error message is returned
- ; in the HLERR variable.
- ;HLDA - the internal entry number for the entry created in file 772.
- ;HLDT - the transmission date/time (associated with the entry in
- ; in file 772 identified by HLDA) in internal VA FileMan
- ; format.
- ;HLDT1 - the same transmission date/time as the HLDT variable, only
- ; in HL7 format.
- ;
- ; patch HL*1.6*108 start
- ;I $D(HLDAP) S:'HLDAP HLDAN=HLDAP S HLDAP=$S('HLDAP:$O(^HL(771,"B",HLDAP,0)),1:HLDAP),HLNDAP=$O(^HL(770,"AG",+HLDAP,0)) I 'HLDAP!('HLNDAP) S HLERR="Invalid "_$S('HLDAP:"DHCP",1:"Non-DHCP")_" Application Name" G SET
- I $D(HLDAP) S:'HLDAP HLDAN=HLDAP S HLDAP=$S('HLDAP:$O(^HL(771,"B",$E(HLDAP,1,30),0)),1:HLDAP),HLNDAP=$O(^HL(770,"AG",+HLDAP,0)) I 'HLDAP!('HLNDAP) S HLERR="Invalid "_$S('HLDAP:"DHCP",1:"Non-DHCP")_" Application Name" G SET
- ; patch HL*1.6*108 end
- ;
- S HLNDAP=$S('$D(HLNDAP):0,HLNDAP:HLNDAP,1:$O(^HL(770,"B",HLNDAP,0))) I 'HLNDAP S HLERR="Invalid Non-DHCP Application Name" G SET
- S HLNDAP0=$S($D(^HL(770,HLNDAP,0)):^(0),1:"") I HLNDAP0']"" S HLERR="Invalid Non-DHCP Application Name" G SET
- I '$D(HLDAP) S HLDAP=$P(HLNDAP0,"^",8) I 'HLDAP S HLERR="Invalid DHCP Application Name" G SET
- I '$D(HLDAN) S HLDAN=$S($D(^HL(771,HLDAP,0)):$P(^(0),"^"),1:"") I HLDAN']"" S HLERR="Invalid DHCP Application Name" G SET
- S HLPID=$P(HLNDAP0,"^",14) I HLPID']"" S HLPID="P"
- S HLVER=$S($D(^HL(771.5,+$P(HLNDAP0,"^",7),0)):$P(^(0),"^"),1:2.1) I HLVER']"" S HLVER=2.1
- S HLQ="""""",HLFS=$S($D(^HL(771,HLDAP,"FS")):$E(^("FS")),1:"^"),HLECH=$S($D(^("EC")):$E(^("EC"),1,4),1:"~|\&")
- SET D CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1) K HLMID
- I $D(HLERR) S:'$G(HLDAP) HLDAP="" S:'HLNDAP HLNDAP="" S:$G(HLDAN)']"" HLDAN="UNKNOWN" S:'$G(HLNDAP0) HLNDAP0="^UNKNOWN" S HLMTN="UNKNOWN",HLERR1=1,HLFS="" D EN K HLFS,HLMSG,HLMTN
- Q
- KILL ;Delete HL variables created by calls to INIT^HLTRANS and FILE^HLTF
- K HLCHAR,HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLDUZ,HLECH,HLERR,HLFS,HLNDAP,HLNDAP0,HLPID,HLQ,HLVER Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLTRANS 4695 printed Jan 18, 2025@03:01:24 Page 2
- HLTRANS ;AISC/SAW-Create Mail Message and Entry in the HL7 Transmission File ;03/24/2004 16:22
- +1 ;;1.6;HEALTH LEVEL SEVEN;**108**;Oct 13, 1995
- +2 ;This routine is used for the Version 1.5 Interface Only
- EN ;Compile 'MSH' Segment
- +1 IF '$DATA(HLERR1)
- SET HLEVN=1
- SET HLSDATA(0)=$$MSH^HLFNC1($GET(HLMTN),$GET(HLSEC))
- IF $DATA(HLSDT)
- SET ^TMP("HLS",$JOB,HLSDT,0)=HLSDATA(0)
- KILL HLSDATA
- EN1 ;Create Mail Message (Package Supplies MSH Segment(s))
- +1 SET XMSUB="HL7 Message "_HLDT_" from "_HLDAN_" at Station "_$PIECE(HLNDAP0,"^",2)
- SET XMDUZ=.5
- DO GET^XMA2
- if XMZ<1
- GOTO EN1
- SET HLXMZ=XMZ
- +2 IF '$DATA(HLERR1)
- NEW X,Y
- Begin DoDot:1
- +3 IF '$DATA(HLSDT)
- SET HLI=""
- SET HLCHAR=0
- FOR HLI0=1:1
- SET HLI=$ORDER(HLSDATA(HLI))
- if HLI=""
- QUIT
- SET ^XMB(3.9,HLXMZ,2,HLI0,0)=HLSDATA(HLI)
- SET HLCHAR=HLCHAR+$LENGTH(HLSDATA(HLI))
- SET X=HLSDATA(HLI)
- IF $EXTRACT(X,1,3)="MSA"!($EXTRACT(X,1,3)="BHS")
- if '$DATA(HLMSA)
- Begin DoDot:2
- +4 IF $EXTRACT(X,1,3)="MSA"
- SET HLMSA=X
- +5 IF $EXTRACT(X,1,3)="BHS"
- IF $PIECE(X,HLFS,10)]""
- SET HLMSA=$PIECE(X,HLFS,10)
- End DoDot:2
- +6 IF $DATA(HLSDT)
- SET HLI=""
- SET HLCHAR=0
- FOR HLI0=1:1
- SET HLI=$ORDER(^TMP("HLS",$JOB,HLSDT,HLI))
- if HLI=""
- QUIT
- SET X=^TMP("HLS",$JOB,HLSDT,HLI)
- SET ^XMB(3.9,HLXMZ,2,HLI0,0)=X
- SET HLCHAR=HLCHAR+$LENGTH(X)
- IF $EXTRACT(X,1,3)="MSA"!($EXTRACT(X,1,3)="BHS")
- if '$DATA(HLMSA)
- Begin DoDot:2
- +7 IF $EXTRACT(X,1,3)="MSA"
- SET HLMSA=X
- +8 IF $EXTRACT(X,1,3)="BHS"
- IF $PIECE(X,HLFS,10)]""
- SET HLMSA=$PIECE(X,HLFS,10)
- End DoDot:2
- +9 SET HLI0=HLI0-1
- SET ^XMB(3.9,HLXMZ,2,0)="^3.92A^"_HLI0_"^"_HLI0_"^"_DT
- SET XMDUN="POSTMASTER"
- +10 IF $PIECE(HLNDAP0,"^",10)
- Begin DoDot:2
- +11 SET X=$GET(^XMB(3.8,$PIECE(HLNDAP0,"^",10),0))
- IF $PIECE(X,"^")]""
- SET XMY("G."_$PIECE(X,"^"))=""
- +12 IF '$TEST
- KILL XMY
- SET HLERR1=1
- SET HLERR="Unable to determine receipients for mail message."
- SET XMY(.5)=""
- KILL ^XMB(3.9,HLXMZ,2)
- End DoDot:2
- +13 IF '$PIECE(HLNDAP0,"^",10)
- SET XMY(.5)=""
- +14 IF '$DATA(HLERR1)
- DO ENT1^XMD
- End DoDot:1
- EN2 ;Enter Data into HL7 Transmission File/Record Error Messages
- +1 if $DATA(HLERR)
- SET HLMSG="Application Error"
- DO OUT^HLTF(HLDA,HLDT,HLMTN)
- IF $DATA(HLERR1)
- Begin DoDot:1
- +2 SET ^XMB(3.9,HLXMZ,2,1,0)="Unable to transmit HL7 message due to the following Application Error:"
- SET ^XMB(3.9,HLXMZ,2,2,0)=HLERR
- SET ^XMB(3.9,HLXMZ,2,0)="^3.92A^2^2^"_DT
- +3 SET XMY(.5)=""
- DO ENT1^XMD
- End DoDot:1
- EXIT KILL HLERR1,HLI,HLI0,HLMSA,HLXMZ,VAT,VATERR,VATNAME,XMDUN,XMDUZ,XMSUB,XMY,XMZ
- QUIT
- INIT ;Initialize Variables for Creating HL7 Segments
- +1 ;The following variables are returned by this entry point:
- +2 ;HLNDAP - Non-DHCP Application Pointer from file 770
- +3 ;HLNDAP0 - Zero node from file 770 corresponding to HLNDAP
- +4 ;HLDAP - DHCP Application Pointer from file 771
- +5 ;HLDAN - The DHCP Application Name (.01 field, file 771) for HLDAP
- +6 ;HLPID - HL7 processing ID from file 770
- +7 ;HLVER - HL7 version number from file 770
- +8 ;HLFS - HL7 Field Separater from the 'FS' node of file 771
- +9 ;HLECH - HL7 Encoding Characters from the 'EC' node of file 771
- +10 ;HLQ - Double quotes ("") for use in building HL7 segments
- +11 ;HLERR - if an error is encountered, an error message is returned
- +12 ; in the HLERR variable.
- +13 ;HLDA - the internal entry number for the entry created in file 772.
- +14 ;HLDT - the transmission date/time (associated with the entry in
- +15 ; in file 772 identified by HLDA) in internal VA FileMan
- +16 ; format.
- +17 ;HLDT1 - the same transmission date/time as the HLDT variable, only
- +18 ; in HL7 format.
- +19 ;
- +20 ; patch HL*1.6*108 start
- +21 ;I $D(HLDAP) S:'HLDAP HLDAN=HLDAP S HLDAP=$S('HLDAP:$O(^HL(771,"B",HLDAP,0)),1:HLDAP),HLNDAP=$O(^HL(770,"AG",+HLDAP,0)) I 'HLDAP!('HLNDAP) S HLERR="Invalid "_$S('HLDAP:"DHCP",1:"Non-DHCP")_" Application Name" G SET
- +22 IF $DATA(HLDAP)
- if 'HLDAP
- SET HLDAN=HLDAP
- SET HLDAP=$SELECT('HLDAP:$ORDER(^HL(771,"B",$EXTRACT(HLDAP,1,30),0)),1:HLDAP)
- SET HLNDAP=$ORDER(^HL(770,"AG",+HLDAP,0))
- IF 'HLDAP!('HLNDAP)
- SET HLERR="Invalid "_$SELECT('HLDAP:"DHCP",1:"Non-DHCP")_" Application Name"
- GOTO SET
- +23 ; patch HL*1.6*108 end
- +24 ;
- +25 SET HLNDAP=$SELECT('$DATA(HLNDAP):0,HLNDAP:HLNDAP,1:$ORDER(^HL(770,"B",HLNDAP,0)))
- IF 'HLNDAP
- SET HLERR="Invalid Non-DHCP Application Name"
- GOTO SET
- +26 SET HLNDAP0=$SELECT($DATA(^HL(770,HLNDAP,0)):^(0),1:"")
- IF HLNDAP0']""
- SET HLERR="Invalid Non-DHCP Application Name"
- GOTO SET
- +27 IF '$DATA(HLDAP)
- SET HLDAP=$PIECE(HLNDAP0,"^",8)
- IF 'HLDAP
- SET HLERR="Invalid DHCP Application Name"
- GOTO SET
- +28 IF '$DATA(HLDAN)
- SET HLDAN=$SELECT($DATA(^HL(771,HLDAP,0)):$PIECE(^(0),"^"),1:"")
- IF HLDAN']""
- SET HLERR="Invalid DHCP Application Name"
- GOTO SET
- +29 SET HLPID=$PIECE(HLNDAP0,"^",14)
- IF HLPID']""
- SET HLPID="P"
- +30 SET HLVER=$SELECT($DATA(^HL(771.5,+$PIECE(HLNDAP0,"^",7),0)):$PIECE(^(0),"^"),1:2.1)
- IF HLVER']""
- SET HLVER=2.1
- +31 SET HLQ=""""""
- SET HLFS=$SELECT($DATA(^HL(771,HLDAP,"FS")):$EXTRACT(^("FS")),1:"^")
- SET HLECH=$SELECT($DATA(^("EC")):$EXTRACT(^("EC"),1,4),1:"~|\&")
- SET DO CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1)
- KILL HLMID
- +1 IF $DATA(HLERR)
- if '$GET(HLDAP)
- SET HLDAP=""
- if 'HLNDAP
- SET HLNDAP=""
- if $GET(HLDAN)']""
- SET HLDAN="UNKNOWN"
- if '$GET(HLNDAP0)
- SET HLNDAP0="^UNKNOWN"
- SET HLMTN="UNKNOWN"
- SET HLERR1=1
- SET HLFS=""
- DO EN
- KILL HLFS,HLMSG,HLMTN
- +2 QUIT
- KILL ;Delete HL variables created by calls to INIT^HLTRANS and FILE^HLTF
- +1 KILL HLCHAR,HLDA,HLDAN,HLDAP,HLDT,HLDT1,HLDUZ,HLECH,HLERR,HLFS,HLNDAP,HLNDAP0,HLPID,HLQ,HLVER
- QUIT