SDEC28 ;ALB/SAT,LEG,LAB - VISTA SCHEDULING RPCS ;JUL 25,2022
;;5.3;Scheduling;**627,642,658,679,785,792,823**;Aug 13, 1993;Build 9
;;Per VHA Directive 6402, this routine should not be modified
;
; ajf;010318; Adding PCP and MHP to return
; leg;051021; Fixed 3N-2N-4N format in SSN
; leg;051221; Eliminated Patient Identifier as ?1A1.3N
;
Q
;
PTLOOKRS(SDECY,SDECP,SDECC,LASTSUB) ;Patient Lookup
;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
;Find up to SDECC patients matching SDECP*
;Supports DOB Lookup, SSN Lookup
;
N SDECI
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 GAF,PADDRES1,PADDRES2,PADDRES3,PCITY,PLIST,PSTATE,PCOUNTRY,PZIP4
N SDTMP,SDECHRN,SDECZ,SDECRET,SDECDPT,SDECRET,DFN,SDECFILE
N SDECIENS,SDECFIELDS,SDECFLAGS,SDECVALUE,SDECNUMBER,SDECINDEXES,SDECSCREEN
N SDECTARG,SDECMSG,SDECRSLT,SDECCNT,SDDEMO,%DT,X,Y,SDECIDEN,SDECX,SDSENS
N PRACE,PRACEN,PETH,PETHN,SDPCP,SDMHP
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^T00030HRN^T00030SSN^D00030DOB^T00030IEN^T00030GENDER^I00010INSTIEN^T00030INSTNAME" ;8
S SDTMP=SDTMP_"^I00010USERIEN^T00030USERNAME" ;10
S SDTMP=SDTMP_"^T00030PRIGRP^T00030ELIGIEN^T00030ELIGNAME^T00030SVCCONN^T00030SVCCONNP" ;15
S SDTMP=SDTMP_"^T00030TYPEIEN^T00030TYPENAME^T00030PADDRES1^T00030PADDRES2" ;19
S SDTMP=SDTMP_"^T00030PADDRES3^T00030PCITY^T00030PSTATE^T00030PCOUNTRY^T00030PZIP4" ;24
S SDTMP=SDTMP_"^T00030GAF^T00100SENSITIVE^T00030PRACE^T00030PRACEN^T00030PETH^T00030PETHN" ;30
S SDTMP=SDTMP_"^T00030LASTSUB" ;31
S SDTMP=SDTMP_"^T00030BADADD^T00030HPHONE^T00030OPHONE^T00030NOK^T00030KNAME^T00030KREL^T00030KPHONE" ;38
S SDTMP=SDTMP_"^T00030KSTREET^T00030KSTREET2^T00030KSTREET3^T00030KCITY^T00030KSTATE^T00030KZIP" ;43
S SDTMP=SDTMP_"^T00030NOK2^T00030K2NAME^T00030K2REL^T00030K2PHONE" ;47
S SDTMP=SDTMP_"^T00030K2STREET^T00030K2STREET2^T00030K2STREET3^T00030K2CITY^T00030K2STATE^T00030K2ZIP" ;53
S SDTMP=SDTMP_"^T00030PCOUNTY^T00030PMARITAL^T00030PRELIGION^T00030PTACTIVE"
S SDTMP=SDTMP_"^T00030PTADDRESS1^T00030PTADDRESS2^T00030PTADDRESS3^T00030PTCITY^T00030PTSTATE^T00030PTZIP^T00030PTZIP+4" ;65
S SDTMP=SDTMP_"^T00030PTCOUNTRY^T00030PTCOUNTY^T00030PTPHONE^T00030PTSTART^T00030PTEND" ;70
S SDTMP=SDTMP_"^T00030PCELL^T00030PPAGER^T00030PEMAIL^T00030PF_FFF^T00030PF_VCD^T00030PFNATIONAL^T00030PFLOCAL" ;77
S SDTMP=SDTMP_"^T00030SUBGRP^T00030CAT8G^T01000SIMILAR^T00030PCP^T00030MHP" ;80
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: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)
. 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,31)=""
. 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
.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,31)=""
.S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
;
;All Patients
N FROM,SDSUB
;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 PETH,PETHN,PRACE,PRACEN
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)
Q:SDECZ=""
S $P(SDECZ,U,2)=SDECHRN
S SDECDPT=$G(^DPT(DFN,0))
S $P(SDECZ,U,3)=$$LAST4SSN^SDESINPUTVALUTL(DFN) ;SSN
S Y=$P(SDECDPT,U,3) X ^DD("DD")
S $P(SDECZ,U,4)=Y ;DOB
S $P(SDECZ,U,5)=DFN
; Add Gender
S $P(SDECZ,U,6)=$P(SDECDPT,U,2)
; Add Institution IEN and Name
S $P(SDECZ,U,7)=DUZ(2)
S $P(SDECZ,U,8)=$P(^DIC(4,DUZ(2),0),U)
; Add User IEN and Name
S $P(SDECZ,U,9)=DUZ
S $P(SDECZ,U,10)=$P(^VA(200,DUZ,0),U)
D PDEMO^SDECU3(.SDDEMO,DFN) ;use to get PATIENT ENROLLMENT data ;alb/sat 658 PDEMO moved to SDECU3
S $P(SDECZ,U,11)=SDDEMO("PRIGRP")
S $P(SDECZ,U,12)=SDDEMO("ELIGIEN")
S $P(SDECZ,U,13)=SDDEMO("ELIGNAME")
S $P(SDECZ,U,14)=SDDEMO("SVCCONN")
S $P(SDECZ,U,15)=SDDEMO("SVCCONNP")
S $P(SDECZ,U,16)=SDDEMO("TYPEIEN")
S $P(SDECZ,U,17)=SDDEMO("TYPENAME")
S $P(SDECZ,U,18)=SDDEMO("PADDRES1") ;18 - Patient Address line 1
S $P(SDECZ,U,19)=SDDEMO("PADDRES2") ;19 - Patient Address line 2
S $P(SDECZ,U,20)=SDDEMO("PADDRES3") ;20 - Patient Address line 3
S $P(SDECZ,U,21)=SDDEMO("PCITY") ;21 - Patient City
S $P(SDECZ,U,22)=SDDEMO("PSTATE") ;22 - Patient state name
S $P(SDECZ,U,23)=SDDEMO("PCOUNTRY") ;23 - Patient country ID
S $P(SDECZ,U,24)=SDDEMO("PZIP+4") ;24 - Patient Zip+4
S $P(SDECZ,U,25)=$$GAF^SDECU2(DFN) ;25
S $P(SDECZ,U,26)=$$PTSEC^SDECUTL(DFN) ;26 - sensitivity
D RACELST^SDECU2(DFN,.PRACE,.PRACEN)
S $P(SDECZ,U,27)=PRACE
S $P(SDECZ,U,28)=PRACEN
D ETH^SDECU2(DFN,.PETH,.PETHN) ;get ethnicity
S:PETH'="" $P(SDECZ,U,29)=PETH
S:PETHN'="" $P(SDECZ,U,30)=PETHN
S $P(SDECZ,U,31)=LSUB ;SDECX_"|"_DFN
S $P(SDECZ,U,32)=SDDEMO("BADADD")
S $P(SDECZ,U,33)=SDDEMO("HPHONE")
S $P(SDECZ,U,34)=SDDEMO("OPHONE")
S $P(SDECZ,U,35)=SDDEMO("NOK")
S $P(SDECZ,U,36)=SDDEMO("KNAME")
S $P(SDECZ,U,37)=SDDEMO("KREL")
S $P(SDECZ,U,38)=SDDEMO("KPHONE")
S $P(SDECZ,U,39)=SDDEMO("KSTREET")
S $P(SDECZ,U,40)=SDDEMO("KSTREET2")
S $P(SDECZ,U,41)=SDDEMO("KSTREET3")
S $P(SDECZ,U,42)=SDDEMO("KCITY")
S $P(SDECZ,U,43)=SDDEMO("KSTATE")
S $P(SDECZ,U,44)=SDDEMO("KZIP")
S $P(SDECZ,U,45)=SDDEMO("NOK2")
S $P(SDECZ,U,46)=SDDEMO("K2NAME")
S $P(SDECZ,U,47)=SDDEMO("K2REL")
S $P(SDECZ,U,48)=SDDEMO("K2PHONE")
S $P(SDECZ,U,49)=SDDEMO("K2STREET")
S $P(SDECZ,U,50)=SDDEMO("K2STREET2")
S $P(SDECZ,U,51)=SDDEMO("K2STREET3")
S $P(SDECZ,U,52)=SDDEMO("K2CITY")
S $P(SDECZ,U,53)=SDDEMO("K2STATE")
S $P(SDECZ,U,54)=SDDEMO("K2ZIP")
S $P(SDECZ,U,55)=SDDEMO("PCOUNTY")
S $P(SDECZ,U,56)=SDDEMO("PMARITAL")
S $P(SDECZ,U,57)=SDDEMO("PRELIGION")
S $P(SDECZ,U,58)=SDDEMO("PTACTIVE")
S $P(SDECZ,U,59)=SDDEMO("PTADDRESS1")
S $P(SDECZ,U,60)=SDDEMO("PTADDRESS2")
S $P(SDECZ,U,61)=SDDEMO("PTADDRESS3")
S $P(SDECZ,U,62)=SDDEMO("PTCITY")
S $P(SDECZ,U,63)=SDDEMO("PTSTATE")
S $P(SDECZ,U,64)=SDDEMO("PTZIP")
S $P(SDECZ,U,65)=SDDEMO("PTZIP+4")
S $P(SDECZ,U,66)=SDDEMO("PTCOUNTRY")
S $P(SDECZ,U,67)=SDDEMO("PTCOUNTY")
S $P(SDECZ,U,68)=SDDEMO("PTPHONE")
S $P(SDECZ,U,69)=SDDEMO("PTSTART")
S $P(SDECZ,U,70)=SDDEMO("PTEND")
S $P(SDECZ,U,71)=SDDEMO("PCELL")
S $P(SDECZ,U,72)=SDDEMO("PPAGER")
S $P(SDECZ,U,73)=SDDEMO("PEMAIL")
S $P(SDECZ,U,74)=SDDEMO("PF_FFF")
S $P(SDECZ,U,75)=SDDEMO("PF_VCD")
S $P(SDECZ,U,76)=SDDEMO("PFNATIONAL")
S $P(SDECZ,U,77)=SDDEMO("PFLOCAL")
S $P(SDECZ,U,78)=SDDEMO("SUBGRP")
S $P(SDECZ,U,79)=(SDDEMO("PRIGRP")="GROUP 8")&(SDDEMO("SUBGRP")="g")
S $P(SDECZ,U,80)=SDDEMO("SIMILAR")
;ajf
S SDPCP=$$OUTPTPR^SDUTL3(DFN) ;Return Primary Care Provider
S $P(SDECZ,U,81)=$P(SDPCP,U,2)
S SDMHP=$$START^SCMCMHTC(DFN) ;Return Mental Health Provider
S $P(SDECZ,U,82)=$P(SDMHP,U,2)
;
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^T00030HRN^T00030SSN^D00030DOB^T00030IEN^T00030GENDER"
S SDECRET=SDECRET_"^I00010INSTIEN^T00030INSTNAME^I00010USERIEN^T00030USERNAME"
S SDECRET=SDECRET_"^T00030PRIGRP^T00030ELIGIEN^T00030ELIGNAME^T00030SVCCONN^T00030SVCCONNP"_$C(30)_$C(31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC28 12751 printed Dec 13, 2024@02:50:22 Page 2
SDEC28 ;ALB/SAT,LEG,LAB - VISTA SCHEDULING RPCS ;JUL 25,2022
+1 ;;5.3;Scheduling;**627,642,658,679,785,792,823**;Aug 13, 1993;Build 9
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; ajf;010318; Adding PCP and MHP to return
+5 ; leg;051021; Fixed 3N-2N-4N format in SSN
+6 ; leg;051221; Eliminated Patient Identifier as ?1A1.3N
+7 ;
+8 QUIT
+9 ;
PTLOOKRS(SDECY,SDECP,SDECC,LASTSUB) ;Patient Lookup
+1 ;SDECP - (optional) Free-Text - Partial name to look up
+2 ;SDECC - (optional) Max number of patients to return; defaults to 10
+3 ;LASTSUB - (optional) last subscripts from previous call
+4 ;Find up to SDECC patients matching SDECP*
+5 ;Supports DOB Lookup, SSN Lookup
+6 ;
+7 NEW SDECI
+8 SET SDECI=0
+9 SET SDECP=$TRANSLATE(SDECP,$CHAR(13),"")
+10 SET SDECP=$TRANSLATE(SDECP,$CHAR(10),"")
+11 SET SDECP=$TRANSLATE(SDECP,$CHAR(9),"")
+12 if $GET(SDECC)=""
SET SDECC=10
+13 SET LASTSUB=$GET(LASTSUB)
+14 NEW GAF,PADDRES1,PADDRES2,PADDRES3,PCITY,PLIST,PSTATE,PCOUNTRY,PZIP4
+15 NEW SDTMP,SDECHRN,SDECZ,SDECRET,SDECDPT,SDECRET,DFN,SDECFILE
+16 NEW SDECIENS,SDECFIELDS,SDECFLAGS,SDECVALUE,SDECNUMBER,SDECINDEXES,SDECSCREEN
+17 NEW SDECTARG,SDECMSG,SDECRSLT,SDECCNT,SDDEMO,%DT,X,Y,SDECIDEN,SDECX,SDSENS
+18 NEW PRACE,PRACEN,PETH,PETHN,SDPCP,SDMHP
+19 KILL ^TMP("SDEC",$JOB)
+20 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+21 SET ^TMP("SDEC",$JOB,0)="T00030ERROR_CODE^T00030ERROR_TEXT"_$CHAR(30)
+22 IF '+$GET(DUZ)
SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^Invalid User."_$CHAR(30)_$CHAR(31)
QUIT
+23 IF '$DATA(DUZ(2))
SET SDECI=SDECI+1
SET @SDECY@(SDECI)="0^Invalid Institution."_$CHAR(30)_$CHAR(31)
QUIT
+24 ;8
SET SDTMP="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN^T00030GENDER^I00010INSTIEN^T00030INSTNAME"
+25 ;10
SET SDTMP=SDTMP_"^I00010USERIEN^T00030USERNAME"
+26 ;15
SET SDTMP=SDTMP_"^T00030PRIGRP^T00030ELIGIEN^T00030ELIGNAME^T00030SVCCONN^T00030SVCCONNP"
+27 ;19
SET SDTMP=SDTMP_"^T00030TYPEIEN^T00030TYPENAME^T00030PADDRES1^T00030PADDRES2"
+28 ;24
SET SDTMP=SDTMP_"^T00030PADDRES3^T00030PCITY^T00030PSTATE^T00030PCOUNTRY^T00030PZIP4"
+29 ;30
SET SDTMP=SDTMP_"^T00030GAF^T00100SENSITIVE^T00030PRACE^T00030PRACEN^T00030PETH^T00030PETHN"
+30 ;31
SET SDTMP=SDTMP_"^T00030LASTSUB"
+31 ;38
SET SDTMP=SDTMP_"^T00030BADADD^T00030HPHONE^T00030OPHONE^T00030NOK^T00030KNAME^T00030KREL^T00030KPHONE"
+32 ;43
SET SDTMP=SDTMP_"^T00030KSTREET^T00030KSTREET2^T00030KSTREET3^T00030KCITY^T00030KSTATE^T00030KZIP"
+33 ;47
SET SDTMP=SDTMP_"^T00030NOK2^T00030K2NAME^T00030K2REL^T00030K2PHONE"
+34 ;53
SET SDTMP=SDTMP_"^T00030K2STREET^T00030K2STREET2^T00030K2STREET3^T00030K2CITY^T00030K2STATE^T00030K2ZIP"
+35 SET SDTMP=SDTMP_"^T00030PCOUNTY^T00030PMARITAL^T00030PRELIGION^T00030PTACTIVE"
+36 ;65
SET SDTMP=SDTMP_"^T00030PTADDRESS1^T00030PTADDRESS2^T00030PTADDRESS3^T00030PTCITY^T00030PTSTATE^T00030PTZIP^T00030PTZIP+4"
+37 ;70
SET SDTMP=SDTMP_"^T00030PTCOUNTRY^T00030PTCOUNTY^T00030PTPHONE^T00030PTSTART^T00030PTEND"
+38 ;77
SET SDTMP=SDTMP_"^T00030PCELL^T00030PPAGER^T00030PEMAIL^T00030PF_FFF^T00030PF_VCD^T00030PFNATIONAL^T00030PFLOCAL"
+39 ;80
SET SDTMP=SDTMP_"^T00030SUBGRP^T00030CAT8G^T01000SIMILAR^T00030PCP^T00030MHP"
+40 SET ^TMP("SDEC",$JOB,0)=SDTMP_$CHAR(30)
+41 ;
DFN ;Patient ID passed in
+1 IF $EXTRACT(SDECP)="#"
Begin DoDot:1
+2 SET DFN=$EXTRACT(SDECP,2,$LENGTH(SDECP))
+3 if DFN=""
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,31)=""
+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 SET SDECX=$SELECT($PIECE(LASTSUB,U,1)'="":$$GETSUB^SDECU($PIECE(LASTSUB,U,1)),1:$$GETSUB^SDECU(SDECP))
+58 FOR
SET SDECX=$ORDER(^DPT("B",SDECX))
if SDECX'[SDECP
QUIT
if SDECX=""
QUIT
Begin DoDot:2
+59 SET DFN=$SELECT($PIECE(LASTSUB,U,2)'="":$PIECE(LASTSUB,U,2),1:0)
+60 SET LASTSUB=""
+61 FOR
SET DFN=$ORDER(^DPT("B",SDECX,DFN))
if DFN=""
QUIT
Begin DoDot:3
+62 if $DATA(SDARR(DFN))
QUIT
+63 SET SDARR(DFN)=""
+64 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+65 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+66 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+67 DO GET1(DFN,SDECHRN,.SDECI,SDECY,SDECX_"|"_DFN)
+68 QUIT
End DoDot:3
if SDECI'<SDECC
QUIT
End DoDot:2
if SDECI'<SDECC
QUIT
+69 IF SDECI>0
IF (SDECX="")!(SDECX'[SDECP)
SET $PIECE(@SDECY@(SDECI),U,31)=""
+70 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
End DoDot:1
QUIT
+71 ;
+72 ;All Patients
+73 NEW FROM,SDSUB
+74 ;I SDECP'?1N.E D S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
+75 IF SDECP=""
Begin DoDot:1
+76 KILL PLIST
+77 SET FROM=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1),1:"")
+78 DO LISTALL^SDECPTPL(.PLIST,FROM,1,SDECC)
+79 SET SDECCNT=0
FOR
SET SDECCNT=$ORDER(PLIST(SDECCNT))
if 'SDECCNT
QUIT
Begin DoDot:2
+80 SET DFN=$PIECE(PLIST(SDECCNT),U)
+81 ;CHART
SET SDECHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+82 ;I SDECHRN="" Q ;NO CHART AT THIS DUZ2
+83 ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q ;HMW 20050721 Record Inactivated
+84 SET SDSUB=$PIECE(PLIST(SDECCNT),U,2)
+85 DO GET1(DFN,SDECHRN,.SDECI,SDECY,SDSUB)
+86 QUIT
End DoDot:2
+87 QUIT
End DoDot:1
SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
QUIT
+88 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=$CHAR(31)
+89 QUIT
+90 ;
GET1(DFN,SDECHRN,SDECI,SDECY,LSUB) ;
+1 NEW PETH,PETHN,PRACE,PRACEN
+2 NEW SDECZ,SDECDPT,SDDEMO
+3 if '+$GET(DFN)
QUIT
+4 if '$DATA(^DPT(DFN,0))
QUIT
+5 SET SDECI=$GET(SDECI)
+6 SET LSUB=$GET(LSUB)
+7 SET SDECZ=""
+8 SET SDECZ=$$GET1^DIQ(2,DFN_",",.01)
+9 if SDECZ=""
QUIT
+10 SET $PIECE(SDECZ,U,2)=SDECHRN
+11 SET SDECDPT=$GET(^DPT(DFN,0))
+12 ;SSN
SET $PIECE(SDECZ,U,3)=$$LAST4SSN^SDESINPUTVALUTL(DFN)
+13 SET Y=$PIECE(SDECDPT,U,3)
XECUTE ^DD("DD")
+14 ;DOB
SET $PIECE(SDECZ,U,4)=Y
+15 SET $PIECE(SDECZ,U,5)=DFN
+16 ; Add Gender
+17 SET $PIECE(SDECZ,U,6)=$PIECE(SDECDPT,U,2)
+18 ; Add Institution IEN and Name
+19 SET $PIECE(SDECZ,U,7)=DUZ(2)
+20 SET $PIECE(SDECZ,U,8)=$PIECE(^DIC(4,DUZ(2),0),U)
+21 ; Add User IEN and Name
+22 SET $PIECE(SDECZ,U,9)=DUZ
+23 SET $PIECE(SDECZ,U,10)=$PIECE(^VA(200,DUZ,0),U)
+24 ;use to get PATIENT ENROLLMENT data ;alb/sat 658 PDEMO moved to SDECU3
DO PDEMO^SDECU3(.SDDEMO,DFN)
+25 SET $PIECE(SDECZ,U,11)=SDDEMO("PRIGRP")
+26 SET $PIECE(SDECZ,U,12)=SDDEMO("ELIGIEN")
+27 SET $PIECE(SDECZ,U,13)=SDDEMO("ELIGNAME")
+28 SET $PIECE(SDECZ,U,14)=SDDEMO("SVCCONN")
+29 SET $PIECE(SDECZ,U,15)=SDDEMO("SVCCONNP")
+30 SET $PIECE(SDECZ,U,16)=SDDEMO("TYPEIEN")
+31 SET $PIECE(SDECZ,U,17)=SDDEMO("TYPENAME")
+32 ;18 - Patient Address line 1
SET $PIECE(SDECZ,U,18)=SDDEMO("PADDRES1")
+33 ;19 - Patient Address line 2
SET $PIECE(SDECZ,U,19)=SDDEMO("PADDRES2")
+34 ;20 - Patient Address line 3
SET $PIECE(SDECZ,U,20)=SDDEMO("PADDRES3")
+35 ;21 - Patient City
SET $PIECE(SDECZ,U,21)=SDDEMO("PCITY")
+36 ;22 - Patient state name
SET $PIECE(SDECZ,U,22)=SDDEMO("PSTATE")
+37 ;23 - Patient country ID
SET $PIECE(SDECZ,U,23)=SDDEMO("PCOUNTRY")
+38 ;24 - Patient Zip+4
SET $PIECE(SDECZ,U,24)=SDDEMO("PZIP+4")
+39 ;25
SET $PIECE(SDECZ,U,25)=$$GAF^SDECU2(DFN)
+40 ;26 - sensitivity
SET $PIECE(SDECZ,U,26)=$$PTSEC^SDECUTL(DFN)
+41 DO RACELST^SDECU2(DFN,.PRACE,.PRACEN)
+42 SET $PIECE(SDECZ,U,27)=PRACE
+43 SET $PIECE(SDECZ,U,28)=PRACEN
+44 ;get ethnicity
DO ETH^SDECU2(DFN,.PETH,.PETHN)
+45 if PETH'=""
SET $PIECE(SDECZ,U,29)=PETH
+46 if PETHN'=""
SET $PIECE(SDECZ,U,30)=PETHN
+47 ;SDECX_"|"_DFN
SET $PIECE(SDECZ,U,31)=LSUB
+48 SET $PIECE(SDECZ,U,32)=SDDEMO("BADADD")
+49 SET $PIECE(SDECZ,U,33)=SDDEMO("HPHONE")
+50 SET $PIECE(SDECZ,U,34)=SDDEMO("OPHONE")
+51 SET $PIECE(SDECZ,U,35)=SDDEMO("NOK")
+52 SET $PIECE(SDECZ,U,36)=SDDEMO("KNAME")
+53 SET $PIECE(SDECZ,U,37)=SDDEMO("KREL")
+54 SET $PIECE(SDECZ,U,38)=SDDEMO("KPHONE")
+55 SET $PIECE(SDECZ,U,39)=SDDEMO("KSTREET")
+56 SET $PIECE(SDECZ,U,40)=SDDEMO("KSTREET2")
+57 SET $PIECE(SDECZ,U,41)=SDDEMO("KSTREET3")
+58 SET $PIECE(SDECZ,U,42)=SDDEMO("KCITY")
+59 SET $PIECE(SDECZ,U,43)=SDDEMO("KSTATE")
+60 SET $PIECE(SDECZ,U,44)=SDDEMO("KZIP")
+61 SET $PIECE(SDECZ,U,45)=SDDEMO("NOK2")
+62 SET $PIECE(SDECZ,U,46)=SDDEMO("K2NAME")
+63 SET $PIECE(SDECZ,U,47)=SDDEMO("K2REL")
+64 SET $PIECE(SDECZ,U,48)=SDDEMO("K2PHONE")
+65 SET $PIECE(SDECZ,U,49)=SDDEMO("K2STREET")
+66 SET $PIECE(SDECZ,U,50)=SDDEMO("K2STREET2")
+67 SET $PIECE(SDECZ,U,51)=SDDEMO("K2STREET3")
+68 SET $PIECE(SDECZ,U,52)=SDDEMO("K2CITY")
+69 SET $PIECE(SDECZ,U,53)=SDDEMO("K2STATE")
+70 SET $PIECE(SDECZ,U,54)=SDDEMO("K2ZIP")
+71 SET $PIECE(SDECZ,U,55)=SDDEMO("PCOUNTY")
+72 SET $PIECE(SDECZ,U,56)=SDDEMO("PMARITAL")
+73 SET $PIECE(SDECZ,U,57)=SDDEMO("PRELIGION")
+74 SET $PIECE(SDECZ,U,58)=SDDEMO("PTACTIVE")
+75 SET $PIECE(SDECZ,U,59)=SDDEMO("PTADDRESS1")
+76 SET $PIECE(SDECZ,U,60)=SDDEMO("PTADDRESS2")
+77 SET $PIECE(SDECZ,U,61)=SDDEMO("PTADDRESS3")
+78 SET $PIECE(SDECZ,U,62)=SDDEMO("PTCITY")
+79 SET $PIECE(SDECZ,U,63)=SDDEMO("PTSTATE")
+80 SET $PIECE(SDECZ,U,64)=SDDEMO("PTZIP")
+81 SET $PIECE(SDECZ,U,65)=SDDEMO("PTZIP+4")
+82 SET $PIECE(SDECZ,U,66)=SDDEMO("PTCOUNTRY")
+83 SET $PIECE(SDECZ,U,67)=SDDEMO("PTCOUNTY")
+84 SET $PIECE(SDECZ,U,68)=SDDEMO("PTPHONE")
+85 SET $PIECE(SDECZ,U,69)=SDDEMO("PTSTART")
+86 SET $PIECE(SDECZ,U,70)=SDDEMO("PTEND")
+87 SET $PIECE(SDECZ,U,71)=SDDEMO("PCELL")
+88 SET $PIECE(SDECZ,U,72)=SDDEMO("PPAGER")
+89 SET $PIECE(SDECZ,U,73)=SDDEMO("PEMAIL")
+90 SET $PIECE(SDECZ,U,74)=SDDEMO("PF_FFF")
+91 SET $PIECE(SDECZ,U,75)=SDDEMO("PF_VCD")
+92 SET $PIECE(SDECZ,U,76)=SDDEMO("PFNATIONAL")
+93 SET $PIECE(SDECZ,U,77)=SDDEMO("PFLOCAL")
+94 SET $PIECE(SDECZ,U,78)=SDDEMO("SUBGRP")
+95 SET $PIECE(SDECZ,U,79)=(SDDEMO("PRIGRP")="GROUP 8")&(SDDEMO("SUBGRP")="g")
+96 SET $PIECE(SDECZ,U,80)=SDDEMO("SIMILAR")
+97 ;ajf
+98 ;Return Primary Care Provider
SET SDPCP=$$OUTPTPR^SDUTL3(DFN)
+99 SET $PIECE(SDECZ,U,81)=$PIECE(SDPCP,U,2)
+100 ;Return Mental Health Provider
SET SDMHP=$$START^SCMCMHTC(DFN)
+101 SET $PIECE(SDECZ,U,82)=$PIECE(SDMHP,U,2)
+102 ;
+103 SET SDECI=SDECI+1
SET @SDECY@(SDECI)=SDECZ_$CHAR(30)
+104 QUIT
+105 ;
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^T00030HRN^T00030SSN^D00030DOB^T00030IEN^T00030GENDER"
+2 SET SDECRET=SDECRET_"^I00010INSTIEN^T00030INSTNAME^I00010USERIEN^T00030USERNAME"
+3 SET SDECRET=SDECRET_"^T00030PRIGRP^T00030ELIGIEN^T00030ELIGNAME^T00030SVCCONN^T00030SVCCONNP"_$CHAR(30)_$CHAR(31)
+4 QUIT
