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