DPTLK1.m

DPTLK1 ;ALB/RMO,EG - MAS Patient Look-up Check Cross-References ; 08/15/2006

 ;;5.3;Registration;**32,50,197,249,317,391,244,532,574,620,641,680,538,657,1015**;Aug 13, 1993;Build 21

FIND ;Cross reference patient lookup

 ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented

 ;                by patch DG*5.3*244

 ;

 N DDCOMA,DPTXOLD,DPTOUT,DPTOVAL,DGLASTLK

 S DGLASTLK=1

 S (DPTXOLD,DPTX)=$$UCASE(DPTX)

 I DPTX?1A.E1","1.A.E S DPTXOLD=DPTX,DDCOMA="I $E($P($G(DPTVAL),"","",2),1,"_$L($P(DPTX,",",2))_")="""_$TR($P(DPTX,",",2),"""")_"""",DPTX=$P(DPTX,",")

 K DPTREFS S DPTREFS=$S(DIC(0)'["M":"B,NOP",DPTX?1A1N.N:$S($L(DPTX)<6:"BS5,CN,RM",1:"CN,RM"),DPTX?4N!(DPTX?4N1A):"BS,SSN,CN,RM",DPTX?9N.E:"SSN,CN,RM",1:"")

 S:DPTREFS="" DPTREFS=$S(DPTX?1N.N:$S($L(DPTX)<5:"CN,RM,BS,SSN",1:"CN,RM,SSN"),DPTX?1N.E:"CN,RM",1:"B,NOP,CN,RM") S:$D(DPTIX) DPTREFS=DPTIX_","_DPTREFS

 ;Use cross reference passed to LIST^DPTLK1 by Person Service Lookup (DPTPSREF) if defined.

 I $G(DPTPSREF)'="" S DPTREFS=DPTPSREF

 S DPTBEG=1,(DPTDFN,DPTNUM,DPTOUT)=0

 F DPTLP=1:1 S DPTREF=$P(DPTREFS,",",DPTLP) Q:DPTREF=""!(DPTDFN)  D  Q:DPTDFN!DPTOUT

 .S DPTVAL=DPTX

 .I DPTREF="NOP",'$G(DPTNOFZY) S DPTVAL=$$FORMAT^XLFNAME7(DPTVAL,2,30,1,0,,1) Q:'$L(DPTVAL)

 .D LOOK(DPTVAL)

 .I DPTREF="B",'$G(DPTNOFZY) S DPTVAL=$$FORMAT^XLFNAME7(DPTX,2,30,1,0,,1) D:DPTVAL'=DPTX LOOK(DPTVAL)

 .Q

SET I 'DPTDFN S:DPTCNT=1&($D(DPTIFNS(DPTCNT))) DPTDFN=+DPTIFNS(DPTCNT) S DPT("NOPRT^")="" D PRTDPT:'DPTDFN&(DPTCNT>DPTNUM)&(DIC(0)["E") K DPT("NOPRT^") I 'DPTDFN,$D(DPTSEL),DPTSEL="" S DPTX="",DPTDFN=-1

 I DPTDFN'>0,$L($G(DPTXOLD)) I DPTX=$P(DPTXOLD,",") S DPTX=DPTXOLD

 I DPTDFN>0,$D(DPTXOLD) S DPTX=DPTXOLD

 ; one last stab at lookup - DG*641

 I '$G(DPTCNT),DPTX[",",DGLASTLK=1,'$G(DPTNOFZY) D

 .S DPTX=$$FORMAT^XLFNAME7(DPTX,2,30,1)

 .S DDCOMA="I $E($P($G(DPTVAL),"","",2),1,"_$L($P(DPTX,",",2))_")="""_$TR($P(DPTX,",",2),"""")_""""

 .S DPTX=$P(DPTX,",")

 .S DGLASTLK=0

 .S DPTREFS="B,NOP,CN,RM"

 .;Person Service Lookup does not allow lookup by RM cross reference

 .;PSL release 4 does not allow lookup by ward (CN) cross reference

 .I $G(DPTPSREF)'="" S DPTREFS="B,NOP"

 .F DPTLP=1:1 S DPTREF=$P(DPTREFS,",",DPTLP) Q:DPTREF=""!(DPTDFN)  D  Q:DPTDFN!DPTOUT

 ..S DPTVAL=DPTX

 ..D LOOK(DPTVAL)

 I DGLASTLK=0,$G(DPTCNT) S DGLASTLK=1 G SET

 I DGLASTLK=0,'$G(DPTCNT),$L($G(DPTXOLD)) S DPTX=DPTXOLD

 ; end of DG*641 change

 ;

Q K DPTBEG,DPTIFN,DPTIFNS,DPTLP,DPTLP1,DPTNUM,DPTREF,DPTREFS,DPTVAL

 K DPTOVAL,DPTOUT,DPTXOLD,^TMP("DPTLK",$J)

 Q

 ;

LOOK(DPTVAL) ;Look for x-ref matches

 ;Input: DPTVAL=lookup seed value

 I $L(DPTVAL),$D(^DPT(DPTREF,DPTVAL)) D CHKIFN Q:DPTDFN!DPTOUT

 I $L(DPTVAL),'($D(^DPT(DPTREF,DPTVAL))&(DIC(0)["O"))&(DIC(0)'["X") D CHKVAL

 Q

 ;

CHKVAL S DPTOVAL=DPTVAL

 N DPTSEED S DPTSEED=DPTVAL

 I DPTREF="SSN",(DPTVAL?9N1"p") D  Q

 .S DPTVAL=$E(DPTVAL,1,9)_"P" D CHKIFN

 .Q

 I DPTREF="SSN",(DPTVAL?2.9N) D  Q

 .S DPTVAL=$E(DPTVAL_"0000000",1,9)

 .D CV1(DPTVAL),CHKIFN

 .S DPTVAL=DPTVAL_"P" D CV1(DPTVAL),CHKIFN

 .Q

 D CV1(DPTVAL)

 I DPTREF="CN"!(DPTREF="RM"),DPTVAL'["E",DPTVAL=+DPTVAL,'$D(^DPT(DPTREF,DPTVAL)) D  Q

 .S DPTVAL=$O(^DPT(DPTREF,DPTVAL_" "),-1)

 .D CV1(DPTVAL)

 .Q

 Q

 ;

CV1(DPTVAL) ;Look for input value matches

 I $L(DPTVAL) F DPTLP1=0:0 S DPTVAL=$O(^DPT(DPTREF,DPTVAL)) Q:DPTVAL=""!(DPTDFN)!($P(DPTVAL,DPTSEED)'="")  D CHKIFN

 Q

 ;

CHKIFN F DPTIFN=0:0 S DPTIFN=$O(^DPT(DPTREF,DPTVAL,DPTIFN)) Q:'DPTIFN!(DPTDFN)!DPTOUT  S Y=DPTIFN D SETDPT I $S<DPTSZ F I=1:1:DPTNUM-7 S J=$S($D(DPTIFNS(I)):+DPTIFNS(I),1:0) K DPTIFNS(I),DPTS(J) S DPTBEG=I

 Q

 ;

SETDPT Q:($D(DPTS(Y))&($G(DPTREF)'="B"))!'$D(^DPT(Y,0))

 ; screen out MERGED FROM records - DG/574

 Q:$D(^DPT(Y,-9))

 N DPTNVAL I '$D(DPTOVAL) N DPTOVAL S DPTOVAL=DPTX

 I 1 S X=DPTOVAL X:$D(DIC("S")) DIC("S") Q:'$T  X:($D(DO("SCR"))) DO("SCR") Q:'$T  X:$D(DDCOMA) DDCOMA Q:'$T

 K:$G(DPTCNT)<1 ^TMP("DPTLK",$J)

 S DPTS(Y)=$S('$D(DPTREF):$P(^DPT(Y,0),U),1:$P(^DPT(Y,0),U))_U_$S($D(DPTVAL):$E(DPTVAL,($L(DPTOVAL)+1),$L(DPTVAL)),1:"")

 S DPTNVAL=$P(^DPT(Y,0),U)_U_$S($G(DPTREF)="NOP":$P(^DPT(Y,0),U),$D(DPTVAL):DPTVAL,1:"")

 Q:$D(^TMP("DPTLK",$J,Y,DPTNVAL))

 S DPTCNT=DPTCNT+1,^TMP("DPTLK",$J,Y,DPTNVAL)="",DPTIFNS(DPTCNT)=Y_U_DPTNVAL

 I $D(DPTLARR) D  Q

 .I DPTLMAX,DPTCNT>DPTLMAX D  Q

 ..S @DPTLARR@(DPTCNT)="ADDITIONAL MATCHES FOUND BUT NOT RETURNED"

 ..S DPTOUT=1

 ..Q

 .S @DPTLARR@(DPTCNT)=DPTIFNS(DPTCNT)_U_$$SSN(Y)_U_$$DOB(Y)

 .Q

 I '(DPTCNT#5),DIC(0)["E" D PRTDPT

 Q

 ;

PRTDPT I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY S X=0 X ^%ZOSF("RM")

 N DPTP1,DPTP2

 F DPTNUM=DPTNUM+1:1:DPTCNT Q:DPTOUT  S DPTIFN=+DPTIFNS(DPTNUM) D

 .W:'$D(DDS) !

 .S DPTP2=$P(DPTIFNS(DPTNUM),U,3)

 .S DPTP1=$P(DPTIFNS(DPTNUM),U,2)

 .W ?3,DPTNUM,?$X+(4-$L(DPTNUM))

 .; write the xref value

 .W DPTP2_"  "

 .; write patient name if diff than xref value

 .I DPTP1'=DPTP2 W DPTP1

 .S Y=DPTIFN X:$D(^DPT(DPTIFN,0)) "N DDS X DIC(""W"")" I $D(DDS) S DY=DY+1,DX=0 X DDXY S $X=0

 I '$D(DPT("NOPRT^")) W:'$D(DDS) ! W "ENTER '^' TO STOP, OR "

 W:'$D(DDS) ! W "CHOOSE ",DPTBEG,"-",DPTNUM,": " R X:DTIME S DPTSEL=X D  Q:DPTSEL=""!$D(DTOUT)!$D(DUOUT)

 .S:'$T DPTSEL=$S($D(DPTOVAL):DPTOVAL,$D(DPTVAL):DPTVAL,$D(DPTX):DPTX,$D(DPTXOLD):DPTXOLD,1:""),(DPTOUT,DTOUT)=1

 .S:X="^" (DPTOUT,DUOUT)=1

 S DPTDFN=$S(DPTSEL'?.ANP!($L(DPTSEL)>30):-1,'$D(DPTIFNS(DPTSEL)):-1,$D(DPTS(+DPTIFNS(DPTSEL))):+DPTIFNS(DPTSEL),1:-1),DPTX=$S(DPTDFN<0:DPTSEL,1:DPTX)

 S:DPTDFN=-1 DPTXOLD=DPTSEL

 Q

 ;

LIST(DPTX,DPTLMAX,DPTLARR) ;Silent lookup list

 ;Input: DPTX=lookup value (name, SSN, room, ward, DFN or 

 ;             "space_return").

 ;       DPTLMAX=maximum number of matches to return (optional), this

 ;               parameter has no effect if DFN or "space_return"

 ;               lookup methods are used.

 ;       DPTLARR=name of array to return list of matches, this should

 ;               be a global if DPTLMAX is a large value or unspecified

 ;               This array is returned in the format:

 ;               @DPTLARR@(n)=DFN^patient_name^xref_lookup_match_value^

 ;                            SSN^Date_of_Birth

 ;               If more matches exist than the maximum to be returned

 ;               as specified by DPTLMAX, the @DPTLARR@(DPTLMAX+1) node

 ;               will be defined = "ADDITIONAL MATCHES FOUND BUT NOT 

 ;               RETURNED".

 ;               The calling program has the responsibility to kill

 ;               @DPTLARR prior to calling this entry point.

 ;Output: number of matches and array named by DPTLARR.

 ;

 N X,Y,DPTCNT,DIC,DPTSZ,DPTDFN,DPTIFNS,DPTS

 S DPTCNT=0,DIC(0)="M",DPTSZ=1000 S:$G(DPTLMAX)<1 DPTLMAX=0

 ;Check for "space_return" or DFN lookup

 I DPTX=" "!($E(DPTX)="`") D  Q DPTCNT

 .I DPTX=" " S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)

 .I $E(DPTX)="`" S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1)

 .Q:Y<1  Q:'$D(^DPT(Y,0))  D SETDPT S DPTCNT=1

 .Q

 D FIND

 Q $S(DPTLMAX&(DPTCNT>DPTLMAX):DPTLMAX,1:DPTCNT)

 ;

UCASE(DGX) ;Uppercase lookup value

 ;Input: DGX=lookup value

 ;Output: transformed DGX

 N DGI,DGY,DGZ S DGZ=DGX,DGX=""

 F DGI=1:1:$L(DGZ) S DGY=$E(DGZ,DGI) D

 .S:DGY?1L DGY=$C($A(DGY)-32)

 .S DGX=DGX_DGY

 Q DGX

 ;        

SSN(DFN) ;do not show ssn identifier for patient

 ; input DFN = ien in file #2 [required]

 ; output SSN = nnnnnnnnn

 ;

 N SSN

 S SSN="",DFN=+DFN

 I DFN>0 D

 .I $$SCREEN(DFN) S SSN="*SENSITIVE*" Q

 .S SSN=$P($G(^DPT(DFN,0)),U,9)

 .; DG*5.3*657 BAJ 11/20 2005

 .; display Pseudo SSN alert on list

 .I SSN?9N1"P" S SSN=SSN_" **Pseudo SSN**"

 .Q 

 Q SSN

 ;

DOB(DFN,DGYR) ;do not show dob identifier for patient

 ; input DFN = ien in file #2  [required]

 ;       DGYR = 0/1  [optional]

 ;              where 0 returns 4-digit year (default)

 ;                    1 returns 2-digit year

 ;                    2 returns File manager date

 ; output DOB = mm/dd/yyyy (default)

 ;            = mm/dd/yy, if DGYR=1

 ;            = yyymmdd, if DGYR=2

 N B,DOB,YEAR

 S DOB="",DFN=+DFN,DGYR=+$G(DGYR)

 I DFN>0 D

 .I $$SCREEN(DFN) S DOB="*SENSITIVE*" Q

 .S B=$P($G(^DPT(DFN,0)),U,3)

 .I DGYR'=2 D  Q

 ..S YEAR=$S(DGYR=1:"2D",1:"5D")

 ..S DOB=$$FMTE^XLFDT(B,YEAR)

 .S DOB=B

 Q DOB

 ;

SCREEN(DFN) ;Screening logic for SSN & DOB

 ;Input  : DFN - Pointer to PATIENT file (#2)

 ;Output : 1 - Apply screen

 ;         0 - Don't apply screen

 ;Notes  : Screen applied if patient is sensitive or an employee

 ;

 N DGTIME,DGT,DGA1,DG1,DGXFR0

 ;Inpatient check - no longer used (kept for future reference)

 ;D H^DGUTL S DGT=DGTIME D ^DGPMSTAT I DG1 Q 0

 ;Sensitive - screen

 I $P($G(^DGSL(38.1,DFN,0)),"^",2) Q 1

 ;Employee - screen

 I $$EMPL^DGSEC4(DFN) Q 1

 ;Don't screen

 Q 0

DPTLK1    ;ALB/RMO,EG - MAS Patient Look-up Check Cross-References ; 08/15/2006

 +1       ;;5.3;Registration;**32,50,197,249,317,391,244,532,574,620,641,680,538,657,1015**;Aug 13, 1993;Build 21

FIND      ;Cross reference patient lookup

 +1       ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented

 +2       ;                by patch DG*5.3*244

 +3       ;

 +4        NEW DDCOMA,DPTXOLD,DPTOUT,DPTOVAL,DGLASTLK

 +5        SET DGLASTLK=1

 +6        SET (DPTXOLD,DPTX)=$$UCASE(DPTX)

 +7        IF DPTX?1A.E1","1.A.E

               SET DPTXOLD=DPTX

               SET DDCOMA="I $E($P($G(DPTVAL),"","",2),1,"_$LENGTH($PIECE(DPTX,",",2))_")="""_$TRANSLATE($PIECE(DPTX,",",2),"""")_""""

               SET DPTX=$PIECE(DPTX,",")

 +8        KILL DPTREFS

           SET DPTREFS=$SELECT(DIC(0)'["M":"B,NOP",DPTX?1A1N.N:$SELECT($LENGTH(DPTX)<6:"BS5,CN,RM",1:"CN,RM"),DPTX?4N!(DPTX?4N1A):"BS,SSN,CN,RM",DPTX?9N.E:"SSN,CN,RM",1:"")

 +9        IF DPTREFS=""

               SET DPTREFS=$SELECT(DPTX?1N.N:$SELECT($LENGTH(DPTX)<5:"CN,RM,BS,SSN",1:"CN,RM,SSN"),DPTX?1N.E:"CN,RM",1:"B,NOP,CN,RM")

           IF $DATA(DPTIX)

               SET DPTREFS=DPTIX_","_DPTREFS

 +10      ;Use cross reference passed to LIST^DPTLK1 by Person Service Lookup (DPTPSREF) if defined.

 +11       IF $GET(DPTPSREF)'=""

               SET DPTREFS=DPTPSREF

 +12       SET DPTBEG=1

           SET (DPTDFN,DPTNUM,DPTOUT)=0

 +13       FOR DPTLP=1:1

               SET DPTREF=$PIECE(DPTREFS,",",DPTLP)

               IF DPTREF=""!(DPTDFN)

                   QUIT 

               Begin DoDot:1

 +14               SET DPTVAL=DPTX

 +15               IF DPTREF="NOP"

                       IF '$GET(DPTNOFZY)

                           SET DPTVAL=$$FORMAT^XLFNAME7(DPTVAL,2,30,1,0,,1)

                           IF '$LENGTH(DPTVAL)

                               QUIT 

 +16               DO LOOK(DPTVAL)

 +17               IF DPTREF="B"

                       IF '$GET(DPTNOFZY)

                           SET DPTVAL=$$FORMAT^XLFNAME7(DPTX,2,30,1,0,,1)

                           IF DPTVAL'=DPTX

                               DO LOOK(DPTVAL)

 +18               QUIT 

               End DoDot:1

               IF DPTDFN!DPTOUT

                   QUIT 

SET        IF 'DPTDFN

               IF DPTCNT=1&($DATA(DPTIFNS(DPTCNT)))

                   SET DPTDFN=+DPTIFNS(DPTCNT)

               SET DPT("NOPRT^")=""

               IF 'DPTDFN&(DPTCNT>DPTNUM)&(DIC(0)["E")

                   DO PRTDPT

               KILL DPT("NOPRT^")

               IF 'DPTDFN

                   IF $DATA(DPTSEL)

                       IF DPTSEL=""

                           SET DPTX=""

                           SET DPTDFN=-1

 +1        IF DPTDFN'>0

               IF $LENGTH($GET(DPTXOLD))

                   IF DPTX=$PIECE(DPTXOLD,",")

                       SET DPTX=DPTXOLD

 +2        IF DPTDFN>0

               IF $DATA(DPTXOLD)

                   SET DPTX=DPTXOLD

 +3       ; one last stab at lookup - DG*641

 +4        IF '$GET(DPTCNT)

               IF DPTX[","

                   IF DGLASTLK=1

                       IF '$GET(DPTNOFZY)

                           Begin DoDot:1

 +5                            SET DPTX=$$FORMAT^XLFNAME7(DPTX,2,30,1)

 +6                            SET DDCOMA="I $E($P($G(DPTVAL),"","",2),1,"_$LENGTH($PIECE(DPTX,",",2))_")="""_$TRANSLATE($PIECE(DPTX,",",2),"""")_""""

 +7                            SET DPTX=$PIECE(DPTX,",")

 +8                            SET DGLASTLK=0

 +9                            SET DPTREFS="B,NOP,CN,RM"

 +10      ;Person Service Lookup does not allow lookup by RM cross reference

 +11      ;PSL release 4 does not allow lookup by ward (CN) cross reference

 +12                           IF $GET(DPTPSREF)'=""

                                   SET DPTREFS="B,NOP"

 +13                           FOR DPTLP=1:1

                                   SET DPTREF=$PIECE(DPTREFS,",",DPTLP)

                                   IF DPTREF=""!(DPTDFN)

                                       QUIT 

                                   Begin DoDot:2

 +14                                   SET DPTVAL=DPTX

 +15                                   DO LOOK(DPTVAL)

                                   End DoDot:2

                                   IF DPTDFN!DPTOUT

                                       QUIT 

                           End DoDot:1

 +16       IF DGLASTLK=0

               IF $GET(DPTCNT)

                   SET DGLASTLK=1

                   GOTO SET

 +17       IF DGLASTLK=0

               IF '$GET(DPTCNT)

                   IF $LENGTH($GET(DPTXOLD))

                       SET DPTX=DPTXOLD

 +18      ; end of DG*641 change

 +19      ;

Q          KILL DPTBEG,DPTIFN,DPTIFNS,DPTLP,DPTLP1,DPTNUM,DPTREF,DPTREFS,DPTVAL

 +1        KILL DPTOVAL,DPTOUT,DPTXOLD,^TMP("DPTLK",$JOB)

 +2        QUIT 

 +3       ;

LOOK(DPTVAL) ;Look for x-ref matches

 +1       ;Input: DPTVAL=lookup seed value

 +2        IF $LENGTH(DPTVAL)

               IF $DATA(^DPT(DPTREF,DPTVAL))

                   DO CHKIFN

                   IF DPTDFN!DPTOUT

                       QUIT 

 +3        IF $LENGTH(DPTVAL)

               IF '($DATA(^DPT(DPTREF,DPTVAL))&(DIC(0)["O"))&(DIC(0)'["X")

                   DO CHKVAL

 +4        QUIT 

 +5       ;

CHKVAL     SET DPTOVAL=DPTVAL

 +1        NEW DPTSEED

           SET DPTSEED=DPTVAL

 +2        IF DPTREF="SSN"

               IF (DPTVAL?9N1"p")

                   Begin DoDot:1

 +3                    SET DPTVAL=$EXTRACT(DPTVAL,1,9)_"P"

                       DO CHKIFN

 +4                    QUIT 

                   End DoDot:1

                   QUIT 

 +5        IF DPTREF="SSN"

               IF (DPTVAL?2.9N)

                   Begin DoDot:1

 +6                    SET DPTVAL=$EXTRACT(DPTVAL_"0000000",1,9)

 +7                    DO CV1(DPTVAL)

                       DO CHKIFN

 +8                    SET DPTVAL=DPTVAL_"P"

                       DO CV1(DPTVAL)

                       DO CHKIFN

 +9                    QUIT 

                   End DoDot:1

                   QUIT 

 +10       DO CV1(DPTVAL)

 +11       IF DPTREF="CN"!(DPTREF="RM")

               IF DPTVAL'["E"

                   IF DPTVAL=+DPTVAL

                       IF '$DATA(^DPT(DPTREF,DPTVAL))

                           Begin DoDot:1

 +12                           SET DPTVAL=$ORDER(^DPT(DPTREF,DPTVAL_" "),-1)

 +13                           DO CV1(DPTVAL)

 +14                           QUIT 

                           End DoDot:1

                           QUIT 

 +15       QUIT 

 +16      ;

CV1(DPTVAL) ;Look for input value matches

 +1        IF $LENGTH(DPTVAL)

               FOR DPTLP1=0:0

                   SET DPTVAL=$ORDER(^DPT(DPTREF,DPTVAL))

                   IF DPTVAL=""!(DPTDFN)!($PIECE(DPTVAL,DPTSEED)'="")

                       QUIT 

                   DO CHKIFN

 +2        QUIT 

 +3       ;

CHKIFN     FOR DPTIFN=0:0

               SET DPTIFN=$ORDER(^DPT(DPTREF,DPTVAL,DPTIFN))

               IF 'DPTIFN!(DPTDFN)!DPTOUT

                   QUIT 

               SET Y=DPTIFN

               DO SETDPT

               IF $STORAGE<DPTSZ

                   FOR I=1:1:DPTNUM-7

                       SET J=$SELECT($DATA(DPTIFNS(I)):+DPTIFNS(I),1:0)

                       KILL DPTIFNS(I),DPTS(J)

                       SET DPTBEG=I

 +1        QUIT 

 +2       ;

SETDPT     IF ($DATA(DPTS(Y))&($GET(DPTREF)'="B"))!'$DATA(^DPT(Y,0))

               QUIT 

 +1       ; screen out MERGED FROM records - DG/574

 +2        IF $DATA(^DPT(Y,-9))

               QUIT 

 +3        NEW DPTNVAL

           IF '$DATA(DPTOVAL)

               NEW DPTOVAL

               SET DPTOVAL=DPTX

 +4        IF 1

               SET X=DPTOVAL

               IF $DATA(DIC("S"))

                   XECUTE DIC("S")

               IF '$TEST

                   QUIT 

               IF ($DATA(DO("SCR")))

                   XECUTE DO("SCR")

               IF '$TEST

                   QUIT 

               IF $DATA(DDCOMA)

                   XECUTE DDCOMA

               IF '$TEST

                   QUIT 

 +5        IF $GET(DPTCNT)<1

               KILL ^TMP("DPTLK",$JOB)

 +6        SET DPTS(Y)=$SELECT('$DATA(DPTREF):$PIECE(^DPT(Y,0),U),1:$PIECE(^DPT(Y,0),U))_U_$SELECT($DATA(DPTVAL):$EXTRACT(DPTVAL,($LENGTH(DPTOVAL)+1),$LENGTH(DPTVAL)),1:"")

 +7        SET DPTNVAL=$PIECE(^DPT(Y,0),U)_U_$SELECT($GET(DPTREF)="NOP":$PIECE(^DPT(Y,0),U),$DATA(DPTVAL):DPTVAL,1:"")

 +8        IF $DATA(^TMP("DPTLK",$JOB,Y,DPTNVAL))

               QUIT 

 +9        SET DPTCNT=DPTCNT+1

           SET ^TMP("DPTLK",$JOB,Y,DPTNVAL)=""

           SET DPTIFNS(DPTCNT)=Y_U_DPTNVAL

 +10       IF $DATA(DPTLARR)

               Begin DoDot:1

 +11               IF DPTLMAX

                       IF DPTCNT>DPTLMAX

                           Begin DoDot:2

 +12                           SET @DPTLARR@(DPTCNT)="ADDITIONAL MATCHES FOUND BUT NOT RETURNED"

 +13                           SET DPTOUT=1

 +14                           QUIT 

                           End DoDot:2

                           QUIT 

 +15               SET @DPTLARR@(DPTCNT)=DPTIFNS(DPTCNT)_U_$$SSN(Y)_U_$$DOB(Y)

 +16               QUIT 

               End DoDot:1

               QUIT 

 +17       IF '(DPTCNT#5)

               IF DIC(0)["E"

                   DO PRTDPT

 +18       QUIT 

 +19      ;

PRTDPT     IF $DATA(DDS)

               DO CLRMSG^DDS

               SET DX=0

               SET DY=DDSHBX+1

               XECUTE DDXY

               SET X=0

               XECUTE ^%ZOSF("RM")

 +1        NEW DPTP1,DPTP2

 +2        FOR DPTNUM=DPTNUM+1:1:DPTCNT

               IF DPTOUT

                   QUIT 

               SET DPTIFN=+DPTIFNS(DPTNUM)

               Begin DoDot:1

 +3                IF '$DATA(DDS)

                       WRITE !

 +4                SET DPTP2=$PIECE(DPTIFNS(DPTNUM),U,3)

 +5                SET DPTP1=$PIECE(DPTIFNS(DPTNUM),U,2)

 +6                WRITE ?3,DPTNUM,?$X+(4-$LENGTH(DPTNUM))

 +7       ; write the xref value

 +8                WRITE DPTP2_"  "

 +9       ; write patient name if diff than xref value

 +10               IF DPTP1'=DPTP2

                       WRITE DPTP1

 +11               SET Y=DPTIFN

                   IF $DATA(^DPT(DPTIFN,0))

                       XECUTE "N DDS X DIC(""W"")"

                   IF $DATA(DDS)

                       SET DY=DY+1

                       SET DX=0

                       XECUTE DDXY

                       SET $X=0

               End DoDot:1

 +12       IF '$DATA(DPT("NOPRT^"))

               IF '$DATA(DDS)

                   WRITE !

               WRITE "ENTER '^' TO STOP, OR "

 +13       IF '$DATA(DDS)

               WRITE !

           WRITE "CHOOSE ",DPTBEG,"-",DPTNUM,": "

           READ X:DTIME

           SET DPTSEL=X

           Begin DoDot:1

 +14           IF '$TEST

                   SET DPTSEL=$SELECT($DATA(DPTOVAL):DPTOVAL,$DATA(DPTVAL):DPTVAL,$DATA(DPTX):DPTX,$DATA(DPTXOLD):DPTXOLD,1:"")

                   SET (DPTOUT,DTOUT)=1

 +15           IF X="^"

                   SET (DPTOUT,DUOUT)=1

           End DoDot:1

           IF DPTSEL=""!$DATA(DTOUT)!$DATA(DUOUT)

               QUIT 

 +16       SET DPTDFN=$SELECT(DPTSEL'?.ANP!($LENGTH(DPTSEL)>30):-1,'$DATA(DPTIFNS(DPTSEL)):-1,$DATA(DPTS(+DPTIFNS(DPTSEL))):+DPTIFNS(DPTSEL),1:-1)

           SET DPTX=$SELECT(DPTDFN<0:DPTSEL,1:DPTX)

 +17       IF DPTDFN=-1

               SET DPTXOLD=DPTSEL

 +18       QUIT 

 +19      ;

LIST(DPTX,DPTLMAX,DPTLARR) ;Silent lookup list

 +1       ;Input: DPTX=lookup value (name, SSN, room, ward, DFN or 

 +2       ;             "space_return").

 +3       ;       DPTLMAX=maximum number of matches to return (optional), this

 +4       ;               parameter has no effect if DFN or "space_return"

 +5       ;               lookup methods are used.

 +6       ;       DPTLARR=name of array to return list of matches, this should

 +7       ;               be a global if DPTLMAX is a large value or unspecified

 +8       ;               This array is returned in the format:

 +9       ;               @DPTLARR@(n)=DFN^patient_name^xref_lookup_match_value^

 +10      ;                            SSN^Date_of_Birth

 +11      ;               If more matches exist than the maximum to be returned

 +12      ;               as specified by DPTLMAX, the @DPTLARR@(DPTLMAX+1) node

 +13      ;               will be defined = "ADDITIONAL MATCHES FOUND BUT NOT 

 +14      ;               RETURNED".

 +15      ;               The calling program has the responsibility to kill

 +16      ;               @DPTLARR prior to calling this entry point.

 +17      ;Output: number of matches and array named by DPTLARR.

 +18      ;

 +19       NEW X,Y,DPTCNT,DIC,DPTSZ,DPTDFN,DPTIFNS,DPTS

 +20       SET DPTCNT=0

           SET DIC(0)="M"

           SET DPTSZ=1000

           IF $GET(DPTLMAX)<1

               SET DPTLMAX=0

 +21      ;Check for "space_return" or DFN lookup

 +22       IF DPTX=" "!($EXTRACT(DPTX)="`")

               Begin DoDot:1

 +23               IF DPTX=" "

                       SET Y=$SELECT('($DATA(DUZ)#2):-1,$DATA(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1)

 +24               IF $EXTRACT(DPTX)="`"

                       SET Y=$SELECT($DATA(^DPT(+$PIECE(DPTX,"`",2),0)):+$PIECE(DPTX,"`",2),1:-1)

 +25               IF Y<1

                       QUIT 

                   IF '$DATA(^DPT(Y,0))

                       QUIT 

                   DO SETDPT

                   SET DPTCNT=1

 +26               QUIT 

               End DoDot:1

               QUIT DPTCNT

 +27       DO FIND

 +28       QUIT $SELECT(DPTLMAX&(DPTCNT>DPTLMAX):DPTLMAX,1:DPTCNT)

 +29      ;

UCASE(DGX) ;Uppercase lookup value

 +1       ;Input: DGX=lookup value

 +2       ;Output: transformed DGX

 +3        NEW DGI,DGY,DGZ

           SET DGZ=DGX

           SET DGX=""

 +4        FOR DGI=1:1:$LENGTH(DGZ)

               SET DGY=$EXTRACT(DGZ,DGI)

               Begin DoDot:1

 +5                IF DGY?1L

                       SET DGY=$CHAR($ASCII(DGY)-32)

 +6                SET DGX=DGX_DGY

               End DoDot:1

 +7        QUIT DGX

 +8       ;        

SSN(DFN)  ;do not show ssn identifier for patient

 +1       ; input DFN = ien in file #2 [required]

 +2       ; output SSN = nnnnnnnnn

 +3       ;

 +4        NEW SSN

 +5        SET SSN=""

           SET DFN=+DFN

 +6        IF DFN>0

               Begin DoDot:1

 +7                IF $$SCREEN(DFN)

                       SET SSN="*SENSITIVE*"

                       QUIT 

 +8                SET SSN=$PIECE($GET(^DPT(DFN,0)),U,9)

 +9       ; DG*5.3*657 BAJ 11/20 2005

 +10      ; display Pseudo SSN alert on list

 +11               IF SSN?9N1"P"

                       SET SSN=SSN_" **Pseudo SSN**"

 +12               QUIT 

               End DoDot:1

 +13       QUIT SSN

 +14      ;

DOB(DFN,DGYR) ;do not show dob identifier for patient

 +1       ; input DFN = ien in file #2  [required]

 +2       ;       DGYR = 0/1  [optional]

 +3       ;              where 0 returns 4-digit year (default)

 +4       ;                    1 returns 2-digit year

 +5       ;                    2 returns File manager date

 +6       ; output DOB = mm/dd/yyyy (default)

 +7       ;            = mm/dd/yy, if DGYR=1

 +8       ;            = yyymmdd, if DGYR=2

 +9        NEW B,DOB,YEAR

 +10       SET DOB=""

           SET DFN=+DFN

           SET DGYR=+$GET(DGYR)

 +11       IF DFN>0

               Begin DoDot:1

 +12               IF $$SCREEN(DFN)

                       SET DOB="*SENSITIVE*"

                       QUIT 

 +13               SET B=$PIECE($GET(^DPT(DFN,0)),U,3)

 +14               IF DGYR'=2

                       Begin DoDot:2

 +15                       SET YEAR=$SELECT(DGYR=1:"2D",1:"5D")

 +16                       SET DOB=$$FMTE^XLFDT(B,YEAR)

                       End DoDot:2

                       QUIT 

 +17               SET DOB=B

               End DoDot:1

 +18       QUIT DOB

 +19      ;

SCREEN(DFN) ;Screening logic for SSN & DOB

 +1       ;Input  : DFN - Pointer to PATIENT file (#2)

 +2       ;Output : 1 - Apply screen

 +3       ;         0 - Don't apply screen

 +4       ;Notes  : Screen applied if patient is sensitive or an employee

 +5       ;

 +6        NEW DGTIME,DGT,DGA1,DG1,DGXFR0

 +7       ;Inpatient check - no longer used (kept for future reference)

 +8       ;D H^DGUTL S DGT=DGTIME D ^DGPMSTAT I DG1 Q 0

 +9       ;Sensitive - screen

 +10       IF $PIECE($GET(^DGSL(38.1,DFN,0)),"^",2)

               QUIT 1

 +11      ;Employee - screen

 +12       IF $$EMPL^DGSEC4(DFN)

               QUIT 1

 +13      ;Don't screen

 +14       QUIT 0