- 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
- 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