DPTLK.m

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)