Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DPTLK

DPTLK.m

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