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

XUPSQRY.m

Go to the documentation of this file.
  1. XUPSQRY ;EDS/GRR - Query New Person file ;03/17/15 08:30
  1. ;;8.0;KERNEL;**325,655**; Jul 10, 1995;Build 16
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;;Input Parameter:
  1. ;; XUPSECID - SecID of the user, internal format with "^"
  1. ;; replaced with "%" (Required for lookup by SecID)
  1. ;; XUPSLNAM - Part or all of the last name to use for basis
  1. ;; of query (Required for lookup by name)
  1. ;; XUPSFNAM - Part or all of the first name to use for basis
  1. ;; of query filter (optional, can be null)
  1. ;; XUPSSSN - Social Security Number (null or full 9 digits) to
  1. ;; use as additional filter for query
  1. ;; XUPSPROV - If value set to "P", screen for only providers
  1. ;; (only persons with active person class)
  1. ;; XUPSSTN - Filter persons based on station number entered
  1. ;; (optional, can be null)
  1. ;; XUPSMNM - Maximum Number of entries to return
  1. ;; (Number between 1 and 50. Null defaults to 50)
  1. ;; XUPSDATE - Date to be used to determine whether person has
  1. ;; active person class. If null, current date is used.
  1. ;;
  1. ;;Output:
  1. ;; RESULT - Name of global array were output data is stored
  1. ;; ^TMP($J,"XUPSQRY",1) - 1 if found, 0 if not found
  1. ;; ^TMP($J,"XUPSQRY",n,0) - SecID^IEN^Last Name~First Name~
  1. ;; Middle Name^SSN^DOB^SEX^
  1. ;; ^TMP($J,"XUPSQRY",n,1) - Provider Type^
  1. ;; ^TMP($J,"XUPSQRY",n,2) - Provider Classification^
  1. ;; ^TMP($J,"XUPSQRY",n,3) - Provider Area of Specialization^
  1. ;; ^TMP($J,"XUPSQRY",n,4) - VA CODE^X12 CODE^Specialty Code^
  1. ;; end-of-record character "|"
  1. ;;
  1. EN1(RESULT,XUPSECID,XUPSLNAM,XUPSFNAM,XUPSSSN,XUPSPROV,XUPSSTN,XUPSMNM,XUPSDATE) ;
  1. N %,XUPSNDAT
  1. K ^TMP($J,"XUPSQRY")
  1. K RESULT
  1. S RESULT=$NA(^TMP($J,"XUPSQRY")) ;set variable to name of global array where output data will be stored
  1. S ^TMP($J,"XUPSQRY",1)=0 ;initialize to not found
  1. I $G(XUPSLNAM)="",($G(XUPSECID)="") Q ;last name parameter empty, and is required
  1. S XUPSFNAM=$G(XUPSFNAM) ;Set to null if missing
  1. S XUPSSSN=$G(XUPSSSN) ;Set to null if missing
  1. S XUPSPROV=$G(XUPSPROV) ;Set to null if missing
  1. S XUPSSTN=$G(XUPSSTN) ;Set to null if missing
  1. I $G(XUPSDATE)="" S XUPSDATE="" ;set to null if missing
  1. D NOW^%DTC S XUPSNDAT=%\1 ;set date to today and truncate time
  1. S XUPSDATE=$S(XUPSDATE="":XUPSNDAT,1:$$FMDATE^HLFNC(XUPSDATE)) ;change date from hl7 format to fileman format
  1. N XUPSCNT,XUPSNAME,XUPSIEN,XUPSDOB,XUPSSEX,XUPSPC,XUPSX12,XUPSPASS ;initialize new set of variables
  1. S:$G(XUPSMNM)="" XUPSMNM=50 ;set to default
  1. S XUPSCNT=0 ;Initialize variable
  1. ;
  1. ;Lookup by SecID
  1. I $G(XUPSECID)'="" D Q
  1. .S XUPSIEN=$$SECMATCH^XUESSO2(XUPSECID)
  1. .I +XUPSIEN>0 D
  1. ..D FILTER
  1. ..Q:XUPSPASS=0
  1. ..S XUPSCNT=XUPSCNT+1
  1. ..D FOUND(XUPSCNT,XUPSIEN,XUPSDATE) ;set array with person data
  1. ;
  1. S XUPSIEN=0,XUPSNAME=XUPSLNAM ;initialize variables
  1. ;;
  1. ;;Loop through the Name index, quit if name is null or beginning portion of name not equal parameter passed or maximum number of entries reached
  1. ;;
  1. F S XUPSNAME=$O(^VA(200,"B",XUPSNAME)) Q:XUPSNAME=""!($E(XUPSNAME,1,$L(XUPSLNAM))'[XUPSLNAM)!(XUPSCNT+1>XUPSMNM) S XUPSIEN=0 F S XUPSIEN=$O(^VA(200,"B",XUPSNAME,XUPSIEN)) Q:XUPSIEN="" D
  1. .D FILTER
  1. .Q:XUPSPASS=0
  1. .S XUPSCNT=XUPSCNT+1
  1. .D FOUND(XUPSCNT,XUPSIEN,XUPSDATE) ;set array with person data
  1. Q
  1. FILTER ;
  1. ; ZEXCEPT: XUPSDATE,XUPSFNAM,XUPSIEN,XUPSPASS,XUPSPROV,XUPSSSN,XUPSSTN ;global variables within this routine
  1. S XUPSPASS=1 ;initialize found flag to found
  1. I '$$ACTIVE^XUSER(XUPSIEN),($O(^VA(200,XUPSIEN,8910,0))>0) S XUPSPASS=0 Q ;skip visitors
  1. I XUPSFNAM]"" S XUPSPASS=$$NMATCH^XUPSUTL1(XUPSIEN,XUPSFNAM) ;check if matches name filter
  1. Q:'XUPSPASS ;failed to match
  1. I XUPSSSN]"",($P($G(^VA(200,XUPSIEN,1)),"^",9)'=XUPSSSN) S XUPSPASS=0 Q ;check ssn filter
  1. I XUPSSTN]"" S XUPSPASS=$$STNMAT^XUPSUTL1(XUPSIEN,XUPSSTN) ;check station number
  1. Q:'XUPSPASS ;failed match
  1. I XUPSPROV]"",($$GET^XUA4A72(XUPSIEN,XUPSDATE)<0) S XUPSPASS=0 Q ;check if active person class
  1. Q
  1. FOUND(XUPSCNT,XUPSIEN,XUPSDATE) ;format output array
  1. ; ZEXCEPT: XUPSPC,XUPSX12 ;global variables within this routine
  1. N XUPSNAME,XUPSSSN,XUPSECID,XUPSSEX,XUPSDOB,I,Y
  1. S Y=$P(^VA(200,XUPSIEN,0),"^",1) ;get full name
  1. S XUPSNAME=$$HLNAME^HLFNC(Y,"~|\/") ;format name into last name~first name~middle name
  1. I $L(XUPSNAME,"~")<3 S $P(XUPSNAME,"~",3)="" ;make sure formatted name has all 3 pieces
  1. S Y=$G(^VA(200,XUPSIEN,1)) ;get ssn,dob,sex
  1. S XUPSSSN=$P(Y,"^",9) ;ssn
  1. S XUPSECID=$P(Y,"^",1) ;secid
  1. S XUPSSEX=$P(Y,"^",2) ;sex
  1. S XUPSDOB=$P(Y,"^",3) ;dob fileman format
  1. I XUPSDOB]"" S XUPSDOB=$$HLDATE^HLFNC(XUPSDOB,"DT") ;format dob to correct hl7 format yyyymmdd
  1. S ^TMP($J,"XUPSQRY",1)=1 ;set to indicate match found
  1. S ^TMP($J,"XUPSQRY",XUPSCNT,0)=XUPSECID_"^"_XUPSIEN_"^"_XUPSNAME_"^"_XUPSSSN_"^"_XUPSDOB_"^"_XUPSSEX_"^"
  1. S XUPSPC=$$GET^XUA4A72(XUPSIEN,XUPSDATE) ;get active person class data
  1. S:XUPSPC<0 XUPSPC="" ;no active person class
  1. F I=1:1:3 S ^TMP($J,"XUPSQRY",XUPSCNT,I)=$P(XUPSPC,"^",(1+I))_"^" ;put provider type, provider class, and are of specialization in output array
  1. S XUPSX12=$S(XUPSPC="":"",1:$P(^USC(8932.1,+XUPSPC,0),"^",7)) ;get x12 code which is not returned by api
  1. S ^TMP($J,"XUPSQRY",XUPSCNT,4)=$P(XUPSPC,"^",7)_"^"_XUPSX12_"^"_$P(XUPSPC,"^",8)_"^|" ;put va code, x12 code, specialty code, and end-of-record character in output array
  1. Q