source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFEOHL2.m@ 1578

Last change on this file since 1578 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1VAFEOHL2 ;ALB/JLU/CAW;generates the HL7 message to be sent(con't);6/29/93
2 ;;5.3;Registration;**38**;Aug 13, 1993
3 ;
4ORC ;sets up the ORC segment and the fields 1 to indicate if new or canceled
5 N VAFEDHL
6 S VAFEDLCT=VAFEDLCT+1
7 S $P(VAFEDHL,HLFS,1)="ORC"
8 S $P(VAFEDHL,HLFS,2)=$S($P(VAFEDST1,"^",3)="C":"CA",1:"NW")
9 D LOG^VAFEDOHL
10 Q
11 ;
12OBR ;sets up the OBR segment and the fields 4,7,8,9,14,22
13 N VAFEDHL
14 S VAFEDLCT=VAFEDLCT+1
15 S $P(VAFEDHL,HLFS,1)="OBR"
16 S $P(VAFEDHL,HLFS,5)=VAFEDDA_$E(HLECH)_"391.51"_$E(HLECH)_"L"
17 S $P(VAFEDHL,HLFS,8)=$$HLDATE^HLFNC($P(VAFEDST1,U,1))
18 S $P(VAFEDHL,HLFS,9)=HLQ
19 S $P(VAFEDHL,HLFS,10)=HLQ
20 S $P(VAFEDHL,HLFS,15)=HLQ
21 S $P(VAFEDHL,HLFS,23)=$$HLDATE^HLFNC(VAFEDLP)
22 D LOG^VAFEDOHL
23 Q
24 ;
25OBX ;this subroutine set up the OBX segments and the fields 3,5
26 N X,VAFEDOBX
27 S VAFEDOBX=0
28 I +$P($G(VAFEDDX(1)),U) D DIAG
29 I VAFEDST2]"" D CPT
30 Q
31 ;
32DIAG ;this subroutine will set up the diagnosics in the OBX.
33 N VAFEDN,X,VAFEDD,I
34 S VAFEDN=+$P(VAFEDDX(1),U)
35 F X=2:1 S VAFEDC=$P(VAFEDDX(1),U,X) Q:'VAFEDC DO
36 .S Y=$O(^ICD9("BA",VAFEDC,0))
37 .Q:'Y I '$D(^ICD9(Y,0)) Q
38 .S VAFEDD=$P(^ICD9(Y,0),U,3)
39 .S VAFEDOBX=VAFEDOBX+1,VAFEDLCT=VAFEDLCT+1
40 .S VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$E(HLECH)_VAFEDD_$E(HLECH)_"I9"_HLFS_HLFS_HLQ
41 .D LOG^VAFEDOHL
42 I $D(VAFEDDX(2)) S I=1 F S I=$O(VAFEDDX(I)) Q:'I D
43 .F X=2:1 S VAFEDC=$P(VAFEDDX(I),U,X) Q:'VAFEDC DO
44 ..S Y=$O(^ICD9("BA",VAFEDC,0))
45 ..Q:'Y I '$D(^ICD9(Y,0)) Q
46 ..S VAFEDD=$P(^ICD9(Y,0),U,3)
47 ..S VAFEDOBX=VAFEDOBX+1,VAFEDLCT=VAFEDLCT+1
48 ..S VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$E(HLECH)_VAFEDD_$E(HLECH)_"I9"_HLFS_HLFS_HLQ
49 ..D LOG^VAFEDOHL
50 Q
51 ;
52CPT ;this subroutine will set up the OBX with CPT codes.
53 N X,VAFEDC,VAFEDD
54 F X=1:1 S VAFEDC=$P(VAFEDST2,U,X) Q:'VAFEDC DO
55 .S Y=$O(^ICPT("B",VAFEDC,0))
56 .Q:'Y I '$D(^ICPT(Y,0)) Q
57 .S VAFEDD=$P(^ICPT(Y,0),U,2)
58 .S VAFEDOBX=VAFEDOBX+1,VAFEDLCT=VAFEDLCT+1
59 .S VAFEDHL="OBX"_HLFS_VAFEDOBX_HLFS_"CE"_HLFS_VAFEDC_$E(HLECH)_VAFEDD_$E(HLECH)_"AS4"_HLFS_HLFS_HLQ
60 .D LOG^VAFEDOHL
61 Q
Note: See TracBrowser for help on using the repository browser.