VAFEOHL2 ;ALB/JLU/CAW;generates the HL7 message to be sent(con't);6/29/93
;;5.3;Registration;**38**;Aug 13, 1993
;
ORC ;sets up the ORC segment and the fields 1 to indicate if new or canceled
N VAFEDHL
S VAFEDLCT=VAFEDLCT+1
S $P(VAFEDHL,HLFS,1)="ORC"
S $P(VAFEDHL,HLFS,2)=$S($P(VAFEDST1,"^",3)="C":"CA",1:"NW")
D LOG^VAFEDOHL
Q
;
OBR ;sets up the OBR segment and the fields 4,7,8,9,14,22
N VAFEDHL
S VAFEDLCT=VAFEDLCT+1
S $P(VAFEDHL,HLFS,1)="OBR"
S $P(VAFEDHL,HLFS,5)=VAFEDDA_$E(HLECH)_"391.51"_$E(HLECH)_"L"
S $P(VAFEDHL,HLFS,8)=$$HLDATE^HLFNC($P(VAFEDST1,U,1))
S $P(VAFEDHL,HLFS,9)=HLQ
S $P(VAFEDHL,HLFS,10)=HLQ
S $P(VAFEDHL,HLFS,15)=HLQ
S $P(VAFEDHL,HLFS,23)=$$HLDATE^HLFNC(VAFEDLP)
D LOG^VAFEDOHL
Q
;
OBX ;this subroutine set up the OBX segments and the fields 3,5
N X,VAFEDOBX
S VAFEDOBX=0
I +$P($G(VAFEDDX(1)),U) D DIAG
I VAFEDST2]"" D CPT
Q
;
DIAG ;this subroutine will set up the diagnosics in the OBX.
N VAFEDN,X,VAFEDD,I
S VAFEDN=+$P(VAFEDDX(1),U)
F X=2:1 S VAFEDC=$P(VAFEDDX(1),U,X) Q:'VAFEDC DO
.S Y=$O(^ICD9("BA",VAFEDC,0))
.Q:'Y I '$D(^ICD9(Y,0)) Q
.S VAFEDD=$P(^ICD9(Y,0),U,3)
.S VAFEDOBX=VAFEDOBX+1,VAFEDLCT=VAFEDLCT+1
.S VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$E(HLECH)_VAFEDD_$E(HLECH)_"I9"_HLFS_HLFS_HLQ
.D LOG^VAFEDOHL
I $D(VAFEDDX(2)) S I=1 F S I=$O(VAFEDDX(I)) Q:'I D
.F X=2:1 S VAFEDC=$P(VAFEDDX(I),U,X) Q:'VAFEDC DO
..S Y=$O(^ICD9("BA",VAFEDC,0))
..Q:'Y I '$D(^ICD9(Y,0)) Q
..S VAFEDD=$P(^ICD9(Y,0),U,3)
..S VAFEDOBX=VAFEDOBX+1,VAFEDLCT=VAFEDLCT+1
..S VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$E(HLECH)_VAFEDD_$E(HLECH)_"I9"_HLFS_HLFS_HLQ
..D LOG^VAFEDOHL
Q
;
CPT ;this subroutine will set up the OBX with CPT codes.
N X,VAFEDC,VAFEDD
F X=1:1 S VAFEDC=$P(VAFEDST2,U,X) Q:'VAFEDC DO
.S Y=$O(^ICPT("B",VAFEDC,0))
.Q:'Y I '$D(^ICPT(Y,0)) Q
.S VAFEDD=$P(^ICPT(Y,0),U,2)
.S VAFEDOBX=VAFEDOBX+1,VAFEDLCT=VAFEDLCT+1
.S VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$E(HLECH)_VAFEDD_$E(HLECH)_"AS4"_HLFS_HLFS_HLQ
.D LOG^VAFEDOHL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFEOHL2 2096 printed Dec 13, 2024@03:02:39 Page 2
VAFEOHL2 ;ALB/JLU/CAW;generates the HL7 message to be sent(con't);6/29/93
+1 ;;5.3;Registration;**38**;Aug 13, 1993
+2 ;
ORC ;sets up the ORC segment and the fields 1 to indicate if new or canceled
+1 NEW VAFEDHL
+2 SET VAFEDLCT=VAFEDLCT+1
+3 SET $PIECE(VAFEDHL,HLFS,1)="ORC"
+4 SET $PIECE(VAFEDHL,HLFS,2)=$SELECT($PIECE(VAFEDST1,"^",3)="C":"CA",1:"NW")
+5 DO LOG^VAFEDOHL
+6 QUIT
+7 ;
OBR ;sets up the OBR segment and the fields 4,7,8,9,14,22
+1 NEW VAFEDHL
+2 SET VAFEDLCT=VAFEDLCT+1
+3 SET $PIECE(VAFEDHL,HLFS,1)="OBR"
+4 SET $PIECE(VAFEDHL,HLFS,5)=VAFEDDA_$EXTRACT(HLECH)_"391.51"_$EXTRACT(HLECH)_"L"
+5 SET $PIECE(VAFEDHL,HLFS,8)=$$HLDATE^HLFNC($PIECE(VAFEDST1,U,1))
+6 SET $PIECE(VAFEDHL,HLFS,9)=HLQ
+7 SET $PIECE(VAFEDHL,HLFS,10)=HLQ
+8 SET $PIECE(VAFEDHL,HLFS,15)=HLQ
+9 SET $PIECE(VAFEDHL,HLFS,23)=$$HLDATE^HLFNC(VAFEDLP)
+10 DO LOG^VAFEDOHL
+11 QUIT
+12 ;
OBX ;this subroutine set up the OBX segments and the fields 3,5
+1 NEW X,VAFEDOBX
+2 SET VAFEDOBX=0
+3 IF +$PIECE($GET(VAFEDDX(1)),U)
DO DIAG
+4 IF VAFEDST2]""
DO CPT
+5 QUIT
+6 ;
DIAG ;this subroutine will set up the diagnosics in the OBX.
+1 NEW VAFEDN,X,VAFEDD,I
+2 SET VAFEDN=+$PIECE(VAFEDDX(1),U)
+3 FOR X=2:1
SET VAFEDC=$PIECE(VAFEDDX(1),U,X)
if 'VAFEDC
QUIT
Begin DoDot:1
+4 SET Y=$ORDER(^ICD9("BA",VAFEDC,0))
+5 if 'Y
QUIT
IF '$DATA(^ICD9(Y,0))
QUIT
+6 SET VAFEDD=$PIECE(^ICD9(Y,0),U,3)
+7 SET VAFEDOBX=VAFEDOBX+1
SET VAFEDLCT=VAFEDLCT+1
+8 SET VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$EXTRACT(HLECH)_VAFEDD_$EXTRACT(HLECH)_"I9"_HLFS_HLFS_HLQ
+9 DO LOG^VAFEDOHL
End DoDot:1
+10 IF $DATA(VAFEDDX(2))
SET I=1
FOR
SET I=$ORDER(VAFEDDX(I))
if 'I
QUIT
Begin DoDot:1
+11 FOR X=2:1
SET VAFEDC=$PIECE(VAFEDDX(I),U,X)
if 'VAFEDC
QUIT
Begin DoDot:2
+12 SET Y=$ORDER(^ICD9("BA",VAFEDC,0))
+13 if 'Y
QUIT
IF '$DATA(^ICD9(Y,0))
QUIT
+14 SET VAFEDD=$PIECE(^ICD9(Y,0),U,3)
+15 SET VAFEDOBX=VAFEDOBX+1
SET VAFEDLCT=VAFEDLCT+1
+16 SET VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$EXTRACT(HLECH)_VAFEDD_$EXTRACT(HLECH)_"I9"_HLFS_HLFS_HLQ
+17 DO LOG^VAFEDOHL
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
CPT ;this subroutine will set up the OBX with CPT codes.
+1 NEW X,VAFEDC,VAFEDD
+2 FOR X=1:1
SET VAFEDC=$PIECE(VAFEDST2,U,X)
if 'VAFEDC
QUIT
Begin DoDot:1
+3 SET Y=$ORDER(^ICPT("B",VAFEDC,0))
+4 if 'Y
QUIT
IF '$DATA(^ICPT(Y,0))
QUIT
+5 SET VAFEDD=$PIECE(^ICPT(Y,0),U,2)
+6 SET VAFEDOBX=VAFEDOBX+1
SET VAFEDLCT=VAFEDLCT+1
+7 SET VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$EXTRACT(HLECH)_VAFEDD_$EXTRACT(HLECH)_"AS4"_HLFS_HLFS_HLQ
+8 DO LOG^VAFEDOHL
End DoDot:1
+9 QUIT
