DPTLK ;ALB/RMO,RTK,ARF,JAM - MAS Patient Look-up Main Routine ; 3/22/05 4:19pm
;;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,769,857,876,915,919,993,1031,1014**;Aug 13, 1993;Build 42
;
; mods made for magstripe read 12/96 - JFP
; mods made for VIC 4.0 (barcode and magstripe) read 4/2012 - ELZ (*857)
;
;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
; by patch DG*5.3*244
;
EN ; -- Entry point
N DIE,DR,DGSEARCH,DPTXX
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,DGNEW,DGSEARCH
.W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC("B")) DIC("B"),"// "
.R X:DTIME
.S (DPTX,DPTXX)=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,BARCODE,DGVIC40,DGCAC
S (MAG,BARCODE,DGVIC40,DGCAC)=0
I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX)
I 'MAG,DPTX?1"%"1N13ANP.3AN S BARCODE=1,(X,DPTX)=$$BARCODE($$UP^XLFSTR(DPTX))
; - read other line but don't use dbia#10096 don't display input
I $G(DGVIC40),'BARCODE X ^%ZOSF("EOFF") R X(1):1 X ^%ZOSF("EON")
I 'MAG,'BARCODE,DPTX?1N6AN1A7AN1A2AN S DGCAC=1,(X,DPTX)=$$CACCARD($$UP^XLFSTR(DPTX))
; fail VHIC card match but starts with %, we're done
I 'MAG,'BARCODE,'DGCAC,$E(DPTX,1)="%" G CHKDFN
;
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)&('$G(DGVIC40))
; -- 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))="""" D STOP G ASKPAT ;DG*5.3*993
; -- Check for EDIPI lookup
I DPTX?10N,DIC(0)["M" D G:$G(DPTDFN)>0 CHKDFN
.N DGEDIPI
.S DGEDIPI=0 F S DGEDIPI=$O(^DGCN(391.91,"AISS",DPTX,"USDOD","NI",+$$IEN^XUAF4("200DOD"),DGEDIPI)) Q:'DGEDIPI I $P($G(^DGCN(391.91,DGEDIPI,2)),"^",3)'="H" Q
.Q:DGEDIPI<1
.S Y=$P($G(^DGCN(391.91,DGEDIPI,0)),"^")
.D SETDPT^DPTLK1:Y>0
.S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)
; -- Check for index lookups
; DG*5.3*1031 remove the use of the DGSTOP var - not needed - was added by DG*5.3*993
;N DGSTOP S DGSTOP=0
;I '$G(DGVIC40)!(DPTX?9N) D ^DPTLK1 D G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D(DUOUT)!(DGSTOP=1),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
I '$G(DGVIC40)!(DPTX?9N) D ^DPTLK1 D 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
. ;Next lines inclusively stop creation of a patient if Load/Edit Patient Data or Admit A Patient DG*5.3*993
. ; DG*5.3*1031 - this check moved to tag NOPAT
. ;I DPTDFN=0,$P($G(XQY0),"^",1)="DG LOAD PATIENT DATA"!($P($G(XQY0),"^",1)="DG ADMIT PATIENT") I $G(DIVDIC)'["IBA" I (X'="^"),(X'="") I DIC(0)["A" W:DIC(0)["Q" *7," ??" D STOP Q ;adding sponsor
. I DPTDFN<1,$P($G(XQY0),"^",1)="DG REGISTER PATIENT",$T(PATIENT^MPIFXMLP)'="",'MAG D
.. S DPTDFN=$$SEARCH^DPTLK7(DPTX,$G(DPTXX))
.. I DPTDFN<1 K DO,D,DIC("W"),DPTCNT,DPTS,DPTSEL,DPTSZ S DPTDFN=-1,Y=-1,(DPTX,DPTXX)=""
.. S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2):$P(^(0),U,2),1:DPTSZ)
.. S:DPTDFN>0 DPTS(DPTDFN)=$P(^DPT(DPTDFN,0),"^")_"^"_$P(^DPT(DPTDFN,0),"^")
MAG ; -- No patient found, check for mag stripe input, create stub
I 'MAG,'BARCODE,'DGCAC 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 @$S(DGVIC40:"VIC40(.DGFLDS,DGVIC40,DGCAC)",1:"FIELDS(IATA)")
I '$D(@DGFLDS) W !,"Could not add patient to patient file" D Q1 G EN2
; -- Check for Duplicates, no checking if VIC 4.0 card or CAC card
D:'$G(DGVIC40) EP2^DPTLK3
; -- No check done on VIC 4.0 or CAC card, so skip DPTDFN value
; check, file record
I 'DGVIC40,DPTDFN<0 D Q1 G EN2
; -- Creates Stub entry in patient file
S Y=$$FILE^DPTLK4(DGFLDS,$G(DGVIC40))
I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q
D QK1
Q
;
STOP ;
I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" W:DIC(0)["Q" *7," ??" ;DG*5.3*993
W !!?5,"Use Register A Patient option to add a new person." ;DG*5.3*993
W !!?5,"Press RETURN to continue..." R X:DTIME ;DG*5.3*993
; DG*5.3*1031 remove DGSTOP var - not needed
;S DGSTOP=1
Q
;
NOPAT ; -- No patient found, ask to add new
; DG*5.3*1031;jam; If in Load/Edit or Admit, and not in "Ask" mode (DIC(0)'["A"), then quit. This allows trigger code that does lookups which end up in this routine, to quit (and not call STOP and go back to ASKPAT)
; Otherwise, (per patch DG*5.3*993) do not allow adding a new patient and reprompt for the patient entry.
I $P($G(XQY0),"^",1)="DG LOAD PATIENT DATA"!($P($G(XQY0),"^",1)="DG ADMIT PATIENT") G:DIC(0)'["A" QK1 W:DIC(0)["Q" *7," ??" D STOP G ASKPAT
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
N DGPREFNM ;DG*5.3*1014 ARF - add PRFERRED NAME to prompt display response if populated
S DGPREFNM=$$GET1^DIQ(2,DPTDFN,.2405)
;DG*5.3*1014 - ARF -Add conditional write to the following line of code to display PREFERRED NAME .2405 when the field is populated
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:"") W:DGPREFNM'="" "(",DGPREFNM,")" 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
I DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN),'$D(DGSEARCH) D G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0 ;*TEST*
.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
I DPTDFN>0,DIC(0)["E" S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0 S DPTBTDT=1
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",$$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,G,DPTIFNS,DPTIX,DPTS
K:'$G(DICR) DPTBTDT ; IF DICR LEAVE FOR DGSEC TO HANDLE
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 (old card)
; - If new card, then use card number to look-up DFN, returned as `DFN
;
;Input: X - what was read in
;Output: SSN - social security number OR `DFN if new card
; 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"
; -- checks for new card, look-up DFN
I $E(X,1,29)?1"%"9NP1"^"17UNP1"?" D
. N CARD
. S CARD=+$P($P(X,"%",2),"^")
. ; **919, Story 220135 (elz) log the card activity
. D CARDLOG^MPIFAPI(CARD,"VHIC","SWIPE")
. S IATA=$$CARD(CARD)
; -- Returns SSN or `DFN value
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
BARCODE(X) ;
;This function pulls off card number from the barcode scan
; looks up the patient (locally)
; if not locally found, queries mpi
;
;Input: X - what was read in
;Output: DFN - `DFN
; Q - quit
;
; Input Start Data VIC ver DoD EDI_PIN VA/VIC II
; -------- ---------- ------- ----------- ----------
; alphanum % N alphanum 7 alphanum 6
;
N CARD
S CARD=$$B32TO10($E(X,10,15)) I 'CARD Q "Q"
; **919, Story 220135 (elz) log the card activity
D CARDLOG^MPIFAPI(CARD,"VHIC","SCAN")
Q $$CARD(CARD)
;
CACCARD(X) ;
;This function pulls off EDIPI number from the CAC barcode scan
; looks up the patient (locally)
; if not locally found, queries mpi
;
;Input: X - what was read in
;Output: DFN - `DFN
; Q - quit
;
; VC PDI PT DoD EDI PC BC CI
; -- --- -- ------- -- --- ---
; "1" 6UN 1U 7UN 1U 1UN 1UN
;
N EDIPI
S EDIPI=$$B32TO10($E(X,9,15)) I 'EDIPI Q "Q"
Q $$EDIPI(EDIPI)
;
EDIPI(EDIPI) ; - returns `DFN from EDIPI number
N DFN,VICFAC
; **919, Story 220135 (elz) log the card activity
D CARDLOG^MPIFAPI(EDIPI,"CAC","SCAN")
S VICFAC=+$$LKUP^XUAF4("200DOD") ; national DOD station number
S DFN=+$G(^DGCN(391.91,+$O(^DGCN(391.91,"ASID",EDIPI,VICFAC,0)),0))
S DGVIC40=EDIPI ; saving EDIPI number here so I don't have to look later
I DFN Q "`"_DFN
; - not found locally, need to make sure we don't find anyone DGVIC40
Q "Q"
CARD(CARD) ; - returns `DFN from card number
N DFN,VICFAC
S VICFAC=+$$LKUP^XUAF4("742V1") ; national vic facility number
S DFN=+$G(^DGCN(391.91,+$O(^DGCN(391.91,"ASID",CARD,VICFAC,0)),0))
S DGVIC40=CARD ; saving card number here so I don't have to look later
I DFN Q "`"_DFN
; - not found locally, need to make sure we don't find anyone DGVIC40
Q "Q"
VIC40(DGFLDS,DGVIC40,DGCAC) ; - returns the data used to create the
; patient file entry from mpi
N X,DGMPI
S DGFLDS="^TMP(""DGVIC"","_$J_")"
K @DGFLDS
I $T(CARDPV^MPIFXMLS)'="" D CARDPV^MPIFXMLS(.DGMPI,DGVIC40,DGCAC)
S X=0 F S X=$O(DGMPI(X)) Q:'X S @DGFLDS@(X)=DGMPI(X)
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
B32TO10(X) ; - convert from base 32 to base 10
N I,Y,S S Y=0,S="0123456789ABCDEFGHIJKLMNOPQRSTUV"
I X[" " S X=$E(X,1,$F(X," ")-2)
F I=1:1:$L(X) S Y=Y*32+($F(S,$E(X,I))-2)
Q Y
RPCVIC(RETURN,DPTX) ; - patient lookup from VIC card, rpc/api
; non-interactive
; this function will return a patient's DFN based on input. input must
; be in the form of the FULL input from a VIC card (magstripe or bar
; code), the patient must be locally known (FULL doesn't but can contain
; additional card tracks)
; RETURN input should be passed by reference
;
; Input examples:
; Barcode possibilities:
; NNNNNNNNN (old VIC card, full 9 digit ssn)
; CCCCCCCCCCCCCCCCCC (new VIC 4.0 card, 18 characters with
; 10-15 being compressed card number)
; Magstripe possibilities:
; Must always start with %
; Must contain ?
; $E(X,2,10) = SSN (old card)
; %NNNNNNNNN^CCCCCCCCCCCCCCCCC? (first 29 characters) where
; N = card number (new card)
;
; Return (pass by reference): If patient known locally = DFN
; If not known locally = -1
;
N MAG,BARCODE
S (RETURN,MAG,BARCODE)=0
I '$D(DPTX) Q -1
S DPTX=$$UP^XLFSTR(DPTX)
I DPTX["?" S DPTX=$E(DPTX,1,$F(DPTX,"?")-1)
I DPTX?9N S RETURN=$O(^DPT("SSN",DPTX,0))
I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?",'RETURN S MAG=1,DPTX=$$IATA(DPTX)
I 'MAG,DPTX?1"%"1N13UNP.3UN,'RETURN S BARCODE=1,DPTX=$$BARCODE(DPTX)
I 'MAG,'BARCODE,DPTX?1N6UN1U7UN1U2UN S DPTX=$$CACCARD(DPTX)
I 'RETURN,$E(DPTX,2,999) S RETURN=$S($E(DPTX)="`":$E(DPTX,2,999),1:$O(^DPT("SSN",DPTX,0)))
S RETURN=$S(RETURN:RETURN,1:-1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDPTLK 17438 printed Sep 23, 2025@20:36:46 Page 2
DPTLK ;ALB/RMO,RTK,ARF,JAM - MAS Patient Look-up Main Routine ; 3/22/05 4:19pm
+1 ;;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,769,857,876,915,919,993,1031,1014**;Aug 13, 1993;Build 42
+2 ;
+3 ; mods made for magstripe read 12/96 - JFP
+4 ; mods made for VIC 4.0 (barcode and magstripe) read 4/2012 - ELZ (*857)
+5 ;
+6 ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
+7 ; by patch DG*5.3*244
+8 ;
EN ; -- Entry point
+1 NEW DIE,DR,DGSEARCH,DPTXX
+2 KILL DPTX,DPTDFN,DPTSAVX
IF $DATA(DIC(0))
if DIC(0)["I"!(DIC(0)'["A"&('$DATA(X)))
GOTO QK
+3 IF '$DATA(^DD("VERSION"))
WRITE !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined."
GOTO QK
+4 IF '$DATA(^DPT(0))!(^DD("VERSION")<17.2)
WRITE !!?3,"Unable to proceed. ",$SELECT('$DATA(^DPT(0)):"0th node of ^DPT missing",^DD("VERSION")<17.2:"Fileman version must be at least 17.2",1:""),"."
GOTO QK
EN2 KILL DO,DUOUT,DTOUT
SET U="^"
SET DIC="^DPT("
SET DIC(0)=$SELECT($DATA(DIC(0)):DIC(0),1:"AELMQ")
if DIC(0)'["A"
SET (DPTX,DPTSAVX)=X
+1 SET DPTSZ=1000
IF $DATA(^DD("OS"))#2
SET DPTSZ=$SELECT(+$PIECE(^DD("OS",^("OS"),0),U,2):$PIECE(^(0),U,2),1:DPTSZ)
+2 ;
ASKPAT ; -- Prompt for patient
+1 IF DIC(0)["A"
Begin DoDot:1
+2 KILL DTOUT,DUOUT,DGNEW,DGSEARCH
+3 WRITE !,$SELECT($DATA(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ")
if $DATA(DIC("B"))
WRITE DIC("B"),"// "
+4 READ X:DTIME
+5 SET (DPTX,DPTXX)=X
if '$TEST
SET DTOUT=1
if $TEST&(DPTX="")&($DATA(DIC("B")))
SET DPTX=DIC("B")
if DPTX["^"&($EXTRACT(DPTX)'="%")
SET DUOUT=1
End DoDot:1
if '$TEST!($EXTRACT(DPTX)["^")!(DPTX="")
GOTO QK
+6 ; -- Check for the IATA magnetic stripe input
+7 NEW MAG,GCHK,BARCODE,DGVIC40,DGCAC
+8 SET (MAG,BARCODE,DGVIC40,DGCAC)=0
+9 IF $EXTRACT(DPTX)="%"!($EXTRACT(DPTX)=";")
IF DPTX["?"
SET MAG=1
SET (X,DPTX)=$$IATA(DPTX)
+10 IF 'MAG
IF DPTX?1"%"1N13ANP.3AN
SET BARCODE=1
SET (X,DPTX)=$$BARCODE($$UP^XLFSTR(DPTX))
+11 ; - read other line but don't use dbia#10096 don't display input
+12 IF $GET(DGVIC40)
IF 'BARCODE
XECUTE ^%ZOSF("EOFF")
READ X(1):1
XECUTE ^%ZOSF("EON")
+13 IF 'MAG
IF 'BARCODE
IF DPTX?1N6AN1A7AN1A2AN
SET DGCAC=1
SET (X,DPTX)=$$CACCARD($$UP^XLFSTR(DPTX))
+14 ; fail VHIC card match but starts with %, we're done
+15 IF 'MAG
IF 'BARCODE
IF 'DGCAC
IF $EXTRACT(DPTX,1)="%"
GOTO CHKDFN
+16 ;
CHKPAT ; -- Custom Patient Lookup
+1 DO DO^DIC1
+2 SET DIC("W")=$SELECT($DATA(DIC("W")):DIC("W"),1:"")
+3 KILL DPTIFNS,DPTS,DPTSEL
+4 SET DPTCNT=0
+5 ; -- Check input for format an length
+6 if DPTX?1A!(DPTX'?.ANP)!($LENGTH(DPTX)>30)&('$GET(DGVIC40))
GOTO CHKDFN
+7 ; -- Check for null response or abort
+8 IF DPTX=""!(DPTX["^")
if DIC(0)["A"
GOTO ASKPAT
GOTO QK
+9 ; -- Check for question mark
+10 IF DPTX["?"
Begin DoDot:1
+11 SET D="B"
+12 SET DZ=$SELECT(DPTX?1"?":"",1:"??")
+13 if DZ="??"
GOTO CHKPAT1
+14 NEW %
+15 WRITE !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of"
+16 WRITE " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER"
+17 WRITE !,?1,"Do you want the entire ",+$PIECE($GET(^DPT(0)),"^",4),"-Entry PATIENT List"
SET %=0
DO YN^DICN
+18 if %'=1
QUIT
+19 SET DZ="??"
CHKPAT1 SET X=DPTX
+1 DO DQ^DICQ
End DoDot:1
if DIC(0)["A"
GOTO ASKPAT
GOTO QK
+2 ; -- Check for space bar, return
+3 IF DPTX=" "
Begin DoDot:1
+4 SET Y=$SELECT('($DATA(DUZ)#2):-1,$DATA(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)
+5 if Y>0
DO SETDPT^DPTLK1
+6 SET DPTDFN=$SELECT($DATA(DPTS(Y)):Y,1:-1)
End DoDot:1
GOTO CHKDFN
+7 ; -- Check for DFN look up
+8 IF $EXTRACT(DPTX)="`"
Begin DoDot:1
+9 SET Y=$SELECT($DATA(^DPT(+$PIECE(DPTX,"`",2),0)):+$PIECE(DPTX,"`",2),1:-1)
+10 if Y>0
DO SETDPT^DPTLK1
+11 SET DPTDFN=$SELECT($DATA(DPTS(Y)):Y,1:-1)
End DoDot:1
GOTO CHKDFN
+12 ; -- Puts input in correct format
+13 if DPTX=""
GOTO CHKDFN
+14 ; -- Force new entry
+15 ;DG*5.3*993
IF $EXTRACT(DPTX)=""""
IF $EXTRACT(DPTX,$LENGTH(DPTX))=""""
DO STOP
GOTO ASKPAT
+16 ; -- Check for EDIPI lookup
+17 IF DPTX?10N
IF DIC(0)["M"
Begin DoDot:1
+18 NEW DGEDIPI
+19 SET DGEDIPI=0
FOR
SET DGEDIPI=$ORDER(^DGCN(391.91,"AISS",DPTX,"USDOD","NI",+$$IEN^XUAF4("200DOD"),DGEDIPI))
if 'DGEDIPI
QUIT
IF $PIECE($GET(^DGCN(391.91,DGEDIPI,2)),"^",3)'="H"
QUIT
+20 if DGEDIPI<1
QUIT
+21 SET Y=$PIECE($GET(^DGCN(391.91,DGEDIPI,0)),"^")
+22 if Y>0
DO SETDPT^DPTLK1
+23 SET DPTDFN=$SELECT($DATA(DPTS(Y)):Y,1:-1)
End DoDot:1
if $GET(DPTDFN)>0
GOTO CHKDFN
+24 ; -- Check for index lookups
+25 ; DG*5.3*1031 remove the use of the DGSTOP var - not needed - was added by DG*5.3*993
+26 ;N DGSTOP S DGSTOP=0
+27 ;I '$G(DGVIC40)!(DPTX?9N) D ^DPTLK1 D G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D(DUOUT)!(DGSTOP=1),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
+28 IF '$GET(DGVIC40)!(DPTX?9N)
DO ^DPTLK1
Begin DoDot:1
+29 ;Next lines inclusively stop creation of a patient if Load/Edit Patient Data or Admit A Patient DG*5.3*993
+30 ; DG*5.3*1031 - this check moved to tag NOPAT
+31 ;I DPTDFN=0,$P($G(XQY0),"^",1)="DG LOAD PATIENT DATA"!($P($G(XQY0),"^",1)="DG ADMIT PATIENT") I $G(DIVDIC)'["IBA" I (X'="^"),(X'="") I DIC(0)["A" W:DIC(0)["Q" *7," ??" D STOP Q ;adding sponsor
+32 IF DPTDFN<1
IF $PIECE($GET(XQY0),"^",1)="DG REGISTER PATIENT"
IF $TEXT(PATIENT^MPIFXMLP)'=""
IF 'MAG
Begin DoDot:2
+33 SET DPTDFN=$$SEARCH^DPTLK7(DPTX,$GET(DPTXX))
+34 IF DPTDFN<1
KILL DO,D,DIC("W"),DPTCNT,DPTS,DPTSEL,DPTSZ
SET DPTDFN=-1
SET Y=-1
SET (DPTX,DPTXX)=""
+35 SET DPTSZ=1000
IF $DATA(^DD("OS"))#2
SET DPTSZ=$SELECT(+$PIECE(^DD("OS",^("OS"),0),U,2):$PIECE(^(0),U,2),1:DPTSZ)
+36 if DPTDFN>0
SET DPTS(DPTDFN)=$PIECE(^DPT(DPTDFN,0),"^")_"^"_$PIECE(^DPT(DPTDFN,0),"^")
End DoDot:2
End DoDot:1
if $DATA(DTOUT)!($DATA(DUOUT)&(DIC(0)'["A"))
GOTO QK
if $DATA(DUOUT)
GOTO ASKPAT
if DPTDFN<0
GOTO CHKPAT
if DPTDFN>0
GOTO CHKDFN
IF DIC(0)["N"
IF $DATA(^DPT(DPTX,0))
SET Y=X
DO SETDPT^DPTLK1
SET DPTDFN=$SELECT($DATA(DPTS(Y)):Y,1:-1)
GOTO CHKDFN
MAG ; -- No patient found, check for mag stripe input, create stub
+1 IF 'MAG
IF 'BARCODE
IF 'DGCAC
GOTO NOPAT
+2 ; -- Check for ADT option(s) only
+3 NEW DGOPT
+4 SET DGOPT=$PIECE($GET(XQY0),"^",2)
+5 IF DGOPT'="Load/Edit Patient Data"
IF DGOPT'="Register a Patient"
Begin DoDot:1
+6 WRITE !," ...Patient not in database, use ADT options to load patient"
DO Q1
End DoDot:1
GOTO EN2
+7 ; -- Prompt for creation of stub
+8 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Patient not found...Create stub entry: "
+9 SET GCHK=$DATA(^TMP("DGVIC"))
+10 DO ^DIR
+11 KILL DIR
+12 IF 'Y
DO Q1
GOTO EN2
+13 ; -- Parse IATA fields
+14 DO @$SELECT(DGVIC40:"VIC40(.DGFLDS,DGVIC40,DGCAC)",1:"FIELDS(IATA)")
+15 IF '$DATA(@DGFLDS)
WRITE !,"Could not add patient to patient file"
DO Q1
GOTO EN2
+16 ; -- Check for Duplicates, no checking if VIC 4.0 card or CAC card
+17 if '$GET(DGVIC40)
DO EP2^DPTLK3
+18 ; -- No check done on VIC 4.0 or CAC card, so skip DPTDFN value
+19 ; check, file record
+20 IF 'DGVIC40
IF DPTDFN<0
DO Q1
GOTO EN2
+21 ; -- Creates Stub entry in patient file
+22 SET Y=$$FILE^DPTLK4(DGFLDS,$GET(DGVIC40))
+23 IF $PIECE(Y,"^",3)'=1
WRITE !,"Could not add patient to patient file"
DO QK1
QUIT
+24 DO QK1
+25 QUIT
+26 ;
STOP ;
+1 ;DG*5.3*993
IF $EXTRACT(DPTX)=""""
IF $EXTRACT(DPTX,$LENGTH(DPTX))=""""
if DIC(0)["Q"
WRITE *7," ??"
+2 ;DG*5.3*993
WRITE !!?5,"Use Register A Patient option to add a new person."
+3 ;DG*5.3*993
WRITE !!?5,"Press RETURN to continue..."
READ X:DTIME
+4 ; DG*5.3*1031 remove DGSTOP var - not needed
+5 ;S DGSTOP=1
+6 QUIT
+7 ;
NOPAT ; -- No patient found, ask to add new
+1 ; DG*5.3*1031;jam; If in Load/Edit or Admit, and not in "Ask" mode (DIC(0)'["A"), then quit. This allows trigger code that does lookups which end up in this routine, to quit (and not call STOP and go back to ASKPAT)
+2 ; Otherwise, (per patch DG*5.3*993) do not allow adding a new patient and reprompt for the patient entry.
+3 IF $PIECE($GET(XQY0),"^",1)="DG LOAD PATIENT DATA"!($PIECE($GET(XQY0),"^",1)="DG ADMIT PATIENT")
if DIC(0)'["A"
GOTO QK1
if DIC(0)["Q"
WRITE *7," ??"
DO STOP
GOTO ASKPAT
+4 IF DIC(0)["L"
DO ^DPTLK2
SET Y=DPTDFN
if DIC(0)["A"&(Y<0)&('$GET(DTOUT))
GOTO ASKPAT
GOTO QK1
+5 ;
CHKDFN ; --
+1 if '$DATA(DPTDFN)
SET DPTDFN=-1
IF DPTDFN'>0!('$DATA(DPTS(+DPTDFN)))
if DIC(0)["Q"
WRITE *7," ??"
if DIC(0)["A"
GOTO ASKPAT
GOTO QK
+2 ;DG*5.3*1014 ARF - add PRFERRED NAME to prompt display response if populated
NEW DGPREFNM
+3 SET DGPREFNM=$$GET1^DIQ(2,DPTDFN,.2405)
+4 ;DG*5.3*1014 - ARF -Add conditional write to the following line of code to display PREFERRED NAME .2405 when the field is populated
+5 IF DIC(0)["E"
Begin DoDot:1
+6 IF $DATA(DDS)
DO CLRMSG^DDS
SET DX=0
SET DY=DDSHBX+1
XECUTE DDXY
End DoDot:1
WRITE $SELECT('$DATA(DPTSEL)&('$DATA(DIVP)):$PIECE(DPTS(DPTDFN),U,2)_" "_$PIECE(DPTS(DPTDFN),U)_" ",$DATA(^DPT(DPTDFN,0)):" "_$PIECE(^(0),U)_" ",1:"")
if DGPREFNM'=""
WRITE "(",DGPREFNM,")"
SET Y=DPTDFN
if $DATA(^DPT(DPTDFN,0))
XECUTE "N DDS X DIC(""W"")"
+7 ;
+8 ; check for other patients in "BS5" xref on Patient file
+9 ;I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D G ASKPAT:DIC(0)["A"&(%'=1),QK:DPTDFN<0
+10 ;*TEST*
IF DPTDFN>0
IF DIC(0)["E"
IF $$BS5^DPTLK5(+DPTDFN)
IF '$DATA(DGSEARCH)
Begin DoDot:1
+11 NEW DPTZERO,DPTLSNME,DPTSSN
SET DPTZERO=$GET(^DPT(+DPTDFN,0))
SET DPTLSNME=$PIECE($PIECE(DPTZERO,U),",")
SET DPTSSN=$EXTRACT($PIECE(DPTZERO,U,9),6,9)
+12 WRITE $CHAR(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and"
+13 WRITE !,"whose social security number ends with '",DPTSSN,"'."
+14 WRITE !,"Are you sure you wish to continue (Y/N)"
SET %=0
DO YN^DICN
+15 IF %'=1
SET DPTDFN=-1
End DoDot:1
if DIC(0)["A"&(%'=1)
GOTO ASKPAT
if DPTDFN<0
GOTO QK
+16 ;
+17 ;I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0)["A"&(DPTDFN<0),QK:DPTDFN<0
+18 IF DPTDFN>0
IF DIC(0)["E"
SET Y=DPTDFN
DO ^DGSEC
SET DPTDFN=Y
if DIC(0)["A"&(DPTDFN<0)
GOTO ASKPAT
if DPTDFN<0
GOTO QK
SET DPTBTDT=1
+19 SET DPTX=DPTX_$PIECE(DPTS(DPTDFN),U,2)
SET DPTDFN=DPTDFN_U_$PIECE(^DPT(DPTDFN,0),U)
+20 ;
Q ; --
+1 SET Y=$SELECT('$DATA(DPTDFN):-1,'$DATA(DPTS(+DPTDFN)):-1,1:DPTDFN)
SET X=$SELECT($DATA(DPTX)&(+Y>0):DPTX,$DATA(DPTSAVX):DPTSAVX,$DATA(DPTX):DPTX,1:"")
+2 IF Y>0
if DIC(0)'["F"
SET ^DISV($SELECT($DATA(DUZ)#2:DUZ,1:0),"^DPT(")=+Y
if DIC(0)["Z"
SET Y(0)=^DPT(+Y,0)
SET Y(0,0)=$PIECE(^(0),U,1)
+3 ;DG*600
+4 IF DIC(0)["E"
IF $$TESTPAT^VADPT(+Y)
WRITE *7,!,"WARNING : You may have selected a test patient."
+5 IF DIC(0)["E"
IF $$BADADR^DGUTL3(+Y)
WRITE *7,!,"WARNING : ** This patient has been flagged with a Bad Address Indicator."
+6 IF DIC(0)["E"
IF $$VAADV^DPTLK3(+Y)
WRITE *7,!,"** Patient is VA ADVANTAGE."
+7 ;DG*485
+8 IF $DATA(^DPT("AXFFP",1,+Y))
DO FFP^DPTLK5
+9 ;Display enrollment information
+10 IF Y>0
IF DIC(0)["E"
DO ENR
+11 ;
+12 ;Call Combat Vet check
+13 IF Y>0
IF DIC(0)["E"
DO CV
+14 ;
+15 ; check whether to display Means Test Required message
+16 Begin DoDot:1
+17 NEW DPTDIV
+18 IF '$GET(DUZ(2))
QUIT
+19 IF Y>0
IF DIC(0)["E"
SET DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2))
IF DPTDIV
Begin DoDot:2
+20 WRITE $CHAR(7),!!,"MEANS TEST REQUIRED"
+21 WRITE !,?3,$PIECE($GET(^DG(40.8,DPTDIV,"MT")),U,2)
+22 HANG 2
End DoDot:2
End DoDot:1
+23 ;
Q1 ; -- Clean up variables
+1 KILL D,DIC("W"),DO,DPTCNT,G,DPTIFNS,DPTIX,DPTS
+2 ; IF DICR LEAVE FOR DGSEC TO HANDLE
if '$GET(DICR)
KILL DPTBTDT
+3 KILL DPTSAVX,DPTSEL,DPTSZ,DPTX
+4 ;
+5 if $DATA(IATA)
KILL IATA
+6 if $DATA(DGFLDS)
KILL @DGFLDS,DGFLDS
+7 QUIT
+8 ;
QK if '$DATA(DPTNOFZK)
KILL DPTNOFZY
GOTO Q
+1 ;
QK1 if '$DATA(DPTNOFZK)
KILL DPTNOFZY
GOTO Q1
+1 ;
IX ; --
+1 IF $DATA(D)
IF $DATA(^DD(2,0,"IX",D))
IF ($EXTRACT(D)'="A")
SET DPTIX=D
+2 GOTO DPTLK
+3 ;
IATA(X) ; --
+1 ;This function pulls off ssn from the IATA track (old card)
+2 ; - If new card, then use card number to look-up DFN, returned as `DFN
+3 ;
+4 ;Input: X - what was read in
+5 ;Output: SSN - social security number OR `DFN if new card
+6 ; Q - quit
+7 ;
+8 ; Track Start Sent End Sent Field Separator
+9 ; ----- ---------- -------- ---------------
+10 ; IATA (alphanum) % ? { (Note: VA used ^)
+11 ; ABA (numeric) ; ? =
+12 ;
+13 ;N IATA
+14 SET (IATA)=""
+15 ; no start sentinel
IF $EXTRACT(X)'="%"
QUIT X
+16 IF X'["?"
QUIT "Q"
+17 ; -- Extract data from track
+18 SET IATA=$$TRACK(X,"%","?")
+19 ; -- checks for no data
+20 IF IATA=""
QUIT "Q"
+21 ; -- checks for new card, look-up DFN
+22 IF $EXTRACT(X,1,29)?1"%"9NP1"^"17UNP1"?"
Begin DoDot:1
+23 NEW CARD
+24 SET CARD=+$PIECE($PIECE(X,"%",2),"^")
+25 ; **919, Story 220135 (elz) log the card activity
+26 DO CARDLOG^MPIFAPI(CARD,"VHIC","SWIPE")
+27 SET IATA=$$CARD(CARD)
End DoDot:1
+28 ; -- Returns SSN or `DFN value
+29 IF IATA'=""
QUIT $PIECE(IATA,"^")
+30 QUIT "Q"
+31 ;
TRACK(X,START,END) ; find track where start/end are sentinels
+1 ;
+2 QUIT $PIECE($PIECE($GET(X),START,2),END,1)
+3 ;
FIELDS(IATA) ; -- Sets fields
+1 if '$DATA(IATA)
QUIT
+2 NEW CNT,FIELD
+3 SET DGFLDS="^TMP(""DGVIC"","_$JOB_")"
SET CNT=1
+4 KILL @DGFLDS
+5 FOR
SET FIELD=$PIECE($GET(IATA),"^",CNT)
if FIELD=""
QUIT
Begin DoDot:1
+6 SET @DGFLDS@(CNT)=FIELD
+7 SET CNT=CNT+1
End DoDot:1
+8 ; -- Define fields for duplicate checker
+9 ;NAME
SET DPTX=$GET(@DGFLDS@(2))
+10 ;DOB
SET DPTIDS(.03)=$GET(@DGFLDS@(3))
+11 ;SSN
SET DPTIDS(.09)=$GET(@DGFLDS@(1))
+12 QUIT
BARCODE(X) ;
+1 ;This function pulls off card number from the barcode scan
+2 ; looks up the patient (locally)
+3 ; if not locally found, queries mpi
+4 ;
+5 ;Input: X - what was read in
+6 ;Output: DFN - `DFN
+7 ; Q - quit
+8 ;
+9 ; Input Start Data VIC ver DoD EDI_PIN VA/VIC II
+10 ; -------- ---------- ------- ----------- ----------
+11 ; alphanum % N alphanum 7 alphanum 6
+12 ;
+13 NEW CARD
+14 SET CARD=$$B32TO10($EXTRACT(X,10,15))
IF 'CARD
QUIT "Q"
+15 ; **919, Story 220135 (elz) log the card activity
+16 DO CARDLOG^MPIFAPI(CARD,"VHIC","SCAN")
+17 QUIT $$CARD(CARD)
+18 ;
CACCARD(X) ;
+1 ;This function pulls off EDIPI number from the CAC barcode scan
+2 ; looks up the patient (locally)
+3 ; if not locally found, queries mpi
+4 ;
+5 ;Input: X - what was read in
+6 ;Output: DFN - `DFN
+7 ; Q - quit
+8 ;
+9 ; VC PDI PT DoD EDI PC BC CI
+10 ; -- --- -- ------- -- --- ---
+11 ; "1" 6UN 1U 7UN 1U 1UN 1UN
+12 ;
+13 NEW EDIPI
+14 SET EDIPI=$$B32TO10($EXTRACT(X,9,15))
IF 'EDIPI
QUIT "Q"
+15 QUIT $$EDIPI(EDIPI)
+16 ;
EDIPI(EDIPI) ; - returns `DFN from EDIPI number
+1 NEW DFN,VICFAC
+2 ; **919, Story 220135 (elz) log the card activity
+3 DO CARDLOG^MPIFAPI(EDIPI,"CAC","SCAN")
+4 ; national DOD station number
SET VICFAC=+$$LKUP^XUAF4("200DOD")
+5 SET DFN=+$GET(^DGCN(391.91,+$ORDER(^DGCN(391.91,"ASID",EDIPI,VICFAC,0)),0))
+6 ; saving EDIPI number here so I don't have to look later
SET DGVIC40=EDIPI
+7 IF DFN
QUIT "`"_DFN
+8 ; - not found locally, need to make sure we don't find anyone DGVIC40
+9 QUIT "Q"
CARD(CARD) ; - returns `DFN from card number
+1 NEW DFN,VICFAC
+2 ; national vic facility number
SET VICFAC=+$$LKUP^XUAF4("742V1")
+3 SET DFN=+$GET(^DGCN(391.91,+$ORDER(^DGCN(391.91,"ASID",CARD,VICFAC,0)),0))
+4 ; saving card number here so I don't have to look later
SET DGVIC40=CARD
+5 IF DFN
QUIT "`"_DFN
+6 ; - not found locally, need to make sure we don't find anyone DGVIC40
+7 QUIT "Q"
VIC40(DGFLDS,DGVIC40,DGCAC) ; - returns the data used to create the
+1 ; patient file entry from mpi
+2 NEW X,DGMPI
+3 SET DGFLDS="^TMP(""DGVIC"","_$JOB_")"
+4 KILL @DGFLDS
+5 IF $TEXT(CARDPV^MPIFXMLS)'=""
DO CARDPV^MPIFXMLS(.DGMPI,DGVIC40,DGCAC)
+6 SET X=0
FOR
SET X=$ORDER(DGMPI(X))
if 'X
QUIT
SET @DGFLDS@(X)=DGMPI(X)
+7 QUIT
ENR ;Display Enrollment information after patient selection
+1 NEW DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT
+2 IF '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR)
QUIT
+3 SET DGENCAT=$$CATEGORY^DGENA4(+DPTDFN)
+4 SET DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)
+5 WRITE !?1,"Enrollment Priority: ",$SELECT($GET(DGENR("PRIORITY")):$$EXT^DGENU("PRIORITY",DGENR("PRIORITY")),1:""),$SELECT($GET(DGENR("SUBGRP"))="":"",1:$$EXT^DGENU("SUBGRP",$GET(DGENR("SUBGRP"))))
+6 WRITE ?33,"Category: ",DGENCAT
+7 WRITE ?57,"End Date: ",$SELECT($GET(DGENR("END")):$$FMTE^XLFDT(DGENR("END"),"5DZ"),1:""),!
+8 ;If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible Project Phase I)
+9 IF $GET(DGENR("STATUS"))=10!($GET(DGENR("STATUS"))=19)!($GET(DGENR("STATUS"))=20)
Begin DoDot:1
+10 ;H 5
WRITE ?1,"Enrollment Status: ",$SELECT($GET(DGENR("STATUS")):$$EXT^DGENU("STATUS",DGENR("STATUS")),1:"")
End DoDot:1
+11 ;check for Combat Veteran Eligibility, if elig do not display EGT info
+12 IF $$CVEDT^DGCV(+DPTDFN)
QUIT
+13 ;Get Enrollment Group Threshold Priority and Subgroup
+14 SET DGEGTIEN=$$FINDCUR^DGENEGT
+15 SET DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
+16 if $GET(DGENR("PRIORITY"))=""!($GET(DGEGT("PRIORITY"))="")
QUIT
+17 ;Compare Patient's Enrollment Priority to Enrollment Group Threshold
+18 IF '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$GET(DGENR("SUBGRP")),DGEGT("PRIORITY"),DGEGT("SUBGRP"))
Begin DoDot:1
+19 NEW X,IORVOFF,IORVON
+20 SET X="IORVOFF;IORVON"
+21 DO ENDR^%ZISS
+22 WRITE !?32
if $DATA(IORVON)
WRITE IORVON
WRITE "*** WARNING ***"
if $DATA(IORVOFF)
WRITE IORVOFF
+23 IF DGENR("END")'=""
WRITE !?14
if $DATA(IORVON)
WRITE IORVON
WRITE "*** PATIENT ENROLLMENT END",$SELECT(DT>+DGENR("END"):"ED",1:"S")," EFFECTIVE ",$$FMTE^XLFDT(DGENR("END"),"5DZ")," ***"
if $DATA(IORVOFF)
WRITE IORVOFF
QUIT
+24 WRITE !?5
if $DATA(IORVON)
WRITE IORVON
WRITE "*** PATIENT ENROLLMENT ENDING. ENROLLMENT END DATE IS NOT KNOWN. ***"
if $DATA(IORVOFF)
WRITE IORVOFF
End DoDot:1
+25 QUIT
CV ;check for Combat Vet status
+1 NEW DGCV
+2 SET DGCV=$$CVEDT^DGCV(+DPTDFN)
+3 IF $PIECE(DGCV,U)=1
Begin DoDot:1
+4 IF '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR)
WRITE !
+5 WRITE ?3,"Combat Vet Status: "_$SELECT($PIECE(DGCV,U,3)=1:"ELIGIBLE",1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($PIECE(DGCV,U,2),"5DZ")
End DoDot:1
QUIT
+6 QUIT
B32TO10(X) ; - convert from base 32 to base 10
+1 NEW I,Y,S
SET Y=0
SET S="0123456789ABCDEFGHIJKLMNOPQRSTUV"
+2 IF X[" "
SET X=$EXTRACT(X,1,$FIND(X," ")-2)
+3 FOR I=1:1:$LENGTH(X)
SET Y=Y*32+($FIND(S,$EXTRACT(X,I))-2)
+4 QUIT Y
RPCVIC(RETURN,DPTX) ; - patient lookup from VIC card, rpc/api
+1 ; non-interactive
+2 ; this function will return a patient's DFN based on input. input must
+3 ; be in the form of the FULL input from a VIC card (magstripe or bar
+4 ; code), the patient must be locally known (FULL doesn't but can contain
+5 ; additional card tracks)
+6 ; RETURN input should be passed by reference
+7 ;
+8 ; Input examples:
+9 ; Barcode possibilities:
+10 ; NNNNNNNNN (old VIC card, full 9 digit ssn)
+11 ; CCCCCCCCCCCCCCCCCC (new VIC 4.0 card, 18 characters with
+12 ; 10-15 being compressed card number)
+13 ; Magstripe possibilities:
+14 ; Must always start with %
+15 ; Must contain ?
+16 ; $E(X,2,10) = SSN (old card)
+17 ; %NNNNNNNNN^CCCCCCCCCCCCCCCCC? (first 29 characters) where
+18 ; N = card number (new card)
+19 ;
+20 ; Return (pass by reference): If patient known locally = DFN
+21 ; If not known locally = -1
+22 ;
+23 NEW MAG,BARCODE
+24 SET (RETURN,MAG,BARCODE)=0
+25 IF '$DATA(DPTX)
QUIT -1
+26 SET DPTX=$$UP^XLFSTR(DPTX)
+27 IF DPTX["?"
SET DPTX=$EXTRACT(DPTX,1,$FIND(DPTX,"?")-1)
+28 IF DPTX?9N
SET RETURN=$ORDER(^DPT("SSN",DPTX,0))
+29 IF $EXTRACT(DPTX)="%"!($EXTRACT(DPTX)=";")
IF DPTX["?"
IF 'RETURN
SET MAG=1
SET DPTX=$$IATA(DPTX)
+30 IF 'MAG
IF DPTX?1"%"1N13UNP.3UN
IF 'RETURN
SET BARCODE=1
SET DPTX=$$BARCODE(DPTX)
+31 IF 'MAG
IF 'BARCODE
IF DPTX?1N6UN1U7UN1U2UN
SET DPTX=$$CACCARD(DPTX)
+32 IF 'RETURN
IF $EXTRACT(DPTX,2,999)
SET RETURN=$SELECT($EXTRACT(DPTX)="`":$EXTRACT(DPTX,2,999),1:$ORDER(^DPT("SSN",DPTX,0)))
+33 SET RETURN=$SELECT(RETURN:RETURN,1:-1)
+34 QUIT
