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

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

WorldVistAEHR overlayed on FOIAVistA
File size: 9.4 KB
Line 
1DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ;1/27/07 13:12
2 ;;5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647,634**;Aug 13, 1993;Build 28
3 ; Modified from FOIA VISTA,
4 ; Copyright (C) 2007 WorldVistA
5 ;
6 ; This program is free software; you can redistribute it and/or modify
7 ; it under the terms of the GNU General Public License as published by
8 ; the Free Software Foundation; either version 2 of the License, or
9 ; (at your option) any later version.
10 ;
11 ;
12 ; mods made for magstripe read 12/96 - JFP
13 ;
14 ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
15 ; by patch DG*5.3*244
16 ;
17EN ; -- Entry point
18 ;Following line so VOE will use alternate lookup routine, DAOU,VA/CJS,WV/TOAD
19 I $G(DUZ("AG"))'="V" D ^AUPNLK Q
20 N DIE,DR
21 K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D(X)))
22 I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined." G QK
23 I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable to proceed. ",$S('$D(^DPT(0)):"0th node of ^DPT missing",^DD("VERSION")<17.2:"Fileman version must be at least 17.2",1:""),"." G QK
24EN2 K DO,DUOUT,DTOUT S U="^",DIC="^DPT(",DIC(0)=$S($D(DIC(0)):DIC(0),1:"AELMQ") S:DIC(0)'["A" (DPTX,DPTSAVX)=X
25 S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DPTSZ)
26 ;
27ASKPAT ; -- Prompt for patient
28 I DIC(0)["A" D G QK:'$T!($E(DPTX)["^")!(DPTX="")
29 .K DTOUT,DUOUT
30 .W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC("B")) DIC("B"),"// "
31 .R X:DTIME
32 .S DPTX=X S:'$T DTOUT=1 S:$T&(DPTX="")&($D(DIC("B"))) DPTX=DIC("B") S:DPTX["^"&($E(DPTX)'="%") DUOUT=1
33 ; -- Check for the IATA magnetic stripe input
34 N MAG,GCHK
35 S MAG=0
36 I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX)
37 ;
38CHKPAT ; -- Custom Patient Lookup
39 D DO^DIC1
40 S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"")
41 K DPTIFNS,DPTS,DPTSEL
42 S DPTCNT=0
43 ; -- Check input for format an length
44 G CHKDFN:DPTX?1A!(DPTX'?.ANP)!($L(DPTX)>30)
45 ; -- Check for null response or abort
46 I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK
47 ; -- Check for question mark
48 I DPTX["?" D G ASKPAT:DIC(0)["A",QK
49 .S D="B"
50 .S DZ=$S(DPTX?1"?":"",1:"??")
51 .G CHKPAT1:DZ="??"
52 .N %
53 .W !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of"
54 .W " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER"
55 .W !,?1,"Do you want the entire ",+$P($G(^DPT(0)),"^",4),"-Entry PATIENT List" S %=0 D YN^DICN
56 .Q:%'=1
57 .S DZ="??"
58CHKPAT1 .S X=DPTX
59 .D DQ^DICQ
60 ; -- Check for space bar, return
61 I DPTX=" " D G CHKDFN
62 .S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)
63 .D SETDPT^DPTLK1:Y>0
64 .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
65 ; -- Check for DFN look up
66 I $E(DPTX)="`" D G CHKDFN
67 .S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1)
68 .D SETDPT^DPTLK1:Y>0
69 .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
70 ; -- Puts input in correct format
71 G CHKDFN:DPTX=""
72 ; -- Force new entry
73 I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" G NOPAT
74 ; -- Check for index lookups
75 D ^DPTLK1 G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D(DUOUT),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN>0 I DIC(0)["N",$D(^DPT(DPTX,0)) S Y=X D SETDPT^DPTLK1 S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) G CHKDFN
76MAG ; -- No patient found, check for mag stripe input, create stub
77 I 'MAG G NOPAT
78 ; -- Check for ADT option(s) only
79 N DGOPT
80 S DGOPT=$P($G(XQY0),"^",2)
81 I DGOPT'="Load/Edit Patient Data",DGOPT'="Register a Patient" D G EN2
82 .W !," ...Patient not in database, use ADT options to load patient" D Q1
83 ; -- Prompt for creation of stub
84 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Patient not found...Create stub entry: "
85 S GCHK=$D(^TMP("DGVIC"))
86 D ^DIR
87 K DIR
88 I 'Y D Q1 G EN2
89 ; -- Parse IATA fields
90 D FIELDS(IATA)
91 ; -- Check for Duplicates
92 D EP2^DPTLK3
93 I DPTDFN<0 D Q1 G EN2
94 ; -- Creates Stub entry in patient file
95 S Y=$$FILE^DPTLK4(DGFLDS)
96 I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q
97 D QK1
98 Q
99 ;
100NOPAT ; -- No patient found, ask to add new
101 I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A"&(Y<0)&('$G(DTOUT)),QK1
102 ;
103CHKDFN ; --
104 S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN))) W:DIC(0)["Q" *7," ??" G ASKPAT:DIC(0)["A",QK
105 I DIC(0)["E" D W $S('$D(DPTSEL)&('$D(DIVP)):$P(DPTS(DPTDFN),U,2)_" "_$P(DPTS(DPTDFN),U)_" ",$D(^DPT(DPTDFN,0)):" "_$P(^(0),U)_" ",1:"") S Y=DPTDFN X:$D(^DPT(DPTDFN,0)) "N DDS X DIC(""W"")"
106 .I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
107 ;
108 ; check for other patients in "BS5" xref on Patient file
109 I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0
110 .N DPTZERO,DPTLSNME,DPTSSN S DPTZERO=$G(^DPT(+DPTDFN,0)),DPTLSNME=$P($P(DPTZERO,U),","),DPTSSN=$E($P(DPTZERO,U,9),6,9)
111 .W $C(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and"
112 .W !,"whose social security number ends with '",DPTSSN,"'."
113 .W !,"Are you sure you wish to continue (Y/N)" S %=0 D YN^DICN
114 .I %'=1 S DPTDFN=-1
115 ;
116 I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0
117 S DPTX=DPTX_$P(DPTS(DPTDFN),U,2),DPTDFN=DPTDFN_U_$P(^DPT(DPTDFN,0),U)
118 ;
119Q ; --
120 S Y=$S('$D(DPTDFN):-1,'$D(DPTS(+DPTDFN)):-1,1:DPTDFN),X=$S($D(DPTX)&(+Y>0):DPTX,$D(DPTSAVX):DPTSAVX,$D(DPTX):DPTX,1:"")
121 I Y>0 S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y S:DIC(0)["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1)
122 ;DG*600
123 ;I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning : You have selected a test patient."
124 I DIC(0)["E",$$TESTPAT^VADPT(+Y) W *7,!,"WARNING : You may have selected a test patient."
125 I DIC(0)["E",$$BADADR^DGUTL3(+Y) W *7,!,"WARNING : ** This patient has been flagged with a Bad Address Indicator."
126 I DIC(0)["E",$$VAADV^DPTLK3(+Y) W *7,!,"** Patient is VA ADVANTAGE."
127 ;DG*485
128 I $D(^DPT("AXFFP",1,+Y)) D FFP^DPTLK5
129 ;Display enrollment information
130 I Y>0,DIC(0)["E" D ENR
131 ;
132 ;Call Combat Vet check
133 I Y>0,DIC(0)["E" D CV
134 ;
135 ; check whether to display Means Test Required message
136 D
137 .N DPTDIV
138 .I '$G(DUZ(2)) Q
139 .I Y>0,DIC(0)["E" S DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2)) I DPTDIV D
140 ..W $C(7),!!,"MEANS TEST REQUIRED"
141 ..W !,?3,$P($G(^DG(40.8,DPTDIV,"MT")),U,2)
142 ..H 2
143 ;
144Q1 ; -- Clean up variables
145 K D,DIC("W"),DO,DPTCNT,DPTDFN,DPTIFNS,DPTIX,DPTS
146 K DPTSAVX,DPTSEL,DPTSZ,DPTX
147 ;
148 K:$D(IATA) IATA
149 K:$D(DGFLDS) @DGFLDS,DGFLDS
150 Q
151 ;
152QK K:'$D(DPTNOFZK) DPTNOFZY G Q
153 ;
154QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1
155 ;
156IX ; --
157 I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D
158 G DPTLK
159 ;
160IATA(X) ; --
161 ;This function pulls off ssn from the IATA track
162 ;
163 ;Input: X - what was read in
164 ;Output: SSN - social security number
165 ; Q - quit
166 ;
167 ; Track Start Sent End Sent Field Separator
168 ; ----- ---------- -------- ---------------
169 ; IATA (alphanum) % ? { (Note: VA used ^)
170 ; ABA (numeric) ; ? =
171 ;
172 ;N IATA
173 S (IATA)=""
174 I $E(X)'="%" Q X ; no start sentinel
175 I X'["?" Q "Q"
176 ; -- Extract data from track
177 S IATA=$$TRACK(X,"%","?")
178 ; -- checks for no data
179 I IATA="" Q "Q"
180 ; -- Returns SSN
181 I IATA'="" Q $P(IATA,"^")
182 Q "Q"
183 ;
184TRACK(X,START,END) ; find track where start/end are sentinels
185 ;
186 Q $P($P($G(X),START,2),END,1)
187 ;
188FIELDS(IATA) ; -- Sets fields
189 Q:'$D(IATA)
190 N CNT,FIELD
191 S DGFLDS="^TMP(""DGVIC"","_$J_")",CNT=1
192 K @DGFLDS
193 F S FIELD=$P($G(IATA),"^",CNT) Q:FIELD="" D
194 .S @DGFLDS@(CNT)=FIELD
195 .S CNT=CNT+1
196 ; -- Define fields for duplicate checker
197 S DPTX=$G(@DGFLDS@(2)) ;NAME
198 S DPTIDS(.03)=$G(@DGFLDS@(3)) ;DOB
199 S DPTIDS(.09)=$G(@DGFLDS@(1)) ;SSN
200 Q
201ENR ;Display Enrollment information after patient selection
202 N DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT
203 I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) Q
204 S DGENCAT=$$CATEGORY^DGENA4(+DPTDFN)
205 S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)
206 W !?1,"Enrollment Priority: ",$S($G(DGENR("PRIORITY")):$$EXT^DGENU("PRIORITY",DGENR("PRIORITY")),1:""),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP"))))
207 W ?33,"Category: ",DGENCAT
208 W ?57,"End Date: ",$S($G(DGENR("END")):$$FMTE^XLFDT(DGENR("END"),"5DZ"),1:""),!
209 ;If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible Project Phase I)
210 I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS"))=20) D
211 . W ?1,"Enrollment Status: ",$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"") ;H 5
212 ;check for Combat Veteran Eligibility, if elig do not display EGT info
213 I $$CVEDT^DGCV(+DPTDFN) Q
214 ;Get Enrollment Group Threshold Priority and Subgroup
215 S DGEGTIEN=$$FINDCUR^DGENEGT
216 S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
217 Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="")
218 ;Compare Patient's Enrollment Priority to Enrollment Group Threshold
219 I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT("PRIORITY"),DGEGT("SUBGRP")) D
220 .N X,IORVOFF,IORVON
221 .S X="IORVOFF;IORVON"
222 .D ENDR^%ZISS
223 .W !?32 W:$D(IORVON) IORVON W "*** WARNING ***" W:$D(IORVOFF) IORVOFF
224 .I DGENR("END")'="" W !?14 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT END",$S(DT>+DGENR("END"):"ED",1:"S")," EFFECTIVE ",$$FMTE^XLFDT(DGENR("END"),"5DZ")," ***" W:$D(IORVOFF) IORVOFF Q
225 .W !?5 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT ENDING. ENROLLMENT END DATE IS NOT KNOWN. ***" W:$D(IORVOFF) IORVOFF
226 Q
227CV ;check for Combat Vet status
228 N DGCV
229 S DGCV=$$CVEDT^DGCV(+DPTDFN)
230 I $P(DGCV,U)=1 D Q
231 . I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W !
232 . W ?3,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
233 Q
Note: See TracBrowser for help on using the repository browser.