VAFEDOHL ;ALB/JLU/CAW;generates the HL7 message to be sent;6/29/93
;;5.3;Registration;**38**;Aug 13, 1993
EN DO
.D DATE
.I '$$CHK(VAFEDDT) Q
.D HL
.I $D(HLERR) Q
.D SETUP
D EXOHL^VAFEDUTL
Q
;
DATE ;this subroutine gets the date to start from.
S %DT="",X="T-1"
D ^%DT
S:'$D(VAFEDDT) VAFEDDT=Y_.9
K Y,X
Q
;
CHK(VAFEDDT) ;this subroutine checks for the existance of data in the 391.51
;file.
N X
S X=$O(^VAT(391.51,"ABDC",0))
DO
.I 'X S X=0 Q
.I X>VAFEDDT S X=0 Q
.S X=1 Q
Q X
;
HL ;this subroutine sets up HL7 variables.
;init of hltrans may return an error HLERR
S HLEVN=0
S HLNDAP="EDR-MAS"
D NOW^%DTC
S HLSDT=%
S HLMTN="ORU"
K ^TMP("HLS",$J),%H,%I,%
D INIT^HLTRANS
Q
;
SETUP ;starts the looping to get the info from the 391.51 file.
S VAFEDLCT=0
N VAFEDLP,X1,DFN,VAFEDD,VAFEDT
F VAFEDLP=0:0 S VAFEDLP=$O(^VAT(391.51,"ABDC",VAFEDLP)) Q:'VAFEDLP!(VAFEDLP>VAFEDDT) F DFN=0:0 S DFN=$O(^VAT(391.51,"ABDC",VAFEDLP,DFN)) Q:'DFN D SET
Q
;
SET ;second layer of the loop.
K VA,VADM,VAPA,VAERR
D DEM^VADPT,ADD^VADPT
I VADM(1)]"" DO
.I 'HLEVN DO
..I '$D(HLDA) D FILE^HLTF
..S ^TMP("HLS",$J,HLSDT,0)=$$BHS^HLFNC1(HLMTN)
.F VAFEDD=0:0 S VAFEDD=$O(^VAT(391.51,"ABDC",VAFEDLP,DFN,VAFEDD)) Q:'VAFEDD F VAFEDT=98,99 S VAFEDDA=$O(^VAT(391.51,"ABDC",VAFEDLP,DFN,VAFEDD,VAFEDT,0)) D:VAFEDDA BUILD I HLEVN>99 D SEND DO
..I '$D(HLDA) D FILE^HLTF
..S ^TMP("HLS",$J,HLSDT,0)=$$BHS^HLFNC1(HLMTN)
Q
;
BUILD ;this subroutine builds the HL7 messages segments
S VAFEDST1=$G(^VAT(391.51,VAFEDDA,100)) I VAFEDDA]"" S VAFEDST2=$G(^VAT(391.51,VAFEDDA,200)),VAFELIG=$P($G(^VAT(391.51,VAFEDDA,0)),U,7) D:$G(^(150,1,0)) DSTR DO
.S HLEVN=HLEVN+1
.D MSH^VAFEOHL1
.D PID^VAFEOHL1
.D ZEL^VAFEOHL1
.D PV1^VAFEOHL1
.D ORC^VAFEOHL2
.D OBR^VAFEOHL2
.D OBX^VAFEOHL2
.S $P(^VAT(391.51,VAFEDDA,0),"^",5)=HLDA
Q
;
LOG ;sets the HL7 string into the TMP global
S ^TMP("HLS",$J,HLSDT,VAFEDLCT)=VAFEDHL
Q
;
SEND ;sends the HL7 message
S VAFEDLCT=VAFEDLCT+1
S VAFEDHL="BTS"_HLFS_HLEVN
D LOG
D EN1^HLTRANS
D DELETE
S (VAFEDLCT,HLEVN)=0
Q
;
DELETE ;deletes entries that were sent.
N LP,Y
F LP=0:0 S LP=$O(^VAT(391.51,LP)) Q:'LP S Y=$G(^(LP,0)) I $P(Y,U,5) DO
.I '$D(HLERR) S DA=LP,DIK="^VAT(391.51," D ^DIK K DA,DIK Q
.I $D(HLERR) S $P(^VAT(391.51,LP,0),U,5)=""
K ^TMP("HLS",$J),HLDA,HLERR
Q
;
DSTR ;builds diagnosis string
N I
S I=0
F S I=$O(^VAT(391.51,VAFEDDA,150,I)) Q:'I S VAFEDDX(I)=^(I,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFEDOHL 2529 printed Sep 23, 2025@20:38:30 Page 2
VAFEDOHL ;ALB/JLU/CAW;generates the HL7 message to be sent;6/29/93
+1 ;;5.3;Registration;**38**;Aug 13, 1993
EN Begin DoDot:1
+1 DO DATE
+2 IF '$$CHK(VAFEDDT)
QUIT
+3 DO HL
+4 IF $DATA(HLERR)
QUIT
+5 DO SETUP
End DoDot:1
+6 DO EXOHL^VAFEDUTL
+7 QUIT
+8 ;
DATE ;this subroutine gets the date to start from.
+1 SET %DT=""
SET X="T-1"
+2 DO ^%DT
+3 if '$DATA(VAFEDDT)
SET VAFEDDT=Y_.9
+4 KILL Y,X
+5 QUIT
+6 ;
CHK(VAFEDDT) ;this subroutine checks for the existance of data in the 391.51
+1 ;file.
+2 NEW X
+3 SET X=$ORDER(^VAT(391.51,"ABDC",0))
+4 Begin DoDot:1
+5 IF 'X
SET X=0
QUIT
+6 IF X>VAFEDDT
SET X=0
QUIT
+7 SET X=1
QUIT
End DoDot:1
+8 QUIT X
+9 ;
HL ;this subroutine sets up HL7 variables.
+1 ;init of hltrans may return an error HLERR
+2 SET HLEVN=0
+3 SET HLNDAP="EDR-MAS"
+4 DO NOW^%DTC
+5 SET HLSDT=%
+6 SET HLMTN="ORU"
+7 KILL ^TMP("HLS",$JOB),%H,%I,%
+8 DO INIT^HLTRANS
+9 QUIT
+10 ;
SETUP ;starts the looping to get the info from the 391.51 file.
+1 SET VAFEDLCT=0
+2 NEW VAFEDLP,X1,DFN,VAFEDD,VAFEDT
+3 FOR VAFEDLP=0:0
SET VAFEDLP=$ORDER(^VAT(391.51,"ABDC",VAFEDLP))
if 'VAFEDLP!(VAFEDLP>VAFEDDT)
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^VAT(391.51,"ABDC",VAFEDLP,DFN))
if 'DFN
QUIT
DO SET
+4 QUIT
+5 ;
SET ;second layer of the loop.
+1 KILL VA,VADM,VAPA,VAERR
+2 DO DEM^VADPT
DO ADD^VADPT
+3 IF VADM(1)]""
Begin DoDot:1
+4 IF 'HLEVN
Begin DoDot:2
+5 IF '$DATA(HLDA)
DO FILE^HLTF
+6 SET ^TMP("HLS",$JOB,HLSDT,0)=$$BHS^HLFNC1(HLMTN)
End DoDot:2
+7 FOR VAFEDD=0:0
SET VAFEDD=$ORDER(^VAT(391.51,"ABDC",VAFEDLP,DFN,VAFEDD))
if 'VAFEDD
QUIT
FOR VAFEDT=98,99
SET VAFEDDA=$ORDER(^VAT(391.51,"ABDC",VAFEDLP,DFN,VAFEDD,VAFEDT,0))
if VAFEDDA
DO BUILD
IF HLEVN>99
DO SEND
Begin DoDot:2
+8 IF '$DATA(HLDA)
DO FILE^HLTF
+9 SET ^TMP("HLS",$JOB,HLSDT,0)=$$BHS^HLFNC1(HLMTN)
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
BUILD ;this subroutine builds the HL7 messages segments
+1 SET VAFEDST1=$GET(^VAT(391.51,VAFEDDA,100))
IF VAFEDDA]""
SET VAFEDST2=$GET(^VAT(391.51,VAFEDDA,200))
SET VAFELIG=$PIECE($GET(^VAT(391.51,VAFEDDA,0)),U,7)
if $GET(^(150,1,0))
DO DSTR
Begin DoDot:1
+2 SET HLEVN=HLEVN+1
+3 DO MSH^VAFEOHL1
+4 DO PID^VAFEOHL1
+5 DO ZEL^VAFEOHL1
+6 DO PV1^VAFEOHL1
+7 DO ORC^VAFEOHL2
+8 DO OBR^VAFEOHL2
+9 DO OBX^VAFEOHL2
+10 SET $PIECE(^VAT(391.51,VAFEDDA,0),"^",5)=HLDA
End DoDot:1
+11 QUIT
+12 ;
LOG ;sets the HL7 string into the TMP global
+1 SET ^TMP("HLS",$JOB,HLSDT,VAFEDLCT)=VAFEDHL
+2 QUIT
+3 ;
SEND ;sends the HL7 message
+1 SET VAFEDLCT=VAFEDLCT+1
+2 SET VAFEDHL="BTS"_HLFS_HLEVN
+3 DO LOG
+4 DO EN1^HLTRANS
+5 DO DELETE
+6 SET (VAFEDLCT,HLEVN)=0
+7 QUIT
+8 ;
DELETE ;deletes entries that were sent.
+1 NEW LP,Y
+2 FOR LP=0:0
SET LP=$ORDER(^VAT(391.51,LP))
if 'LP
QUIT
SET Y=$GET(^(LP,0))
IF $PIECE(Y,U,5)
Begin DoDot:1
+3 IF '$DATA(HLERR)
SET DA=LP
SET DIK="^VAT(391.51,"
DO ^DIK
KILL DA,DIK
QUIT
+4 IF $DATA(HLERR)
SET $PIECE(^VAT(391.51,LP,0),U,5)=""
End DoDot:1
+5 KILL ^TMP("HLS",$JOB),HLDA,HLERR
+6 QUIT
+7 ;
DSTR ;builds diagnosis string
+1 NEW I
+2 SET I=0
+3 FOR
SET I=$ORDER(^VAT(391.51,VAFEDDA,150,I))
if 'I
QUIT
SET VAFEDDX(I)=^(I,0)
+4 QUIT
