source: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACVDEM.m@ 1579

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

initial load of WorldVistAEHR
File size: 6.2 KB
Line 
1QACVDEM ;PGB - RPC TO RETRIEVE DEMO/ELIG/ENROLLMENT PATIENT DATA ;8/3/05 14:13
2 ;;2.0;Patient Representative;**19**;07/25/1995;Build 55
3 ;
4EN(PATSBY,DFN) ; (deprecated 08/03/2005)
5 ; (note: this entry point will be replaced with calls to
6 ; Patient Service Demographics service 08/03/2005)
7 S PATSBY=$NA(^TMP("PatsPatientDetailsXml",$J))
8 N CNT,TXT
9 S DFN=+$G(DFN),CNT=0,TXT=""
10 I '$G(DFN)!('$D(^DPT(DFN,0))) QUIT
11 S TXT="<?xml version=""1.0"" encoding=""utf-8""?>"
12 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
13 S TXT="<PatientDataSet xmlns=""http://tempuri.org/PatientDataSet.xsd"">"
14 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
15 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)="<PatsPatient>"
16 D DEMOG(DFN,.CNT)
17 D ELIG(DFN,.CNT)
18 D ENROLL(DFN,.CNT)
19 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)="</PatsPatient>"
20 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)="</PatientDataSet>"
21 QUIT
22 ;
23DEMOG(DFN,CNT) ;
24 ;Retrieve: Full Name (.01)
25 ; Name Components (Last,First,Middle,Pre,Suffix,Degree
26 ; Gender(.02);
27 ; Date of Birth (.03)
28 ; SSN (.09)
29 ; ICN (991.01)
30 ; RACE (2)
31 ; ETHNICITY (6)
32 N FILE,ICNO,SSN,TXT,ARR,TAGO,TAGC,VADM
33 N YYYY,MM,DD,DOB,RACE,ETH
34 S (SNN,ARR,TXT,YYYY,MM,DD,ETH)=""
35 D NAMEC(DFN_",",.CNT) ;Get individual name components
36 ; Get patient demographics and load into output (IA #10061)
37 D DEM^VADPT
38 S TXT="<Gender>"_$P(VADM(5),"^")_"</Gender>"
39 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
40 S DOB=$$CONVDATE($P(VADM(3),"^"))
41 I DOB'="" D
42 .S TXT="<DateOfBirth>"_DOB_"</DateOfBirth>"
43 .S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
44 S TAGO="<SocialSecurityNumber>",TAGC="</SocialSecurityNumber>"
45 S SSN=$P(VADM(2),"^")
46 S TXT=TAGO_$E(SSN,1,9)_TAGC
47 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
48 S TAGO="<IsPseudoSsn>",TAGC="</IsPseudoSsn>"
49 S TXT=TAGO_"false"_TAGC
50 I SSN["P" S TXT=TAGO_"true"_TAGC
51 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
52 ; Get race and ethnicity data (IA #3799)
53 D RACETH(.VADM,.RACE,.ETH)
54 I ETH]"" D
55 . S TXT="<Ethnicity>"_ETH_"</Ethnicity>"
56 . S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
57 . Q
58 F I=0:0 S I=$O(RACE(I)) Q:'I D
59 . S TXT="<Race>"_RACE(I)_"</Race>"
60 . S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
61 . Q
62 ; Get integration control number (IA #2701)
63 S ICNO=$P($$GETICN^MPIF001(DFN),"^")
64 S TAGO="<IntegrationControlNumber>",TAGC="</IntegrationControlNumber>"
65 I ICNO'="" D
66 .S TXT=TAGO_ICNO_TAGC
67 .S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
68 QUIT
69 ;
70NAMEC(DFN,CNT) ;Name from Name Component File (#20) (IA #3065)
71 ;Retrieve: LastName(1)
72 ; FirstName(2)
73 ; MiddleName(3)
74 ; Prefix(4)
75 ; Suffix(5)
76 ; Degree(6)
77 N DGNAMEC,DPTNAME,DGFLD,TXT,NAMEC,DGII,TAGO,TAGC
78 S DPTNAME("FILE")=2,DGFLD=1,DPTNAME("FIELD")=".01",DPTNAME("IENS")=DFN
79 S NAMEC=$$HLNAME^XLFNAME(.DPTNAME,"S","^") ;IA #3065
80 F DGII=1:1:6 D
81 .S $P(DGNAMEC,U,DGFLD)=$P(NAMEC,U,DGII)
82 .S DGFLD=DGFLD+1
83 S TXT="<LastName>"_$P(DGNAMEC,U,1)_"</LastName>"
84 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
85 S TXT="<FirstName>"_$P(DGNAMEC,U,2)_"</FirstName>"
86 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
87 S TXT="<MiddleName>"_$P(DGNAMEC,U,3)_"</MiddleName>"
88 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
89 S TXT="<NameSuffix>"_$P(DGNAMEC,U,4)_"</NameSuffix>"
90 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
91 S TXT="<NamePrefix>"_$P(DGNAMEC,U,5)_"</NamePrefix>"
92 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
93 S TXT="<Degree>"_$P(DGNAMEC,U,6)_"</Degree>"
94 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
95 QUIT
96 ;
97ELIG(DFN,CNT) ;
98 ;Retrieve: Eligibility (.361)
99 ; Service Connected (.301)
100 ; SC Percent (.302)
101 ; Period of Service (.323)
102 ; Category (current means test status .14)
103 N VAEL,FILE,TXT,ARR,TAGO,TAGC,ISSC,SCP,X
104 S FILE=2,(ARR,TXT,SCP)=""
105 ; (IA #10061 - NOTE: does not remove reserved XML characters (see $$SYMENC^MXMLUTL, IA#4153))
106 D ELIG^VADPT
107 S DFN=DFN_","
108 S TAGO="<EligibilityCode>",TAGC="</EligibilityCode>"
109 S X=$P(VAEL(1),"^",2)
110 S TXT=TAGO_X_TAGC
111 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
112 S ISSC="false"
113 I $P(VAEL(3),"^",1)=1 S ISSC="true"
114 S TAGO="<IsServiceConnected>",TAGC="</IsServiceConnected>"
115 S TXT=TAGO_ISSC_TAGC
116 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
117 S TAGO="<ServiceConnectedPercentage>"
118 S TAGC="</ServiceConnectedPercentage>"
119 I ISSC="true" S SCP=$P(VAEL(3),"^",2)
120 I SCP'="" D
121 .S TXT=TAGO_SCP_TAGC
122 .S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
123 S TAGO="<PeriodOfService>",TAGC="</PeriodOfService>"
124 S X=$P(VAEL(2),"^",2)
125 S TXT=TAGO_X_TAGC
126 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
127 S TAGO="<Category>",TAGC="</Category>"
128 S X=$P(VAEL(9),"^",2)
129 S TXT=TAGO_X_TAGC
130 S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
131 QUIT
132 ;
133ENROLL(DFN,CNT) ;
134 ;Retrieve: Enrollment Priority (#27.01-->#27.11,.07)
135 N ENRP,TAGO,TAGC
136 S TAGO="<EnrollmentPriority>",TAGC="</EnrollmentPriority>"
137 S ENRP=$$GETENRL(DFN)
138 I ENRP'="" D
139 .S TXT=TAGO_ENRP_TAGC
140 .S CNT=CNT+1,^TMP("PatsPatientDetailsXml",$J,CNT)=TXT
141 QUIT
142GETENRL(DFN) ; Return current enrollment priority for this patient
143 N CUR,QACX
144 ; Get current enrollment (IA #2918)
145 S CUR=$$PRIORITY^DGENA(DFN) Q:CUR="" ""
146 ; Convert internal to external enrollment priority (IA #2462)
147 S QACX=$$EXTERNAL^DILFD(27.11,.07,,CUR)
148 Q QACX
149 ;
150RACETH(VADM,RACE,ETH) ; Return active race and ethnicity values
151 N I,J,TXT S ETH=""
152 ; Get Ethnicity abbreviation.
153 S I=$O(VADM(11,0)) D:I
154 . S ETH=$P($G(VADM(11,I)),"^")
155 . I 'ETH S ETH="" Q
156 . Q:$$INACTIVE^DGUTL4(ETH,2)
157 . S ETH=$$PTR2CODE^DGUTL4(ETH,2,1)
158 . Q
159 ; Get historical race HL7 code.
160 S J=0 K RACE
161 S RACE=$P($G(VADM(8)),"^") D:RACE RACE(.RACE,.J)
162 ; Get new race HL7 codes.
163 F I=0:0 S I=$O(VADM(12,I)) Q:'I D
164 . S RACE=$P($G(VADM(12,I)),"^") Q:'RACE
165 . D RACE(.RACE,.J) Q
166 Q
167 ;
168RACE(RACE,CNT) ; Return race
169 Q:$$INACTIVE^DGUTL4(RACE,1)
170 N X S X=$$PTR2CODE^DGUTL4(RACE,1,2) Q:X=""
171 S CNT=CNT+1,RACE(CNT)=X Q
172 ;
173CONVDATE(OLDDATE) ; Convert data to MM/DD/YYYY format
174 Q:OLDDATE="" ""
175 N MM,DD S MM=$E(OLDDATE,4,5),DD=$E(OLDDATE,6,7)
176 S:MM="00" MM="01"
177 S:DD="00" DD="01"
178 Q $E(OLDDATE,1,3)+1700_"-"_MM_"-"_DD
Note: See TracBrowser for help on using the repository browser.