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
