| [623] | 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
|
|---|
