Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDEC28L

SDEC28L.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VHA Directive 6402, this routine should not be modified
  1.  ;
  1.  ; Reference to ^AUPNPAT(DFN in ICR #7048
  1.  ; Reference to ^DPT in ICR #10035
  1.  Q
  1.  ;This Routine is a "LITE" version of the rtn SDEC28-Patient info lookup for RPC SDEC PTLOOKRS.
  1.  ; It generates only "PATIENT NAME, SSN, DOB, DFN, SEX, ELIGIBILITY" fields
  1.  ; and finds up to "SDECC" number of patients that match the "SDECP" defined lookup criteria.
  1.  ;
  1.  ;The Patient lookup supports input in the form of:
  1.  ;    a)#DFN,   b)DOB,   c)SSN,   d)First letter of LastName followed by L4SSN,
  1.  ;    e)PartialName  or  f)NULL for ALL
  1.  ;Vars In:
  1.  ;  SDECP   - (optional) Free-Text - Partial name to look up
  1.  ;  SDECC   - (optional) Max number of patients to return; defaults to 10
  1.  ;  LASTSUB - (optional) last subscripts from previous call
  1.  ;Var Out:
  1.  ;  SDECY (^TMP("SDEC",$J))
  1.  ;
  1.  ;PTLOOKRSLITE(SDECY,SDECP,SDECC,LASTSUB)  ;Patient Lookup
  1. GETPATDEMOG(SDECY,SDECP,SDECC,LASTSUB)  ;Get Patient Demographics ("PATIENT NAME, SSN, DOB, DFN, SEX, ELIGIBILITY")
  1.  S SDECI=0
  1.  S SDECP=$TR(SDECP,$C(13),"")
  1.  S SDECP=$TR(SDECP,$C(10),"")
  1.  S SDECP=$TR(SDECP,$C(9),"")
  1.  S:$G(SDECC)="" SDECC=10
  1.  S LASTSUB=$G(LASTSUB)
  1.  N PLIST,SDTMP,SDECHRN,SDECZ,SDECRET,DFN
  1.  N %DT,X,Y,SDECX
  1.  K ^TMP("SDEC",$J)
  1.  S SDECY="^TMP(""SDEC"","_$J_")"
  1.  S ^TMP("SDEC",$J,0)="T00030ERROR_CODE^T00030ERROR_TEXT"_$C(30)
  1.  I '+$G(DUZ) S SDECI=SDECI+1 S @SDECY@(SDECI)="0^Invalid User."_$C(30)_$C(31) Q
  1.  I '$D(DUZ(2)) S SDECI=SDECI+1 S @SDECY@(SDECI)="0^Invalid Institution."_$C(30)_$C(31) Q
  1.  S SDTMP="T00030NAME^T00030SSN^D00030DOB^T00030GENDER^T00030TYPENAME^T00030LASTSUB^T00030IEN^T00030SENSITIVE" ;  7
  1.  S ^TMP("SDEC",$J,0)=SDTMP_$C(30)
  1.  ;
  1. DFN ;Patient ID passed in
  1.  I $E(SDECP)="#" D  S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
  1.  . S DFN=$E(SDECP,2,$L(SDECP))
  1.  . Q:'$D(^DPT(DFN,0))
  1.  . S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
  1.  . ;I SDECHRN="" Q  ;NO CHART AT THIS DUZ2
  1.  . ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
  1.  . D GET1(DFN,SDECHRN,.SDECI,SDECY)
  1.  . Q
  1.  ;
  1. DOB ;DOB Lookup
  1.  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
  1.  . S X=SDECP S %DT="P" D ^%DT S SDECP=Y Q:'+Y
  1.  . Q:'$D(^DPT("ADOB",SDECP))
  1.  . S DFN=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1),1:0)
  1.  . S LASTSUB=""
  1.  . F  S DFN=$O(^DPT("ADOB",SDECP,DFN)) Q:'+DFN  D  Q:SDECI'<SDECC
  1.  . . Q:'$D(^DPT(DFN,0))
  1.  . . S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
  1.  . . ;I SDECHRN="" Q  ;NO CHART AT THIS DUZ2
  1.  . . ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
  1.  . . D GET1(DFN,SDECHRN,.SDECI,SDECY,DFN)
  1.  . . Q
  1.  . I SDECI>0,'+DFN S $P(@SDECY@(SDECI),U,6)=""
  1.  . Q
  1.  ;
  1.  ;SSN Lookup
  1.  ;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
  1.  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
  1.  .;SSN Lookup (BS - last 4)
  1.  .I SDECP?4N D
  1.  ..S SDECP1=SDECP
  1.  ..S DFN=0 F  S DFN=$O(^DPT("BS",SDECP1,DFN)) Q:'+DFN  D
  1.  ...Q:'$D(^DPT(DFN,0))
  1.  ...S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
  1.  ...;I SDECHRN="" Q  ;NO CHART AT THIS DUZ2
  1.  ...;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
  1.  ...D GET1(DFN,SDECHRN,.SDECI,SDECY)
  1.  .E  D SSN(SDECP,.SDECI,SDECY)  ;(partial/full ssn)
  1.  ;
  1.  ;SSN Lookup (BS5)
  1.  ;I SDECP?1A1.4N D  S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
  1.  I SDECP?1A4N D  S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q  ;VSE-168 LEG 5/12/21 eliminates ?1A1.3N
  1.  .S SDECP1=$S(SDECP?1A4N:$E(SDECP,1,4)_$C($A($E(SDECP,5))-1),1:SDECP)
  1.  .F  S SDECP1=$O(^DPT("BS5",SDECP1)) Q:SDECP1=""  Q:SDECP1'[SDECP  Q:(SDECP?1A4N)&(SDECP1'=SDECP)  D
  1.  ..S DFN=0 F  S DFN=$O(^DPT("BS5",SDECP1,DFN)) Q:'+DFN  D
  1.  ...Q:'$D(^DPT(DFN,0))
  1.  ...S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
  1.  ...;I SDECHRN="" Q  ;NO CHART AT THIS DUZ2
  1.  ...;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
  1.  ...D GET1(DFN,SDECHRN,.SDECI,SDECY)
  1.  ;
  1.  ;Chart# Lookup  (not currently used)
  1.  I 0,+DUZ(2),SDECP]"",$D(^AUPNPAT("D",SDECP)) D  S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
  1.  . S DFN=0 F  S DFN=$O(^AUPNPAT("D",SDECP,DFN)) Q:'+DFN  I $D(^AUPNPAT("D",SDECP,DFN,DUZ(2))) D  Q
  1.  . . Q:'$D(^DPT(DFN,0))
  1.  . . S SDECHRN=SDECP ;CHART
  1.  . . ;I $D(^AUPNPAT(DFN,41,DUZ(2),0)),$P(^(0),U,3) S SDECHRN=SDECHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
  1.  . . D GET1(DFN,SDECHRN,.SDECI,SDECY)
  1.  . . Q
  1.  . Q
  1.  ;
  1.  ;Partial name
  1.  N SDARR
  1.  ;lab testing I SDECP?2.A.E D  Q
  1.  I SDECP?1.A.E D  Q
  1.  .;F SDECX=1:1:$P(SDECRSLT("DILIST",0),U) D
  1.  .; restrict lookup to 30 characters to prevent <SUBSCRIPT> error for extremely long values - INC23935053
  1.  .S SDECP=$E(SDECP,1,30)
  1.  .S SDECX=$S($P(LASTSUB,U,1)'="":$$GETSUB^SDECU($P(LASTSUB,U,1)),1:$$GETSUB^SDECU(SDECP))
  1.  .F  S SDECX=$O(^DPT("B",SDECX)) Q:SDECX'[SDECP  Q:SDECX=""  D  Q:SDECI'<SDECC
  1.  ..S DFN=$S($P(LASTSUB,U,2)'="":$P(LASTSUB,U,2),1:0)
  1.  ..S LASTSUB=""
  1.  ..F  S DFN=$O(^DPT("B",SDECX,DFN)) Q:DFN=""  D  Q:SDECI'<SDECC
  1.  ...Q:$D(SDARR(DFN))
  1.  ...S SDARR(DFN)=""
  1.  ...S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
  1.  ...;I SDECHRN="" Q  ;NO CHART AT THIS DUZ2
  1.  ...;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
  1.  ...D GET1(DFN,SDECHRN,.SDECI,SDECY,SDECX_"|"_DFN)
  1.  ...Q
  1.  .I SDECI>0,(SDECX="")!(SDECX'[SDECP) S $P(@SDECY@(SDECI),U,6)=""
  1.  .S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
  1.  ;
  1.  ;All Patients
  1.  N FROM,SDSUB,SDECCNT
  1.  ;I SDECP'?1N.E D  S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
  1.  I SDECP="" D  S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31) Q
  1.  . K PLIST
  1.  . S FROM=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1),1:"")
  1.  . D LISTALL^SDECPTPL(.PLIST,FROM,1,SDECC)
  1.  . S SDECCNT=0 F  S SDECCNT=$O(PLIST(SDECCNT)) Q:'SDECCNT  D
  1.  . . S DFN=$P(PLIST(SDECCNT),U)
  1.  . . S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
  1.  . . ;I SDECHRN="" Q  ;NO CHART AT THIS DUZ2
  1.  . . ;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
  1.  . . S SDSUB=$P(PLIST(SDECCNT),U,2)
  1.  . . D GET1(DFN,SDECHRN,.SDECI,SDECY,SDSUB)
  1.  . . Q
  1.  . Q
  1.  S SDECI=SDECI+1 S @SDECY@(SDECI)=$C(31)
  1.  Q
  1.  ;
  1. GET1(DFN,SDECHRN,SDECI,SDECY,LSUB) ;
  1.  N SDECZ,SDECDPT,SDDEMO
  1.  Q:'+$G(DFN)
  1.  Q:'$D(^DPT(DFN,0))
  1.  S SDECI=$G(SDECI)
  1.  S LSUB=$G(LSUB)
  1.  S SDECZ=""
  1.  S SDECZ=$$GET1^DIQ(2,DFN_",",.01) ; NAME
  1.  Q:SDECZ=""
  1.  S SDECDPT=$G(^DPT(DFN,0))
  1.  S $P(SDECZ,U,2)=$$LAST4SSN^SDESINPUTVALUTL(DFN)
  1.  S Y=$P(SDECDPT,U,3) X ^DD("DD")
  1.  S $P(SDECZ,U,3)=Y ;DOB
  1.  S $P(SDECZ,U,4)=$P(SDECDPT,U,2) ;Gender
  1.  D PDEMO^SDECU3(.SDDEMO,DFN)     ;use to get PATIENT ENROLLMENT data  ;alb/sat 658 PDEMO moved to SDECU3
  1.  S $P(SDECZ,U,5)=SDDEMO("TYPENAME")
  1.  S $P(SDECZ,U,6)=$P(SDECZ,U)_"|"_DFN ; NAME|DFN
  1.  S $P(SDECZ,U,7)=DFN ;
  1.  S $P(SDECZ,U,8)=$$PTSEC^SDECUTL(DFN) ;8   - sensitivity
  1.  S SDECI=SDECI+1 S @SDECY@(SDECI)=SDECZ_$C(30)
  1.  Q
  1.  ;
  1. SSN(SDECP,SDECI,SDECY)  ;
  1.  S SDECP=$TR(SDECP,"-","") ;LEG 05/10/2021-needed to fix 3N-2N-4N format
  1.  I $D(^DPT("SSN",$E(SDECP,1,9)_"P")) D
  1.  .N SDECP1
  1.  .S SDECP1=$E(SDECP,1,9)_"O"
  1.  .S SDECP1=$O(^DPT("SSN",SDECP1)) Q:SDECP1=""  Q:SDECP1'[$E(SDECP,1,9)  D SSN1
  1.  E  D
  1.  .N SDLEN S SDLEN=$L(SDECP)
  1.  .I SDLEN=9 S SDECP1=SDECP D SSN1
  1.  .E  D
  1.  ..S SDECP1=SDECP_$$FILL^SDECU(9-SDLEN,0)
  1.  ..F  S SDECP1=$O(^DPT("SSN",SDECP1)) Q:SDECP1=""  Q:$E(SDECP1,1,SDLEN)'=SDECP  D SSN1
  1.  Q
  1. SSN1 ;
  1.  S DFN=0 F  S DFN=$O(^DPT("SSN",SDECP1,DFN)) Q:'+DFN  D
  1.  .Q:'$D(^DPT(DFN,0))
  1.  .S SDECHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) ;CHART
  1.  .;I SDECHRN="" Q  ;NO CHART AT THIS DUZ2
  1.  .;I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3) S SDECHRN=SDECHRN_"(*)" Q  ;HMW 20050721 Record Inactivated
  1.  .D GET1(DFN,SDECHRN,.SDECI,SDECY)
  1.  .Q
  1.  Q
  1.  ;
  1. ERROR ;
  1.  D ERR("Error")
  1.  Q
  1.  ;
  1. ERR(ERRNO) ;Error processing
  1.  S SDECRET="T00030NAME^T00030SSN^D00030DOB^T00030IEN^T00030GENDER^T00030TYPENAME^T00030LASTSUB"_$C(30)_$C(31)
  1.  Q