1 | IVMPTRNA ;ALB/CKN/BRM,TDM - HL7 FULL DATA TRANSMISSION (Z07) BUILDER(CONTINUED);30 AUG 2001 ; 5/17/06 1:57pm
|
---|
2 | ;;2.0;INCOME VERIFICATION MATCH;**46,58,76,105**; 21-OCT-94;Build 2
|
---|
3 | Q
|
---|
4 | NTROBX(DGNTARR) ;
|
---|
5 | N NTRTEMP,I,CS,RS,SS
|
---|
6 | I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
|
---|
7 | I $G(HLFS)'="^" N HLFS S HLFS="^"
|
---|
8 | S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2)
|
---|
9 | S NTRTEMP("NTR","Y")="1"_CS_"Received NTR Trmt"_CS_"VA0053"
|
---|
10 | S NTRTEMP("AVI","Y")="2"_CS_"Aviator Pre 1955"_CS_"VA0053"
|
---|
11 | S NTRTEMP("SUB","Y")="3"_CS_"Sub Trainee pre 1965"_CS_"VA0053"
|
---|
12 | S NTRTEMP("HNC","Y")="4"_CS_"Dx With Head Neck Cancer"_CS_"VA0053"
|
---|
13 | S NTRTEMP("NTR","N")="5"_CS_"No NTR Trmt"_CS_"VA0053"
|
---|
14 | S NTRTEMP("AVI","N")="6"_CS_"Not Aviator Pre 1955"_CS_"VA0053"
|
---|
15 | S NTRTEMP("SUB","N")="7"_CS_"Not Sub Trainee pre 1965"_CS_"VA0053"
|
---|
16 | S NTRTEMP("HNC","N")="8"_CS_"Not Dx With Head Neck Cancer"_CS_"VA0053"
|
---|
17 | S NTRTEMP("NTR","U")="9"_CS_"NTR Trmt Unknown"_CS_"VA0053"
|
---|
18 | S NTRTEMP("VER","M")="M"_CS_"Military Med Rec"_CS_"VA0052"
|
---|
19 | S NTRTEMP("VER","S")="S"_CS_"Qual Military Srvc"_CS_"VA0052"
|
---|
20 | S NTRTEMP("VER","N")="N"_CS_"Not Qualified"_CS_"VA0052"
|
---|
21 | S NTROBX(2)="CE",NTROBX(3)="VISTA"_CS_"28.11"
|
---|
22 | S NTROBX(5)=""
|
---|
23 | F I="NTR","AVI","SUB","HNC" D
|
---|
24 | . I $G(DGNTARR(I))="" Q
|
---|
25 | . I NTROBX(5)'="" S NTROBX(5)=$G(NTROBX(5))_RS
|
---|
26 | . S NTROBX(5)=$G(NTROBX(5))_$G(NTRTEMP(I,$G(DGNTARR(I))))
|
---|
27 | S NTROBX(11)="F"
|
---|
28 | S NTROBX(12)=$G(DGNTARR("HDT"))
|
---|
29 | S NTROBX(14)=$G(DGNTARR("VDT"))
|
---|
30 | I $G(DGNTARR("VSIT"))'="" D
|
---|
31 | . S NTROBX(15)=$P($G(^DIC(4,DGNTARR("VSIT"),99)),"^")
|
---|
32 | S NTROBX(16)=""
|
---|
33 | I $G(DGNTARR("HSIT"))'="" D
|
---|
34 | . S $P(NTROBX(16),CS,14)=SS_$P($G(^DIC(4,DGNTARR("HSIT"),99)),"^")
|
---|
35 | I $G(DGNTARR("VER"))'="" S NTROBX(17)=$G(NTRTEMP("VER",$G(DGNTARR("VER"))))
|
---|
36 | Q
|
---|
37 | RF1(DFN,RF1TYP) ; create RF1 segment
|
---|
38 | ; Input:
|
---|
39 | ; DFN - Patient IEN
|
---|
40 | ; RF1TYP - RF1 Type
|
---|
41 | ; SAD = Street Address Change (Default)
|
---|
42 | ; CAD = Confidential Address Change
|
---|
43 | ; CPH = Cell Phone Number Change
|
---|
44 | ; PNO = Pager Number Change
|
---|
45 | ; EAD = E-Mail Address Change
|
---|
46 | ;
|
---|
47 | ; Output: RF1 segment
|
---|
48 | ;
|
---|
49 | N X,Y,ADDRSRC,ADRSRC,ADRSIT,ADTDT,I,CS,RS,SS,HLQ,RETURN,RFDAT,ERR
|
---|
50 | I $G(HLECH)'="~|\&" N HLECH S HLECH="~|\&"
|
---|
51 | I $G(HLFS)'="^" N HLFS S HLFS="^"
|
---|
52 | S CS=$E(HLECH,1),SS=$E(HLECH,4),RS=$E(HLECH,2),HLQ=""""
|
---|
53 | S:$G(RF1TYP)="" RF1TYP="SAD" ;Set type to 'SAD' if no value passed
|
---|
54 | ; initialize the RETURN variable
|
---|
55 | S RETURN="RF1",$P(RETURN,HLFS,4)=RF1TYP,$P(RETURN,HLFS,11)=""
|
---|
56 | Q:'$G(DFN) RETURN
|
---|
57 | ;I RF1TYP="SAD",$$BADADR^DGUTL3(DFN) Q RETURN
|
---|
58 | D RF1LOAD(RF1TYP) Q:$D(ERR) RETURN
|
---|
59 | I RF1TYP'="SAD",$G(ADRDT)="" Q ""
|
---|
60 | ; RF1 SEQ 1-2 are not currently used
|
---|
61 | ; RF1 SEQ 3
|
---|
62 | S $P(RETURN,HLFS,4)=RF1TYP
|
---|
63 | ; RF1 SEQ 4-5 are not currently used
|
---|
64 | ; RF1 SEQ 6
|
---|
65 | S $P(RETURN,HLFS,7)=$G(ADRSIT)
|
---|
66 | S:$G(ADRSRC)'="" $P(RETURN,HLFS,7)=$P(RETURN,HLFS,7)_CS_ADRSRC
|
---|
67 | ; RF1 SEQ 7
|
---|
68 | S $P(RETURN,HLFS,8)=$G(ADRDT)
|
---|
69 | ; RF1 SEQ 8-11 are not currently used
|
---|
70 | ; quit with completed RF1 segment
|
---|
71 | Q RETURN
|
---|
72 | ;
|
---|
73 | ADDRCNV(ADDRSRC) ;convert Address Source to HL7 format
|
---|
74 | Q:$G(ADDRSRC)']"" ""
|
---|
75 | Q:ADDRSRC="HEC" "USVAHEC"
|
---|
76 | Q:ADDRSRC="VAMC" "USVAMC"
|
---|
77 | Q:ADDRSRC="HBSC" "USVAHBSC"
|
---|
78 | Q:ADDRSRC="NCOA" "USNCOA"
|
---|
79 | Q:ADDRSRC="BVA" "USVABVA"
|
---|
80 | Q:ADDRSRC="VAINS" "USVAINS"
|
---|
81 | Q:ADDRSRC="USPS" "USPS"
|
---|
82 | Q:ADDRSRC="LACS" "LACS"
|
---|
83 | Q ""
|
---|
84 | ;
|
---|
85 | RF1LOAD(RF1TYP) ;
|
---|
86 | N RFDT,RFSRC,RFSIT,GETFLDS,RFDAT,ERR
|
---|
87 | K ADRDT,ADRSRC,ADRSIT
|
---|
88 | I RF1TYP="SAD" S RFDT=.118,RFSRC=.119,RFSIT=.12
|
---|
89 | I RF1TYP="CAD" S RFDT=.14112,RFSRC="",RFSIT=.14113
|
---|
90 | I RF1TYP="CPH" S RFDT=.139,RFSRC=.1311,RFSIT=.13111
|
---|
91 | I RF1TYP="PNO" S RFDT=.1312,RFSRC=.1313,RFSIT=.1314
|
---|
92 | I RF1TYP="EAD" S RFDT=.136,RFSRC=.137,RFSIT=.138
|
---|
93 | S GETFLDS=RFDT S:RFSRC'="" GETFLDS=GETFLDS_";"_RFSRC S GETFLDS=GETFLDS_";"_RFSIT
|
---|
94 | D GETS^DIQ(2,DFN_",",GETFLDS,"IE","RFDAT","ERR") Q:$D(ERR)
|
---|
95 | S ADRDT=$$FMTHL7^XLFDT($G(RFDAT(2,DFN_",",RFDT,"I")))
|
---|
96 | S:RFSRC'="" ADRSRC=$$EXTERNAL^DILFD(2,RFSRC,"",$G(RFDAT(2,DFN_",",RFSRC,"I")))
|
---|
97 | ; only populate Change Site if Source=VAMC or NO Source Field
|
---|
98 | I ($G(ADRSRC)="VAMC")!(RFSRC="") D
|
---|
99 | . S ADRSIT=$G(RFDAT(2,DFN_",",RFSIT,"I"))
|
---|
100 | . S:ADRSIT]"" ADRSIT=$$GET1^DIQ(4,ADRSIT_",",99)
|
---|
101 | S ADRSRC=$$ADDRCNV($G(ADRSRC)) ;convert source to HL7 format
|
---|
102 | Q
|
---|