DGWPT ; SLC/KCM/REV - Patient Lookup Functions ;3/20/02
;;5.3;Registration;**447,796**;Aug 13, 1993;Build 6
;
SELCHK(REC,DFN) ; Check for sensitive pt
; SENSITIVE
S REC=$$EN1^DGQPT2(DFN)
Q
DIEDON(VAL,DFN) ; Check for a date of death
S VAL=+$G(^DPT(DFN,.35))
Q
BYWARD(LST,WARD) ; Return a list of patients in a ward
N ILST,DFN
I +$G(WARD)<1 S LST(1)="^No ward identified" Q
S (ILST,DFN)=0
S WARD=$P(^DIC(42,WARD,0),"^") ;DBIA #36
F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D
. S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101))
I ILST<1 S LST(1)="^No patients found."
Q
TOP(LST) ; Return top for all patients list (last selected for now)
N IEN
S IEN=$G(^DISV(DUZ,"^DPT("))
I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U)
Q
CLINRNG(LST) ; return date ranges for clinic appointments
S LST(1)="T;T^Today"
S LST(2)="T+1;T+1^Tomorrow"
S LST(3)="T-1;T-1^Yesterday"
S LST(4)="T-7;T^Past Week"
S LST(5)="T-31;T^Past Month"
S LST(6)="S^Specify Date Range..."
Q
;
N %,%H,X,SUNDAY,START
S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1)
S LST(2)=X_";"_X_"^Tomorrow"
S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday
S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week"
S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week"
S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month"
S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0)
S LST(6)=X_"01;"_X_"31^Next Month"
S LST(7)="^Specify Dates"
Q
DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S)
N SRV S SRV=+$G(^VA(200,DUZ,5))
S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE")
Q
SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt)
G SAVDFLT^DGWPT1
;
SELECT(REC,DFN) ; Selects patient & returns key information
; 1 2 3 4 5 6 7 8 9 10 11 12
; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^
; 13 14 15 16
; SC%^ICN^AGE^TS
N X
K ^TMP("DGWPCE",$J) ; delete PCE 'cache' when switching patients
S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101))
S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44))
S $P(REC,U,8)=$$CWAD^DGQPT2(DFN)_U_$$EN1^DGQPT2(DFN)
; I $P(REC,U,9) D EN2^DGQPT2(DFN) ;update DG security log ; DG249
S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U)
S:'$D(IOST) IOST="P-OTHER"
S $P(REC,U,11)=0
D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC%
I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X
S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3))
S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty
K VAEL,VAERR ;VADPT call to kill?
S ^DISV(DUZ,"^DPT(")=DFN
Q
;
AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT)
N END,X
S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT)
S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGWPT 3012 printed Sep 23, 2025@20:35:10 Page 2
DGWPT ; SLC/KCM/REV - Patient Lookup Functions ;3/20/02
+1 ;;5.3;Registration;**447,796**;Aug 13, 1993;Build 6
+2 ;
SELCHK(REC,DFN) ; Check for sensitive pt
+1 ; SENSITIVE
+2 SET REC=$$EN1^DGQPT2(DFN)
+3 QUIT
DIEDON(VAL,DFN) ; Check for a date of death
+1 SET VAL=+$GET(^DPT(DFN,.35))
+2 QUIT
BYWARD(LST,WARD) ; Return a list of patients in a ward
+1 NEW ILST,DFN
+2 IF +$GET(WARD)<1
SET LST(1)="^No ward identified"
QUIT
+3 SET (ILST,DFN)=0
+4 ;DBIA #36
SET WARD=$PIECE(^DIC(42,WARD,0),"^")
+5 FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
if DFN'>0
QUIT
Begin DoDot:1
+6 SET ILST=ILST+1
SET LST(ILST)=+DFN_U_$PIECE(^DPT(+DFN,0),U)_U_$GET(^DPT(+DFN,.101))
End DoDot:1
+7 IF ILST<1
SET LST(1)="^No patients found."
+8 QUIT
TOP(LST) ; Return top for all patients list (last selected for now)
+1 NEW IEN
+2 SET IEN=$GET(^DISV(DUZ,"^DPT("))
+3 IF IEN
SET LST(1)=IEN_U_$PIECE($GET(^DPT(IEN,0)),U)
+4 QUIT
CLINRNG(LST) ; return date ranges for clinic appointments
+1 SET LST(1)="T;T^Today"
+2 SET LST(2)="T+1;T+1^Tomorrow"
+3 SET LST(3)="T-1;T-1^Yesterday"
+4 SET LST(4)="T-7;T^Past Week"
+5 SET LST(5)="T-31;T^Past Month"
+6 SET LST(6)="S^Specify Date Range..."
+7 QUIT
+8 ;
+9 NEW %,%H,X,SUNDAY,START
+10 SET LST(1)=DT_";"_DT_"^Today"
SET X=$$HTFM^XLFDT($HOROLOG+1,1)
+11 SET LST(2)=X_";"_X_"^Tomorrow"
+12 ; $H#7=3 is Sunday
SET X=+$HOROLOG
FOR
if X#7=3
QUIT
SET X=X-1
+13 SET LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week"
+14 SET LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week"
+15 SET LST(5)=$EXTRACT(DT,1,5)_"01;"_$EXTRACT(DT,1,5)_"31^This Month"
+16 SET X=$EXTRACT(DT,4,5)+1
if X=13
SET X=1
SET X=$EXTRACT(DT,1,3)_$TRANSLATE($JUSTIFY(X,2)," ",0)
+17 SET LST(6)=X_"01;"_X_"31^Next Month"
+18 SET LST(7)="^Specify Dates"
+19 QUIT
DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S)
+1 NEW SRV
SET SRV=+$GET(^VA(200,DUZ,5))
+2 SET VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE")
+3 QUIT
SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt)
+1 GOTO SAVDFLT^DGWPT1
+2 ;
SELECT(REC,DFN) ; Selects patient & returns key information
+1 ; 1 2 3 4 5 6 7 8 9 10 11 12
+2 ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^
+3 ; 13 14 15 16
+4 ; SC%^ICN^AGE^TS
+5 NEW X
+6 ; delete PCE 'cache' when switching patients
KILL ^TMP("DGWPCE",$JOB)
+7 SET X=^DPT(DFN,0)
SET REC=$PIECE(X,U,1,3)_U_$PIECE(X,U,9)_U_U_$GET(^(.1))_U_$GET(^(.101))
+8 SET X=$PIECE(REC,U,6)
IF $LENGTH(X)
SET $PIECE(REC,U,5)=+$GET(^DIC(42,+$ORDER(^DIC(42,"B",X,0)),44))
+9 SET $PIECE(REC,U,8)=$$CWAD^DGQPT2(DFN)_U_$$EN1^DGQPT2(DFN)
+10 ; I $P(REC,U,9) D EN2^DGQPT2(DFN) ;update DG security log ; DG249
+11 SET X=$GET(^DPT(DFN,.105))
IF X
SET $PIECE(REC,U,10)=$PIECE($GET(^DGPM(X,0)),U)
+12 if '$DATA(IOST)
SET IOST="P-OTHER"
+13 SET $PIECE(REC,U,11)=0
+14 ;two pieces: SC^SC%
DO ELIG^VADPT
SET $PIECE(REC,U,12)=$GET(VAEL(3))
+15 IF $LENGTH($TEXT(GETICN^MPIF001))
SET X=+$$GETICN^MPIF001(DFN)
if X>0
SET $PIECE(REC,U,14)=X
+16 SET $PIECE(REC,U,15)=$$AGE(DFN,$PIECE(REC,U,3))
+17 ; treating specialty
SET $PIECE(REC,U,16)=+$GET(^DPT(DFN,.103))
+18 ;VADPT call to kill?
KILL VAEL,VAERR
+19 SET ^DISV(DUZ,"^DPT(")=DFN
+20 QUIT
+21 ;
AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT)
+1 NEW END,X
+2 SET END=+$GET(^DPT(DFN,.35))
SET END=$SELECT(END:END,1:DT)
+3 SET X=$EXTRACT(END,1,3)-$EXTRACT(BEG,1,3)-($EXTRACT(END,4,7)<$EXTRACT(BEG,4,7))
+4 QUIT X
