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

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

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