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

DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ;1/27/07  13:12
 ;;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
 ; Modified from FOIA VISTA,
 ; Copyright (C) 2007 WorldVistA
 ;
 ; This program is free software; you can redistribute it and/or modify
 ; it under the terms of the GNU General Public License as published by
 ; the Free Software Foundation; either version 2 of the License, or
 ; (at your option) any later version.
 ;
 ;
 ; mods made for magstripe read 12/96 - JFP
 ;
 ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
 ;                by patch DG*5.3*244
 ;
EN ; -- Entry point
 ;Following line so VOE will use alternate lookup routine, DAOU,VA/CJS,WV/TOAD
 I $G(DUZ("AG"))'="V" D ^AUPNLK Q
 N DIE,DR
 K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D(X)))
 I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined." G QK
 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
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
 S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DPTSZ)
 ;
ASKPAT ; -- Prompt for patient
 I DIC(0)["A" D   G QK:'$T!($E(DPTX)["^")!(DPTX="")
 .K DTOUT,DUOUT
 .W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC("B")) DIC("B"),"// "
 .R X:DTIME
 .S DPTX=X S:'$T DTOUT=1 S:$T&(DPTX="")&($D(DIC("B"))) DPTX=DIC("B") S:DPTX["^"&($E(DPTX)'="%") DUOUT=1
 ; -- Check for the IATA magnetic stripe input
 N MAG,GCHK
 S MAG=0
 I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX)
 ;
CHKPAT ; -- Custom Patient Lookup
 D DO^DIC1
 S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"")
 K DPTIFNS,DPTS,DPTSEL
 S DPTCNT=0
 ; -- Check input for format an length
 G CHKDFN:DPTX?1A!(DPTX'?.ANP)!($L(DPTX)>30)
 ; -- Check for null response or abort
 I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK
 ; -- Check for question mark
 I DPTX["?" D  G ASKPAT:DIC(0)["A",QK
 .S D="B"
 .S DZ=$S(DPTX?1"?":"",1:"??")
 .G CHKPAT1:DZ="??"
 .N %
 .W !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of"
 .W " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER"
 .W !,?1,"Do you want the entire ",+$P($G(^DPT(0)),"^",4),"-Entry PATIENT List" S %=0 D YN^DICN
 .Q:%'=1
 .S DZ="??"
CHKPAT1 .S X=DPTX
 .D DQ^DICQ
 ; -- Check for space bar, return
 I DPTX=" " D  G CHKDFN
 .S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)
 .D SETDPT^DPTLK1:Y>0
 .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
 ; -- Check for DFN look up
 I $E(DPTX)="`" D  G CHKDFN
 .S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1)
 .D SETDPT^DPTLK1:Y>0
 .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
 ; -- Puts input in correct format
 G CHKDFN:DPTX=""
 ; -- Force new entry
 I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" G NOPAT
 ; -- Check for index lookups
 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
MAG ; -- No patient found, check for mag stripe input, create stub
 I 'MAG G NOPAT
 ; -- Check for ADT option(s) only
 N DGOPT
 S DGOPT=$P($G(XQY0),"^",2)
 I DGOPT'="Load/Edit Patient Data",DGOPT'="Register a Patient" D  G EN2
 .W !,"    ...Patient not in database, use ADT options to load patient" D Q1
 ; -- Prompt for creation of stub
 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Patient not found...Create stub entry: "
 S GCHK=$D(^TMP("DGVIC"))
 D ^DIR
 K DIR
 I 'Y D Q1 G EN2
 ; -- Parse IATA fields
 D FIELDS(IATA)
 ; -- Check for Duplicates
 D EP2^DPTLK3
 I DPTDFN<0 D Q1 G EN2
 ; -- Creates Stub entry in patient file
 S Y=$$FILE^DPTLK4(DGFLDS)
 I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q
 D QK1
 Q
 ;
NOPAT ; -- No patient found, ask to add new
 I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A"&(Y<0)&('$G(DTOUT)),QK1
 ;
CHKDFN ; -- 
 S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN))) W:DIC(0)["Q" *7," ??" G ASKPAT:DIC(0)["A",QK
 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"")"
 .I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY
 ;
 ; check for other patients in "BS5" xref on Patient file
 I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D  G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0
 .N DPTZERO,DPTLSNME,DPTSSN S DPTZERO=$G(^DPT(+DPTDFN,0)),DPTLSNME=$P($P(DPTZERO,U),","),DPTSSN=$E($P(DPTZERO,U,9),6,9)
 .W $C(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and"
 .W !,"whose social security number ends with '",DPTSSN,"'."
 .W !,"Are you sure you wish to continue (Y/N)" S %=0 D YN^DICN
 .I %'=1 S DPTDFN=-1
 ;
 I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0
 S DPTX=DPTX_$P(DPTS(DPTDFN),U,2),DPTDFN=DPTDFN_U_$P(^DPT(DPTDFN,0),U)
 ;
Q ; -- 
 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:"")
 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)
 ;DG*600
 ;I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning : You have selected a test patient."
 I DIC(0)["E",$$TESTPAT^VADPT(+Y) W *7,!,"WARNING : You may have selected a test patient."
 I DIC(0)["E",$$BADADR^DGUTL3(+Y) W *7,!,"WARNING : ** This patient has been flagged with a Bad Address Indicator."
 I DIC(0)["E",$$VAADV^DPTLK3(+Y) W *7,!,"** Patient is VA ADVANTAGE."
 ;DG*485
 I $D(^DPT("AXFFP",1,+Y)) D FFP^DPTLK5
 ;Display enrollment information
 I Y>0,DIC(0)["E" D ENR
 ;
 ;Call Combat Vet check
 I Y>0,DIC(0)["E" D CV
 ;
 ; check whether to display Means Test Required message
 D
 .N DPTDIV
 .I '$G(DUZ(2)) Q
 .I Y>0,DIC(0)["E" S DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2)) I DPTDIV D
 ..W $C(7),!!,"MEANS TEST REQUIRED"
 ..W !,?3,$P($G(^DG(40.8,DPTDIV,"MT")),U,2)
 ..H 2
 ;
Q1 ; -- Clean up variables
 K D,DIC("W"),DO,DPTCNT,DPTDFN,DPTIFNS,DPTIX,DPTS
 K DPTSAVX,DPTSEL,DPTSZ,DPTX
 ;
 K:$D(IATA) IATA
 K:$D(DGFLDS) @DGFLDS,DGFLDS
 Q
 ;
QK K:'$D(DPTNOFZK) DPTNOFZY G Q
 ;
QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1
 ;
IX ; --
 I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D
 G DPTLK
 ;
IATA(X) ; --
 ;This function pulls off ssn from the IATA track
 ;
 ;Input:  X   -  what was read in
 ;Output: SSN -  social security number
 ;          Q -  quit
 ;
 ; Track            Start Sent     End Sent      Field Separator
 ; -----            ----------     --------      ---------------
 ;  IATA (alphanum)      %             ?          {   (Note: VA used ^)
 ;  ABA (numeric)        ;             ?          =    
 ;
 ;N IATA
 S (IATA)=""
 I $E(X)'="%" Q X ; no start sentinel
 I X'["?" Q "Q"
 ; -- Extract data from track
 S IATA=$$TRACK(X,"%","?")
 ; -- checks for no data
 I IATA="" Q "Q"
 ; -- Returns SSN
 I IATA'="" Q $P(IATA,"^")
 Q "Q"
 ;
TRACK(X,START,END) ; find track where start/end are sentinels
 ;
 Q $P($P($G(X),START,2),END,1)
 ;
FIELDS(IATA) ; -- Sets fields
 Q:'$D(IATA)
 N CNT,FIELD
 S DGFLDS="^TMP(""DGVIC"","_$J_")",CNT=1
 K @DGFLDS
 F  S FIELD=$P($G(IATA),"^",CNT)  Q:FIELD=""  D
 .S @DGFLDS@(CNT)=FIELD
 .S CNT=CNT+1
 ; -- Define fields for duplicate checker
 S DPTX=$G(@DGFLDS@(2)) ;NAME
 S DPTIDS(.03)=$G(@DGFLDS@(3)) ;DOB
 S DPTIDS(.09)=$G(@DGFLDS@(1)) ;SSN
 Q
ENR ;Display Enrollment information after patient selection
 N DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT
 I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) Q
 S DGENCAT=$$CATEGORY^DGENA4(+DPTDFN)
 S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)
 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"))))
 W ?33,"Category: ",DGENCAT
 W ?57,"End Date: ",$S($G(DGENR("END")):$$FMTE^XLFDT(DGENR("END"),"5DZ"),1:""),!
 ;If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible Project Phase I)
 I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS"))=20) D
 . W ?1,"Enrollment Status: ",$S($G(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"") ;H 5
 ;check for Combat Veteran Eligibility, if elig do not display EGT info
 I $$CVEDT^DGCV(+DPTDFN) Q
 ;Get Enrollment Group Threshold Priority and Subgroup
 S DGEGTIEN=$$FINDCUR^DGENEGT
 S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
 Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="")
 ;Compare Patient's Enrollment Priority to Enrollment Group Threshold
 I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT("PRIORITY"),DGEGT("SUBGRP")) D
 .N X,IORVOFF,IORVON
 .S X="IORVOFF;IORVON"
 .D ENDR^%ZISS
 .W !?32 W:$D(IORVON) IORVON  W "*** WARNING ***" W:$D(IORVOFF) IORVOFF
 .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
 .W !?5 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT ENDING.  ENROLLMENT END DATE IS NOT KNOWN. ***" W:$D(IORVOFF) IORVOFF
 Q
CV ;check for Combat Vet status
 N DGCV
 S DGCV=$$CVEDT^DGCV(+DPTDFN)
 I $P(DGCV,U)=1 D  Q
 . I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W !
 . W ?3,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
 Q