Changeset 623 for WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m
r613 r623 1 DPTLK 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 30 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 EN 18 19 20 21 22 23 24 EN2 25 26 27 ASKPAT 28 29 30 31 32 33 34 35 36 37 38 CHKPAT 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 CHKPAT1 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 MAG 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 NOPAT 101 102 103 CHKDFN 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 Q 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 Q1 145 146 147 148 149 150 151 152 QK 153 154 QK1 155 156 IX 157 158 159 160 IATA(X) 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 TRACK(X,START,END) 185 186 187 188 FIELDS(IATA) 189 190 191 192 193 194 195 196 197 198 199 200 201 ENR 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 CV 228 229 230 231 232 233 1 DPTLK ;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 ; 17 EN ; -- 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 24 EN2 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 ; 27 ASKPAT ; -- 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 ; 38 CHKPAT ; -- 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="??" 58 CHKPAT1 .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 76 MAG ; -- 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 ; 100 NOPAT ; -- 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 ; 103 CHKDFN ; -- 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 ; 119 Q ; -- 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 ; 144 Q1 ; -- 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 ; 152 QK K:'$D(DPTNOFZK) DPTNOFZY G Q 153 ; 154 QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1 155 ; 156 IX ; -- 157 I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D 158 G DPTLK 159 ; 160 IATA(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 ; 184 TRACK(X,START,END) ; find track where start/end are sentinels 185 ; 186 Q $P($P($G(X),START,2),END,1) 187 ; 188 FIELDS(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 201 ENR ;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 227 CV ;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 TracChangeset
for help on using the changeset viewer.
