- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT2.m
r613 r623 1 ORWPT2 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**269**;Dec 17, 1997 LOCAL ;Build 29 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 LOOKUP(LST,X1) 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 OVETT 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 TRYPH 103 104 105 106 107 108 109 CHKX(X) 110 111 112 113 114 115 116 117 118 119 120 121 122 CHKXB(X1) 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 LISTPOPB(DFN) 139 140 141 142 143 144 145 146 LISTPOP(DFN,X1) 147 148 149 150 151 152 153 154 155 LISTPOPP(DFN,X1) 156 157 158 159 160 161 162 163 164 165 LISTPOPH(DFN) 166 167 168 169 170 171 LISTPOPD(DFN) 172 173 174 175 176 177 178 179 180 VWPT1 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 VWPT2 201 202 203 204 205 206 ALTHRN(DFN) 207 1 ORWPT2 ; 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 ; 29 LOOKUP(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 74 OVETT ; 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 102 TRYPH ; 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 109 CHKX(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 122 CHKXB(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 138 LISTPOPB(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 146 LISTPOP(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 155 LISTPOPP(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 ; 165 LISTPOPH(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 171 LISTPOPD(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 ; 180 VWPT1 ;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 200 VWPT2 ;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 206 ALTHRN(DFN) ; 207 Q ""
Note:
See TracChangeset
for help on using the changeset viewer.
