source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT2.m@ 861

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

revised back to 6/30/08 version

File size: 7.4 KB
Line 
1ORWPT2 ; VOE//GT/GOW REV - Patient Lookup Functions ;8/13/07 17:45
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 28
3 ; Copyright (C) 2007 WorldVistA
4 ;
5 ; This program is free software; you can redistribute it and/or modify
6 ; it under the terms of the GNU General Public License as published by
7 ; the Free Software Foundation; either version 2 of the License, or
8 ; (at your option) any later version.
9 ;
10 ; This program is distributed in the hope that it will be useful,
11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ; GNU General Public License for more details.
14 ;
15 ; You should have received a copy of the GNU General Public License
16 ; along with this program; if not, write to the Free Software
17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
18 ;
19 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06
20 ;GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP
21 ; Ref. to ^UTILITY via IA 10061
22 ;
23 Q
24 ;VWVOEDPT ;GFT VOE PATIENT LOOKUP;6OCT2006
25 ;;5.3;Registration;VWVF VOE LOCAL
26 ;
27 ;;Q
28 ;
29LOOKUP(LST,X1) ;'GFT PATIENT LOOKUP' RPC CALLS HERE FOR GENERAL PATIENT LOOKUP
30 K LST
31 N GFTI,I,X,ILEN,IEN2,IENN,TAB,ILENP,X3,IEND,CR,XX
32 N IRET
33 N IDTMP,AJJTMP,AJJTMP1
34 ;
35 S X=X1
36 I X="" Q
37 S IEND=0
38 ;UPPERCASE IT
39 X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
40 S ILEN=$L(X)
41 ;CHECK INPUT TAB POSTION 20, 25, 30 WITH PRECEDING TRAILING BLANKS
42 ;CHECK FOR INITITAL LOOKUP BY DFN AS !DFN
43 ;CHECK FOR LOOKUP BY DFN AS 3 TAB POSITION FOR CLICKING AFTER PREVIOUS LOOKUP
44 S TAB=$C(9)
45 S X3=$P(X,TAB,3)
46 I X3'="",X3'="OPT" D
47 .S X=X3
48 .S ILENP=$L(X)
49 .S X=$E(X,2,ILENP) ;TAKEOUT !
50 .S U="^",(GFTI,I)=0
51 .D LISTPOPD(X)
52 .S IEND=1
53 E D
54 .S X=$P(X,TAB,1)
55 I IEND=1 Q
56 I $E(X1,1,1)="'" D
57 .I ILEN'=1 S X=$E(X1,2,ILEN)
58 .;CHECK FOR ENDING "'"
59 .S CR=$C(13)
60 .I $E(X1,ILEN,ILEN)'="'" S IEND=1
61 .S X=$P(X,"'",1)
62 S U="^",(GFTI,I)=0
63 I IEND=1 Q
64 S XX=X ; NO CR FOR HRN
65 F S IRET=$$CHKX(X) Q:IRET'=1 S I=$O(^AUPNPAT("D",X,I)) Q:'I I X=$$HRN^DGLBPID(I) D LISTPOPH(I) ;I X=$P($$HRN^DGLBPID(I),"#",2
66 Q:GFTI
67 ;
68 S X=XX
69 ;NOW CHECK FOR B CROSS REFERENCE
70 D FIND^DIC(2,,,"MPC",X,,"B") ; ^SSN^BS5")
71 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOPB(+^(I,0))
72 K ^TMP("DILIST",$J)
73 Q:GFTI>0
74OVETT ;
75 Q:ILEN<4 ;USE ADOB LOOKUP XXX-
76 ;
77 ;
78 ;
79 ; NEW EDITS/GOW 8/12/07 BELOW. CHECK TO PREVENT ASSUMED CURRENT YEAR TRIGGER
80 ; SELECTION AUTOMATICALLY WITH JUST MONTH DAY OR MM/DD INPUT. REQUIRE REMAINING YR ( 2 DIGIT MINIMUM)
81 ; WE CAN USE NUMERIC ENTRY ( IE 2-3-56, 2/3/56 OR 2.3.56, JUN 12,68, ETC OR 4 DIGIT YEAR FOR EXPLICIT YEAR ENTRY, IE JUNE 1,1903
82 S NOCONTIN=0
83 D
84 .S NOCONTIN=1
85 .S IDTMP=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),1,30)
86 .I IDTMP'=X D
87 ..S AJJTMP=$L($TR($P(X,",",2)," ")) I AJJTMP>1 S NOCONTIN=0 Q ;CASE FOR SPECIFIC DATE ENTRY BY ALPHABETIC MONTH DAY AND "," AND AT LEAST 2 YR DATE
88 ..S AJJTMP=$L($TR($P(X," ",2),",")) I AJJTMP>3 S NOCONTIN=0 Q ;CASE FOR SPECIFIC ( MONTH DAY followed by " " (space) and Year ( 2 or4 digit yr)
89 .I IDTMP'=X Q ; ALPHABETICAL DATE OF SOME KIND WHICH HAS BEEN TESTED ALREADY
90 .S AJJTMP=$L($TR($P(X,"-",3)," ")) I AJJTMP>1 S NOCONTIN=0 ;NUMERIC INPUT
91 .S AJJTMP=$L($TR($P(X,"/",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT
92 .S AJJTMP=$L($TR($P(X,".",3)," ")) I AJJTMP>1 S NOCONTIN=0 ; NUMERIC INPUT
93 I NOCONTIN=1 G TRYPH ; TRY PHONE #
94 ;END EDITS/GOW
95 ;
96 ;
97 D FIND^DIC(2,,,"MPC",X,,"ADOB^B") ;^SSN^BS5")
98 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOP(+^(I,0),X1)
99 K ^TMP("DILIST",$J)
100 Q:GFTI>0
101 ;TRY PHONE # WITH TRANSLATE
102TRYPH ;
103 Q:ILEN<10
104 S X=$E($TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30)
105 D FIND^DIC(2,,,"MPC",X,,"AZVWVOE^B") ;^SSN^BS5")
106 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I D LISTPOPP(+^(I,0),X1)
107 K ^TMP("DILIST",$J)
108 Q
109CHKX(X) ;CHECK TO SEE IF LEGITIMATE HRN EXISTS FOR IHS PATIENT HRN
110 N IDX,ILENM1,IFLAG
111 S IFLAG=0
112 S IDX=X
113 ;TO SEE blank char inserts
114 S ILENM1=$L(X)-1
115 I ILENM1>0 D
116 .S IDX=$E(X,1,ILENM1)
117 E D
118 .S IDX=""
119 F S IDX=$O(^AUPNPAT("D",IDX)) Q:(IDX="")!(IFLAG=1) D
120 . I IDX=X S IFLAG=1
121 Q IFLAG
122CHKXB(X1) ;CHECK TO SEE IF PATIENT NAME ENTERED TO ALLOW LOOKUP EVEN FOR SENSITIVE PATIENT
123 N IDX,ILENM1,IFLAG,X
124 S IFLAG=0
125 S X=X1
126 ;CONVERT UPPER CASE
127 X "F %=1:1:$L(X) S:$E(X,%)?1L X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)"
128 S IDX=X
129 ;TO SEE blank char inserts
130 S ILENM1=$L(X)-1
131 I ILENM1>0 D
132 .S IDX=$E(X,1,ILENM1)
133 E D
134 .S IDX=""
135 F S IDX=$O(^DPT("B",IDX)) Q:(IDX="")!(IFLAG=1) D
136 . I IDX=X S IFLAG=1
137 Q IFLAG
138LISTPOPB(DFN) ;PATIENT NAME B X-REF
139 N IEN
140 N HRN,PHONE,X
141 Q:($$SCREEN^DPTLK1(DFN)) ;SCREEN FOR VIP
142 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
143 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
144 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
145 Q
146LISTPOP(DFN,X1) ;DOB
147 N IEN
148 N HRN,PHONE,X
149 S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK
150 Q:($$SCREEN^DPTLK1(DFN))&(IEN=0) ;SCREEN FOR VIP
151 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
152 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
153 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
154 Q
155LISTPOPP(DFN,X1) ;PHONE #
156 N IEN
157 N HRN,PHONE,X
158 S IEN=$$CHKXB(X1) ;ALLOW INPUT BY NAME ON CLICK
159 Q:($$SCREEN^DPTLK1(DFN))&(IEN=0) ;SCREEN FOR VIP
160 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
161 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
162 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_PHONE_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
163 Q
164 ;
165LISTPOPH(DFN) ;Q:$$SCREEN^DPTLK1(DFN) ;SCREEN FOR VIP FOR HRN
166 N HRN,PHONE
167 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
168 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
169 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_"'"_HRN_"'"_TAB_"!"_DFN_U_$$FMTE^XLFDT($P(^(0),U,3))_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
170 Q
171LISTPOPD(DFN) ;
172 N IEN
173 N HRN,PHONE,X
174 ;NO SCREEN FOR VIP
175 Q:GFTI=-1 I GFTI>500 K LST S GFTI=-1 ;WE RETURN 500 VALUES MAX
176 S PHONE=$P($G(^DPT(DFN,.13)),U),HRN=$$HRN^DGLBPID(DFN)
177 S GFTI=GFTI+1,LST(GFTI)=DFN_U_$P(^DPT(DFN,0),U)_U_$$FMTE^XLFDT($P(^(0),U,3))_TAB_"!"_DFN_U_$$ID^DGLBPID(DFN)_U_"'"_HRN_"'"_U_PHONE
178 Q
179 ;
180VWPT1 ;VWPT NEW LOGIC . 4TH PIECE BELOW REPLACE $P(X,U,9)=SSN WITH ID AS $$ID^DGLBPID(DFN)
181 ; THEN IF THIS VALUE = HRN AND BOTH '="" THEN PUT SINGLE QUOTES
182 ; AROUND 4TH PIECE AS THIS IS SAME AS HRN.
183 S ID=$$ID^DGLBPID(DFN) S HRN=$$HRN^DGLBPID(DFN)
184 I (ID=HRN)&(HRN'="") S ID="'"_ID_"'"
185 ;
186 ;VWPT LINE BELOW WITH ID SUBSTITUTED FOR 9TH PIECE OF X
187 S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_ID_U_U_$G(^(.1))_U_$G(^(.101))
188 ; End VOE mod
189 ;
190 ; Following taken from ORWPT call to VWPT1 to save space
191 ;
192 S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44))
193 S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN)
194 S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U)
195 S:'$D(IOST) IOST="P-OTHER"
196 S $P(REC,U,11)=$$OTF^OR3CONV(DFN,1)
197 D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC%
198 I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X
199 Q
200VWPT2 ;VWPT GET HRN AND ALTERNATE HRN
201 S $P(REC,U,17)="'"_$$HRN^DGLBPID(DFN)_"'" ;$$HRN^VWVOEDPT(DFN)
202 S $P(REC,U,18)=$$ALTHRN(DFN)
203 K VAEL,VAERR ;VADPT call to kill?
204 S ^DISV(DUZ,"^DPT(")=DFN
205 Q
206ALTHRN(DFN) ;
207 Q ""
Note: See TracBrowser for help on using the repository browser.