- 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 Jan 18, 2025@04:01:33 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