SDEC28L ;ALB/LEG,JLS,LAB,BWF - VISTA SCHEDULING GET PAT DEMOG RPC ;JUL 26,2022
;;5.3;Scheduling;**785,823,825**;Aug 13, 1993;Build 2
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to ^AUPNPAT(DFN in ICR #7048
; Reference to ^DPT in ICR #10035
Q
;This Routine is a "LITE" version of the rtn SDEC28-Patient info lookup for RPC SDEC PTLOOKRS.
; It generates only "PATIENT NAME, SSN, DOB, DFN, SEX, ELIGIBILITY" fields
; and finds up to "SDECC" number of patients that match the "SDECP" defined lookup criteria.
;
;The Patient lookup supports input in the form of:
; a)#DFN, b)DOB, c)SSN, d)First letter of LastName followed by L4SSN,
; e)PartialName or f)NULL for ALL
;Vars In:
; SDECP - (optional) Free-Text - Partial name to look up
; SDECC - (optional) Max number of patients to return; defaults to 10
; LASTSUB - (optional) last subscripts from previous call
;Var Out:
; SDECY (^TMP("SDEC",$J))
;
;PTLOOKRSLITE(SDECY,SDECP,SDECC,LASTSUB) ;Patient Lookup
GETPATDEMOG(SDECY,SDECP,SDECC,LASTSUB) ;Get Patient Demographics ("PATIENT NAME, SSN, DOB, DFN, SEX, ELIGIBILITY")
S SDECI=0
S SDECP=$TR(SDECP,$C(13),"")
S SDECP=$TR(SDECP,$C(10),"")
S SDECP=$TR(SDECP,$C(9),"")
S:$G(SDECC)="" SDECC=10
S LASTSUB=$G(LASTSUB)
N PLIST,SDTMP,SDECHRN,SDECZ,SDECRET,DFN
N %DT,X,Y,SDECX
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="T00030ERROR_CODE^T00030ERROR_TEXT"_$C(30)
I '+$G(DUZ) S SDECI=SDECI+1 S @SDECY@(SDECI)="0^Invalid User."_$C(30)_$C(31) Q
I '$D(DUZ(2)) S SDECI=SDECI+1 S @SDECY@(SDECI)="0^Invalid Institution."_$C(30)_$C(31) Q
S SDTMP="T00030NAME^T00030SSN^D00030DOB^T00030GENDER^T00030TYPENAME^T00030LASTSUB^T00030IEN^T00030SENSITIVE" ; 7
S ^TMP("SDEC",$J,0)=SDTMP_$C(30)
;
DFN ;Patient ID passed in
I $E(SDECP)="#" D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
. S DFN=$E(SDECP,2,$L(SDECP))
. Q:'$D(^DPT(DFN,0))
. S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
. ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
. ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
. D GET1(DFN,SDECHRN,.SDECI,SDECY)
. Q
;
DOB ;DOB Lookup
I +DUZ(2),((SDECP?1.2N1"/"1.2N1"/"1.4N)!(SDECP?1.2N1" "1.2N1" "1.4N)!(SDECP?1.2N1"-"1.2N1"-"1.4N)!(SDECP?1.2N1"."1.2N1"."1.4N)) D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
. S X=SDECP S %DT="P" D ^%DT S SDECP=Y Q:'+Y
. Q:'$D(^DPT("ADOB",SDECP))
. S DFN=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1),1:0)
. S LASTSUB=""
. F S DFN=$O(^DPT("ADOB",SDECP,DFN)) Q:'+DFN D Q:SDECI'<SDECC
. . Q:'$D(^DPT(DFN,0))
. . S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
. . ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
. . ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
. . D GET1(DFN,SDECHRN,.SDECI,SDECY,DFN)
. . Q
. I SDECI>0,'+DFN S $P(@SDECY@(SDECI),U,6)=""
. Q
;
;SSN Lookup
;I (SDECP?4.9N)!(SDECP?9N.1"P")!(SDECP?3N1"-"2N1"-"4N.1"P") D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
I (SDECP?4N)!(SDECP?9N)!(SDECP?9N.1"P")!(SDECP?3N1"-"2N1"-"4N.1"P") D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q ;VSE-168 LEG 5/12/21 eliminates ?1A1.3n
.;SSN Lookup (BS - last 4)
.I SDECP?4N D
..S SDECP1=SDECP
..S DFN=0 F S DFN=$O(^DPT("BS",SDECP1,DFN)) Q:'+DFN D
...Q:'$D(^DPT(DFN,0))
...S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
...;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
...;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
...D GET1(DFN,SDECHRN,.SDECI,SDECY)
.E D SSN(SDECP,.SDECI,SDECY) ;(partial/full ssn)
;
;SSN Lookup (BS5)
;I SDECP?1A1.4N D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
I SDECP?1A4N D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q ;VSE-168 LEG 5/12/21 eliminates ?1A1.3N
.S SDECP1=$S(SDECP?1A4N:$E(SDECP,1,4)_$C($A($E(SDECP,5))-1),1:SDECP)
.F S SDECP1=$O(^DPT("BS5",SDECP1)) Q:SDECP1="" Q:SDECP1'[SDECP Q:(SDECP?1A4N)&(SDECP1'=SDECP) D
..S DFN=0 F S DFN=$O(^DPT("BS5",SDECP1,DFN)) Q:'+DFN D
...Q:'$D(^DPT(DFN,0))
...S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
...;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
...;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
...D GET1(DFN,SDECHRN,.SDECI,SDECY)
;
;Chart# Lookup (not currently used)
I 0,+DUZ(2),SDECP]"",$D(^AUPNPAT("D",SDECP)) D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
. S DFN=0 F S DFN=$O(^AUPNPAT("D",SDECP,DFN)) Q:'+DFN I $D(^AUPNPAT("D",SDECP,DFN,DUZ(2))) D Q
. . Q:'$D(^DPT(DFN,0))
. . S SDECHRN=SDECP ;CHART
. . ;I $D(^AUPNPAT(DFN,41,DUZ(2),0)),$P(^(0),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
. . D GET1(DFN,SDECHRN,.SDECI,SDECY)
. . Q
. Q
;
;Partial name
N SDARR
;lab testing I SDECP?2.A.E D Q
I SDECP?1.A.E D Q
.;F SDECX=1:1:$P(SDECRSLT("DILIST",0),U) D
.; restrict lookup to 30 characters to prevent <SUBSCRIPT> error for extremely long values - INC23935053
.S SDECP=$E(SDECP,1,30)
.S SDECX=$S($P(LASTSUB,U,1)'="":$$GETSUB^SDECU($P(LASTSUB,U,1)),1:$$GETSUB^SDECU(SDECP))
.F S SDECX=$O(^DPT("B",SDECX)) Q:SDECX'[SDECP Q:SDECX="" D Q:SDECI'<SDECC
..S DFN=$S($P(LASTSUB,U,2)'="":$P(LASTSUB,U,2),1:0)
..S LASTSUB=""
..F S DFN=$O(^DPT("B",SDECX,DFN)) Q:DFN="" D Q:SDECI'<SDECC
...Q:$D(SDARR(DFN))
...S SDARR(DFN)=""
...S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
...;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
...;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
...D GET1(DFN,SDECHRN,.SDECI,SDECY,SDECX_"|"_DFN)
...Q
.I SDECI>0,(SDECX="")!(SDECX'[SDECP) S $P(@SDECY@(SDECI),U,6)=""
.S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
;
;All Patients
N FROM,SDSUB,SDECCNT
;I SDECP'?1N.E D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
I SDECP="" D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
. K PLIST
. S FROM=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1),1:"")
. D LISTALL^SDECPTPL(.PLIST,FROM,1,SDECC)
. S SDECCNT=0 F S SDECCNT=$O(PLIST(SDECCNT)) Q:'SDECCNT D
. . S DFN=$P(PLIST(SDECCNT),U)
. . S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
. . ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
. . ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
. . S SDSUB=$P(PLIST(SDECCNT),U,2)
. . D GET1(DFN,SDECHRN,.SDECI,SDECY,SDSUB)
. . Q
. Q
S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31)
Q
;
GET1(DFN,SDECHRN,SDECI,SDECY,LSUB) ;
N SDECZ,SDECDPT,SDDEMO
Q:'+$G(DFN)
Q:'$D(^DPT(DFN,0))
S SDECI=$G(SDECI)
S LSUB=$G(LSUB)
S SDECZ=""
S SDECZ=$$GET1^DIQ(2,DFN_",",.01) ; NAME
Q:SDECZ=""
S SDECDPT=$G(^DPT(DFN,0))
S $P(SDECZ,U,2)=$$LAST4SSN^SDESINPUTVALUTL(DFN)
S Y=$P(SDECDPT,U,3) X ^DD("DD")
S $P(SDECZ,U,3)=Y ;DOB
S $P(SDECZ,U,4)=$P(SDECDPT,U,2) ;Gender
D PDEMO^SDECU3(.SDDEMO,DFN) ;use to get PATIENT ENROLLMENT data ;alb/sat 658 PDEMO moved to SDECU3
S $P(SDECZ,U,5)=SDDEMO("TYPENAME")
S $P(SDECZ,U,6)=$P(SDECZ,U)_"|"_DFN ; NAME|DFN
S $P(SDECZ,U,7)=DFN ;
S $P(SDECZ,U,8)=$$PTSEC^SDECUTL(DFN) ;8 - sensitivity
S SDECI=SDECI+1 S @SDECY@(SDECI)=SDECZ_$C(30)
Q
;
SSN(SDECP,SDECI,SDECY) ;
S SDECP=$TR(SDECP,"-","") ;LEG 05/10/2021-needed to fix 3N-2N-4N format
I $D(^DPT("SSN",$E(SDECP,1,9)_"P")) D
.N SDECP1
.S SDECP1=$E(SDECP,1,9)_"O"
.S SDECP1=$O(^DPT("SSN",SDECP1)) Q:SDECP1="" Q:SDECP1'[$E(SDECP,1,9) D SSN1
E D
.N SDLEN S SDLEN=$L(SDECP)
.I SDLEN=9 S SDECP1=SDECP D SSN1
.E D
..S SDECP1=SDECP_$$FILL^SDECU(9-SDLEN,0)
..F S SDECP1=$O(^DPT("SSN",SDECP1)) Q:SDECP1="" Q:$E(SDECP1,1,SDLEN)'=SDECP D SSN1
Q
SSN1 ;
S DFN=0 F S DFN=$O(^DPT("SSN",SDECP1,DFN)) Q:'+DFN D
.Q:'$D(^DPT(DFN,0))
.S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
.;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
.;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
.D GET1(DFN,SDECHRN,.SDECI,SDECY)
.Q
Q
;
ERROR ;
D ERR("Error")
Q
;
ERR(ERRNO) ;Error processing
S SDECRET="T00030NAME^T00030SSN^D00030DOB^T00030IEN^T00030GENDER^T00030TYPENAME^T00030LASTSUB"_$C(30)_$C(31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC28L 8294 printed Nov 22, 2024@18:00:24 Page 2
SDEC28L ;ALB/LEG,JLS,LAB,BWF - VISTA SCHEDULING GET PAT DEMOG RPC ;JUL 26,2022
+1 ;;5.3;Scheduling;**785,823,825**;Aug 13, 1993;Build 2
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to ^AUPNPAT(DFN in ICR #7048
+5 ; Reference to ^DPT in ICR #10035
+6 QUIT
+7 ;This Routine is a "LITE" version of the rtn SDEC28-Patient info lookup for RPC SDEC PTLOOKRS.
+8 ; It generates only "PATIENT NAME, SSN, DOB, DFN, SEX, ELIGIBILITY" fields
+9 ; and finds up to "SDECC" number of patients that match the "SDECP" defined lookup criteria.
+10 ;
+11 ;The Patient lookup supports input in the form of:
+12 ; a)#DFN, b)DOB, c)SSN, d)First letter of LastName followed by L4SSN,
+13 ; e)PartialName or f)NULL for ALL
+14 ;Vars In:
+15 ; SDECP - (optional) Free-Text - Partial name to look up
+16 ; SDECC - (optional) Max number of patients to return; defaults to 10
+17 ; LASTSUB - (optional) last subscripts from previous call
+18 ;Var Out:
+19 ; SDECY (^TMP("SDEC",$J))
+20 ;
+21 ;PTLOOKRSLITE(SDECY,SDECP,SDECC,LASTSUB) ;Patient Lookup
GETPATDEMOG(SDECY,SDECP,SDECC,LASTSUB) ;Get Patient Demographics ("PATIENT NAME, SSN, DOB, DFN, SEX, ELIGIBILITY")
+1 SET SDECI=0
+2 SET SDECP=$TRANSLATE(SDECP,$CHAR(13),"")
+3 SET SDECP=$TRANSLATE(SDECP,$CHAR(10),"")
+4 SET SDECP=$TRANSLATE(SDECP,$CHAR(9),"")
+5 if $GET(SDECC)=""
SET SDECC=10
+6 SET LASTSUB=$GET(LASTSUB)
+7 NEW PLIST,SDTMP,SDECHRN,SDECZ,SDECRET,DFN
+8 NEW %DT,X,Y,SDECX
+9 KILL ^TMP("SDEC",$JOB)
+10 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+11 SET ^TMP("SDEC",$JOB,0)="T00030ERROR_CODE^T00030ERROR_TEXT"_$CHAR(30)
+12 IF '+$GET(DUZ)
SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^Invalid User."_$CHAR(30)_$CHAR(31)
QUIT
+13 IF '$DATA(DUZ(2))
SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^Invalid Institution."_$CHAR(30)_$CHAR(31)
QUIT
+14 ; 7
SET SDTMP="T00030NAME^T00030SSN^D00030DOB^T00030GENDER^T00030TYPENAME^T00030LASTSUB^T00030IEN^T00030SENSITIVE"
+15 SET ^TMP("SDEC",$JOB,0)=SDTMP_$CHAR(30)
+16 ;
DFN ;Patient ID passed in
+1 IF $EXTRACT(SDECP)="#"
Begin DoDot:1
+2 SET DFN=$EXTRACT(SDECP,2,$LENGTH(SDECP))
+3 if '$DATA(^DPT(DFN,0))
QUIT
+4 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+5 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+6 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+7 DO GET1(DFN,SDECHRN,.SDECI,SDECY)
+8 QUIT
End DoDot:1
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
QUIT
+9 ;
DOB ;DOB Lookup
+1 IF +DUZ(2)
IF ((SDECP?1.2N1"/"1.2N1"/"1.4N)!(SDECP?1.2N1" "1.2N1" "1.4N)!(SDECP?1.2N1"-"1.2N1"-"1.4N)!(SDECP?1.2N1"."1.2N1"."1.4N))
Begin DoDot:1
+2 SET X=SDECP
SET %DT="P"
DO ^%DT
SET SDECP=Y
if '+Y
QUIT
+3 if '$DATA(^DPT("ADOB",SDECP))
QUIT
+4 SET DFN=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1),1:0)
+5 SET LASTSUB=""
+6 FOR
SET DFN=$ORDER(^DPT("ADOB",SDECP,DFN))
if '+DFN
QUIT
Begin DoDot:2
+7 if '$DATA(^DPT(DFN,0))
QUIT
+8 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+9 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+10 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+11 DO GET1(DFN,SDECHRN,.SDECI,SDECY,DFN)
+12 QUIT
End DoDot:2
if SDECI'<SDECC
QUIT
+13 IF SDECI>0
IF '+DFN
SET $PIECE(@SDECY@(SDECI),U,6)=""
+14 QUIT
End DoDot:1
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
QUIT
+15 ;
+16 ;SSN Lookup
+17 ;I (SDECP?4.9N)!(SDECP?9N.1"P")!(SDECP?3N1"-"2N1"-"4N.1"P") D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
+18 ;VSE-168 LEG 5/12/21 eliminates ?1A1.3n
IF (SDECP?4N)!(SDECP?9N)!(SDECP?9N.1"P")!(SDECP?3N1"-"2N1"-"4N.1"P")
Begin DoDot:1
+19 ;SSN Lookup (BS - last 4)
+20 IF SDECP?4N
Begin DoDot:2
+21 SET SDECP1=SDECP
+22 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("BS",SDECP1,DFN))
if '+DFN
QUIT
Begin DoDot:3
+23 if '$DATA(^DPT(DFN,0))
QUIT
+24 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+25 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+26 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+27 DO GET1(DFN,SDECHRN,.SDECI,SDECY)
End DoDot:3
End DoDot:2
+28 ;(partial/full ssn)
IF '$TEST
DO SSN(SDECP,.SDECI,SDECY)
End DoDot:1
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
QUIT
+29 ;
+30 ;SSN Lookup (BS5)
+31 ;I SDECP?1A1.4N D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
+32 ;VSE-168 LEG 5/12/21 eliminates ?1A1.3N
IF SDECP?1A4N
Begin DoDot:1
+33 SET SDECP1=$SELECT(SDECP?1A4N:$EXTRACT(SDECP,1,4)_$CHAR($ASCII($EXTRACT(SDECP,5))-1),1:SDECP)
+34 FOR
SET SDECP1=$ORDER(^DPT("BS5",SDECP1))
if SDECP1=""
QUIT
if SDECP1'[SDECP
QUIT
if (SDECP?1A4N)&(SDECP1'=SDECP)
QUIT
Begin DoDot:2
+35 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("BS5",SDECP1,DFN))
if '+DFN
QUIT
Begin DoDot:3
+36 if '$DATA(^DPT(DFN,0))
QUIT
+37 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+38 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+39 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+40 DO GET1(DFN,SDECHRN,.SDECI,SDECY)
End DoDot:3
End DoDot:2
End DoDot:1
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
QUIT
+41 ;
+42 ;Chart# Lookup (not currently used)
+43 IF 0
IF +DUZ(2)
IF SDECP]""
IF $DATA(^AUPNPAT("D",SDECP))
Begin DoDot:1
+44 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT("D",SDECP,DFN))
if '+DFN
QUIT
IF $DATA(^AUPNPAT("D",SDECP,DFN,DUZ(2)))
Begin DoDot:2
+45 if '$DATA(^DPT(DFN,0))
QUIT
+46 ;CHART
SET SDECHRN=SDECP
+47 ;I $D(^AUPNPAT(DFN,41,DUZ(2),0)),$P(^(0),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+48 DO GET1(DFN,SDECHRN,.SDECI,SDECY)
+49 QUIT
End DoDot:2
QUIT
+50 QUIT
End DoDot:1
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
QUIT
+51 ;
+52 ;Partial name
+53 NEW SDARR
+54 ;lab testing I SDECP?2.A.E D Q
+55 IF SDECP?1.A.E
Begin DoDot:1
+56 ;F SDECX=1:1:$P(SDECRSLT("DILIST",0),U) D
+57 ; restrict lookup to 30 characters to prevent <SUBSCRIPT> error for extremely long values - INC23935053
+58 SET SDECP=$EXTRACT(SDECP,1,30)
+59 SET SDECX=$SELECT($PIECE(LASTSUB,U,1)'="":$$GETSUB^SDECU($PIECE(LASTSUB,U,1)),1:$$GETSUB^SDECU(SDECP))
+60 FOR
SET SDECX=$ORDER(^DPT("B",SDECX))
if SDECX'[SDECP
QUIT
if SDECX=""
QUIT
Begin DoDot:2
+61 SET DFN=$SELECT($PIECE(LASTSUB,U,2)'="":$PIECE(LASTSUB,U,2),1:0)
+62 SET LASTSUB=""
+63 FOR
SET DFN=$ORDER(^DPT("B",SDECX,DFN))
if DFN=""
QUIT
Begin DoDot:3
+64 if $DATA(SDARR(DFN))
QUIT
+65 SET SDARR(DFN)=""
+66 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+67 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+68 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+69 DO GET1(DFN,SDECHRN,.SDECI,SDECY,SDECX_"|"_DFN)
+70 QUIT
End DoDot:3
if SDECI'<SDECC
QUIT
End DoDot:2
if SDECI'<SDECC
QUIT
+71 IF SDECI>0
IF (SDECX="")!(SDECX'[SDECP)
SET $PIECE(@SDECY@(SDECI),U,6)=""
+72 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
End DoDot:1
QUIT
+73 ;
+74 ;All Patients
+75 NEW FROM,SDSUB,SDECCNT
+76 ;I SDECP'?1N.E D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
+77 IF SDECP=""
Begin DoDot:1
+78 KILL PLIST
+79 SET FROM=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1),1:"")
+80 DO LISTALL^SDECPTPL(.PLIST,FROM,1,SDECC)
+81 SET SDECCNT=0
FOR
SET SDECCNT=$ORDER(PLIST(SDECCNT))
if 'SDECCNT
QUIT
Begin DoDot:2
+82 SET DFN=$PIECE(PLIST(SDECCNT),U)
+83 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+84 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+85 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+86 SET SDSUB=$PIECE(PLIST(SDECCNT),U,2)
+87 DO GET1(DFN,SDECHRN,.SDECI,SDECY,SDSUB)
+88 QUIT
End DoDot:2
+89 QUIT
End DoDot:1
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
QUIT
+90 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
+91 QUIT
+92 ;
GET1(DFN,SDECHRN,SDECI,SDECY,LSUB) ;
+1 NEW SDECZ,SDECDPT,SDDEMO
+2 if '+$GET(DFN)
QUIT
+3 if '$DATA(^DPT(DFN,0))
QUIT
+4 SET SDECI=$GET(SDECI)
+5 SET LSUB=$GET(LSUB)
+6 SET SDECZ=""
+7 ; NAME
SET SDECZ=$$GET1^DIQ(2,DFN_",",.01)
+8 if SDECZ=""
QUIT
+9 SET SDECDPT=$GET(^DPT(DFN,0))
+10 SET $PIECE(SDECZ,U,2)=$$LAST4SSN^SDESINPUTVALUTL(DFN)
+11 SET Y=$PIECE(SDECDPT,U,3)
XECUTE ^DD("DD")
+12 ;DOB
SET $PIECE(SDECZ,U,3)=Y
+13 ;Gender
SET $PIECE(SDECZ,U,4)=$PIECE(SDECDPT,U,2)
+14 ;use to get PATIENT ENROLLMENT data ;alb/sat 658 PDEMO moved to SDECU3
DO PDEMO^SDECU3(.SDDEMO,DFN)
+15 SET $PIECE(SDECZ,U,5)=SDDEMO("TYPENAME")
+16 ; NAME|DFN
SET $PIECE(SDECZ,U,6)=$PIECE(SDECZ,U)_"|"_DFN
+17 ;
SET $PIECE(SDECZ,U,7)=DFN
+18 ;8 - sensitivity
SET $PIECE(SDECZ,U,8)=$$PTSEC^SDECUTL(DFN)
+19 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=SDECZ_$CHAR(30)
+20 QUIT
+21 ;
SSN(SDECP,SDECI,SDECY) ;
+1 ;LEG 05/10/2021-needed to fix 3N-2N-4N format
SET SDECP=$TRANSLATE(SDECP,"-","")
+2 IF $DATA(^DPT("SSN",$EXTRACT(SDECP,1,9)_"P"))
Begin DoDot:1
+3 NEW SDECP1
+4 SET SDECP1=$EXTRACT(SDECP,1,9)_"O"
+5 SET SDECP1=$ORDER(^DPT("SSN",SDECP1))
if SDECP1=""
QUIT
if SDECP1'[$EXTRACT(SDECP,1,9)
QUIT
DO SSN1
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 NEW SDLEN
SET SDLEN=$LENGTH(SDECP)
+8 IF SDLEN=9
SET SDECP1=SDECP
DO SSN1
+9 IF '$TEST
Begin DoDot:2
+10 SET SDECP1=SDECP_$$FILL^SDECU(9-SDLEN,0)
+11 FOR
SET SDECP1=$ORDER(^DPT("SSN",SDECP1))
if SDECP1=""
QUIT
if $EXTRACT(SDECP1,1,SDLEN)'=SDECP
QUIT
DO SSN1
End DoDot:2
End DoDot:1
+12 QUIT
SSN1 ;
+1 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("SSN",SDECP1,DFN))
if '+DFN
QUIT
Begin DoDot:1
+2 if '$DATA(^DPT(DFN,0))
QUIT
+3 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+4 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+5 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+6 DO GET1(DFN,SDECHRN,.SDECI,SDECY)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
ERROR ;
+1 DO ERR("Error")
+2 QUIT
+3 ;
ERR(ERRNO) ;Error processing
+1 SET SDECRET="T00030NAME^T00030SSN^D00030DOB^T00030IEN^T00030GENDER^T00030TYPENAME^T00030LASTSUB"_$CHAR(30)_$CHAR(31)
+2 QUIT
