source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENUPL2.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.3 KB
Line 
1DGENUPL2 ;ALB/CJM,RTK,TMK,ISA/KWP/RMM/CKN,EG,TDM,ERC - PROCESS INCOMING (Z11 EVENT TYPE) HL7 MESSAGES ; 9/18/06 4:38pm
2 ;;5.3;REGISTRATION;**147,222,232,310,314,367,397,677,631,675,672,673,716,653**;Aug 13,1993;Build 2
3 ;
4 ;**************************************************************
5 ;The following procedures parse particular segment types.
6 ;Input:SEG(),MSGID
7 ;Output:DGPAT(),DGELG(),DGENR(),DGCDIS(),DGNTR(),DGOEIF(),ERROR
8 ;**************************************************************
9 ;
10PID ;
11 S DGPAT("SSN")=SEG(19)
12 Q
13 ;
14ZPD ;
15 S DGELG("RATEINC")=$$CONVERT^DGENUPL1(SEG(8))
16 S DGPAT("DEATH")=$$CONVERT^DGENUPL1(SEG(9),"TS",.ERROR)
17 I ERROR D Q
18 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 9",.ERRCOUNT)
19 S DGELG("MEDICAID")=$$CONVERT^DGENUPL1(SEG(12))
20 S DGELG("MEDASKDT")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
21 I ERROR D Q
22 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZPD SEGMENT, SEQ 13",.ERRCOUNT)
23 S DGELG("POW")=$$CONVERT^DGENUPL1(SEG(17))
24 S DGPAT("EMGRES")=$$CONVERT^DGENUPL1(SEG(40)) ;DG*5.3*677
25 Q
26 ;
27ZIE ;
28 S DGPAT("INELDATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
29 I ERROR D Q
30 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZIE SEGMENT, SEQ 2",.ERRCOUNT)
31 S DGPAT("INELREA")=$$CONVERT^DGENUPL1(SEG(3))
32 S DGPAT("INELDEC")=$$CONVERT^DGENUPL1(SEG(4))
33 Q
34 ;
35ZIO ;New segment - DG*5.3*653
36 D ZIO^DGENUPLA ;Code for ZIO has moved to DGENUPLA
37 Q
38 ;
39ZEL(COUNT) ;
40 D ZEL^DGENUPLA(COUNT) ;code for ZEL segment has moved to DGENUPLA
41 Q
42 ;
43ZEN ;
44 N SUB
45 S DGENR("DATE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
46 I ERROR D Q
47 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 2",.ERRCOUNT)
48 S DGENR("SOURCE")=$$CONVERT^DGENUPL1(SEG(3))
49 S DGENR("STATUS")=$$CONVERT^DGENUPL1(SEG(4))
50 S ERROR=$$PEND(DFN,DGENR("STATUS"))
51 I ERROR D Q
52 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ENROLLMENT STATUS PENDING-ELIGIBILITY IS VERIFIED",.ERRCOUNT)
53 S DGENR("REASON")=$$CONVERT^DGENUPL1(SEG(5))
54 S DGENR("REMARKS")=$$CONVERT^DGENUPL1(SEG(6))
55 S DGENR("FACREC")=$$CONVERT^DGENUPL1(SEG(7),"INSTITUTION",.ERROR)
56 I ERROR D Q
57 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY RECEIVED "_SEG(7)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
58 S DGPAT("PREFAC")=$$CONVERT^DGENUPL1(SEG(8),"INSTITUTION",.ERROR)
59 I ERROR D Q
60 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"PREFERRED FACILITY "_SEG(8)_" NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
61 ;
62 S DGENR("PRIORITY")=$$CONVERT^DGENUPL1(SEG(9))
63 S DGENR("EFFDATE")=$$CONVERT^DGENUPL1(SEG(10),"DATE",.ERROR)
64 I ERROR D Q
65 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 10",.ERRCOUNT)
66 S DGENR("APP")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
67 I ERROR D Q
68 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 11",.ERRCOUNT)
69 ;
70 ;!!!!!! take next line out when HEC begins transmitting application dt
71 I DGENR("APP")="" S DGENR("APP")=DGENR("DATE")
72 I DGENR("APP")="" S DGENR("APP")=DGENR("EFFDATE")
73 ;
74 S DGENR("END")=$$CONVERT^DGENUPL1(SEG(12),"DATE",.ERROR)
75 I ERROR D Q
76 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZEN SEGMENT, SEQ 12",.ERRCOUNT)
77 ;Phase II Parse out Sub-Group (SRS 6.4)
78 S DGENR("SUBGRP")=$$CONVERT^DGENUPL1(SEG(13))
79 ;
80 ;want to ignore double quotes sent for enrollment fields
81 S SUB=""
82 F S SUB=$O(DGENR(SUB)) Q:SUB="" I DGENR(SUB)="@" S DGENR(SUB)=""
83 ;
84 Q
85 ;
86ZMT ;
87 I SEG(1)>1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"ZMT SEGMENT, SEQ 1, SHOULD SPECIFY MEANS TEST",.ERRCOUNT) S ERROR=1 Q
88 S DGELG("MTSTA")=$$CONVERT^DGENUPL1(SEG(3),"MT",.ERROR)
89 I ERROR D Q
90 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZMT SEGMENT, SEQ 3",.ERRCOUNT)
91 Q
92 ;
93ZCD ;
94 ;Phase II for multiple ZCD's
95 I SEG(1)>1 G SKIP
96 S DGCDIS("BY")=$$CONVERT^DGENUPL1(SEG(3))
97 S DGCDIS("DATE")=$$CONVERT^DGENUPL1(SEG(5),"DATE",.ERROR)
98 I ERROR D Q
99 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 5",.ERRCOUNT)
100 S DGCDIS("FACDET")=$$CONVERT^DGENUPL1(SEG(4),"INSTITUTION",.ERROR)
101 I ERROR D Q
102 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"FACILITY "_SEG(4)_" MAKING CATASTROPHIC DISABILITY DETERMINATION NOT FOUND IN THE INSTITUTION FILE",.ERRCOUNT)
103 S DGCDIS("REVDTE")=$$CONVERT^DGENUPL1(SEG(2),"DATE",.ERROR)
104 I ERROR D Q
105 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 2",.ERRCOUNT)
106 S DGCDIS("METDET")=$$CONVERT^DGENUPL1($P(SEG(6),$E(HLECH)))
107 S DGCDIS("VCD")=$$CONVERT^DGENUPL1(SEG(12))
108 ;SEQ 14 - DATE VETERAN REQUESTED CD EVALUATION
109 S DGCDIS("VETREQDT")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
110 I ERROR D Q
111 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 14",.ERRCOUNT)
112 ;SEQ 15 - DATE FACILITY INITIATED REVIEW
113 S DGCDIS("DTFACIRV")=$$CONVERT^DGENUPL1(SEG(15),"DATE",.ERROR)
114 I ERROR D Q
115 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 15",.ERRCOUNT)
116 ;SEQ 16 - DATE VETERAN WAS NOTIFIED
117 S DGCDIS("DTVETNOT")=$$CONVERT^DGENUPL1(SEG(16),"DATE",.ERROR)
118 I ERROR D Q
119 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZCD SEGMENT, SEQ 16",.ERRCOUNT)
120SKIP ;
121 ;Phase II Parse out additional fields. CONVERT type of RSN converts the code to IEN for diagnosis,procedure and condition (HL7TORSN^DGENA5).
122 S DGCDIS("DIAG",SEG(1))=$$CONVERT^DGENUPL1(SEG(7),"CDRSN")
123 S DGCDIS("PROC",SEG(1))=$$CONVERT^DGENUPL1(SEG(8),"CDRSN")
124 S DGCDIS("EXT",SEG(1),1)=$$CONVERT^DGENUPL1($P(SEG(9),$E(HLECH)),"EXT")
125 S DGCDIS("COND",SEG(1))=$$CONVERT^DGENUPL1(SEG(10),"CDRSN")
126 S DGCDIS("SCORE",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(11),$E(HLECH)))
127 S DGCDIS("PERM",SEG(1))=$$CONVERT^DGENUPL1($P(SEG(13),$E(HLECH)))
128 I DGCDIS("VCD")="Y",'DGCDIS("DIAG",SEG(1)),'DGCDIS("PROC",SEG(1)),'DGCDIS("COND",SEG(1)) D Q
129 .S ERROR=1 D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"NO VALID DIAGNOSIS,PROCEDURE, OR CONDITION IN THE ZCD SEGMENT",.ERRCOUNT)
130 Q
131 ;
132ZSP ;
133 S DGELG("SC")=$$CONVERT^DGENUPL1(SEG(2),"Y/N",.ERROR)
134 I ERROR D Q
135 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 2",.ERRCOUNT)
136 S DGELG("SCPER")=$$CONVERT^DGENUPL1(SEG(3))
137 S DGELG("POS")=$$CONVERT^DGENUPL1(SEG(4),"POS",.ERROR)
138 I ERROR D Q
139 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 4",.ERRCOUNT)
140 S DGELG("EFFDT")=$$CONVERT^DGENUPL1(SEG(11),"DATE",.ERROR)
141 I ERROR D Q
142 . D ADDERROR^DGENUPL(MSGID,$G(DGELG("EFFDT")),"BAD VALUE, ZSP SEGMENT, SEQ 11",.ERRCOUNT)
143 ;if effective date is null, set update value to "@" (delete)
144 I DGELG("EFFDT")="" S DGELG("EFFDT")="@"
145 ;
146 ;added 8/3/98 to reduce #rejects
147 ;if HEC sends SC=NO, SC% not sent, and site has value for SC% then delete it
148 I DGELG("SC")="N",DGELG("SCPER")="" S DGELG("SCPER")="@"
149 ;
150 S DGELG("P&T")=$$CONVERT^DGENUPL1(SEG(6),"Y/N",.ERROR)
151 I ERROR D Q
152 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 6",.ERRCOUNT)
153 S DGELG("UNEMPLOY")=$$CONVERT^DGENUPL1(SEG(7),"Y/N",.ERROR)
154 I ERROR D Q
155 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 7",.ERRCOUNT)
156 S DGELG("SCAWDATE")=$$CONVERT^DGENUPL1(SEG(8),"DATE",.ERROR)
157 I ERROR D Q
158 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZSP SEGMENT, SEQ 8",.ERRCOUNT)
159 Q
160 ;
161ZMH ;Purple Heart, OEFOIE, POW
162 D ZMH^DGENUPL3 ;Moved to DGENUPL3 - DG*5.3*653
163 Q
164 ;
165ZRD ;
166 N COUNT,DXCODE,NAME,COND
167 S DXCODE=$P(SEG(2),$E(HLECH))
168 I DXCODE="""""" S DXCODE=""
169 S NAME=$P(SEG(2),$E(HLECH),2)
170 Q:DXCODE="" ;segment does not contain a disability condition
171 ;
172 S COUNT=1+(+$G(DGELG("RATEDIS")))
173 S (COND,DGELG("RATEDIS",COUNT,"RD"))=$$DCLOOKUP(DXCODE,NAME)
174 S DGELG("RATEDIS",COUNT,"PER")=SEG(3),DGELG("RATEDIS")=COUNT
175 S DGELG("RATEDIS",COUNT,"RDEXT")=SEG(12)
176 S DGELG("RATEDIS",COUNT,"RDORIG")=$$CONVERT^DGENUPL1(SEG(13),"DATE",.ERROR)
177 I ERROR D Q
178 . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 13",.ERRCOUNT)
179 S DGELG("RATEDIS",COUNT,"RDCURR")=$$CONVERT^DGENUPL1(SEG(14),"DATE",.ERROR)
180 I ERROR D Q
181 . D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, S 14",.ERRCOUNT)
182 I 'COND D Q
183 .D ADDERROR^DGENUPL(MSGID,$G(DGPAT("SSN")),"BAD VALUE, ZRD SEGMENT, SEQ 2 - DISABILTY CONDITION LOOKUP FAILED",.ERRCOUNT)
184 .S ERROR=1
185 Q
186OBX ;
187 D OBX^DGENUPLA ;code for OBX segment moved to DGENUPLA
188 Q
189 ;
190 ;*********** end of segment parsers ****
191 ;
192DCLOOKUP(DGCODE,DGNAME) ;
193 ;Description: Returns the ien of a Disability Condition (file #31) based on the DGCODE and DGNAME
194 ;
195 ;Input:
196 ; DGCODE - DX Code of the Disability Condition
197 ; DGNAME - name of the Disability Condition
198 ;Output:
199 ; Function Value: ien of the entry found, or 0 otherwise
200 ;
201 Q:(DGCODE="") 0
202 N NODE,IEN,FOUND
203 S (FOUND,IEN)=0
204 F S IEN=$O(^DIC(31,"C",DGCODE,IEN)) Q:'IEN D Q:FOUND
205 .S NODE=$G(^DIC(31,IEN,0))
206 .I DGNAME=$P(NODE,"^"),DGCODE=$P(NODE,"^",3) S FOUND=1
207 I 'FOUND S IEN=$O(^DIC(31,"C",DGCODE,0))
208 Q +IEN
209 ;
210REGCHECK(DFN) ;
211 ; Description: passes patient through the registration consistency checker
212 ;Input -
213 ; DFN - is a pointer to the Patient File
214 ;
215 N DGCD,DGCHK,DGDAY,DGEDCN,DGER,DGLST,DGNCK,DGRPCOLD,DGSC,DGTYPE,DGVT,VA,X
216 ;
217 S DGEDCN=0
218 D ^DGRPC
219 Q
220PEND(DFN,DGSTAT) ;
221 N DGARR,DGEC,DGERR,DGX
222 I $P($G(^DPT(DFN,.361)),U)'="V" Q 0
223 I $G(DGSTAT)']"" Q 0
224 S DGSTAT="^"_DGSTAT_"^"
225 Q:"^15^17^"'[DGSTAT 0
226 D GETS^DIQ(2,DFN_",",".301;.302;.361;.36295","IE","DGARR","DGERR")
227 I $D(DGERR) Q 0
228 S DGEC=$G(DGARR(2,DFN_",",.361,"I"))
229 I $G(DGEC)']"" Q 0
230 S DGEC=$P($G(^DIC(8,DGEC,0)),U,9)
231 I $G(DGEC)']"" Q 0
232 I DGEC=5 Q 1
233 I DGEC=3 D Q DGX
234 . S DGX=1
235 . I $G(DGARR(2,DFN_",",.301,"I"))'="Y" S DGX=0 Q
236 . I +$G(DGARR(2,DFN_",",.302,"I"))>0 S DGX=0 Q
237 . I +$G(DGARR(2,DFN_",",.36295,"I"))>0 S DGX=0 Q
238 Q 0
Note: See TracBrowser for help on using the repository browser.