- XUPSQRY ;EDS/GRR - Query New Person file ;03/17/15 08:30
- ;;8.0;KERNEL;**325,655**; Jul 10, 1995;Build 16
- ;Per VA Directive 6402, this routine should not be modified.
- ;;Input Parameter:
- ;; XUPSECID - SecID of the user, internal format with "^"
- ;; replaced with "%" (Required for lookup by SecID)
- ;; XUPSLNAM - Part or all of the last name to use for basis
- ;; of query (Required for lookup by name)
- ;; XUPSFNAM - Part or all of the first name to use for basis
- ;; of query filter (optional, can be null)
- ;; XUPSSSN - Social Security Number (null or full 9 digits) to
- ;; use as additional filter for query
- ;; XUPSPROV - If value set to "P", screen for only providers
- ;; (only persons with active person class)
- ;; XUPSSTN - Filter persons based on station number entered
- ;; (optional, can be null)
- ;; XUPSMNM - Maximum Number of entries to return
- ;; (Number between 1 and 50. Null defaults to 50)
- ;; XUPSDATE - Date to be used to determine whether person has
- ;; active person class. If null, current date is used.
- ;;
- ;;Output:
- ;; RESULT - Name of global array were output data is stored
- ;; ^TMP($J,"XUPSQRY",1) - 1 if found, 0 if not found
- ;; ^TMP($J,"XUPSQRY",n,0) - SecID^IEN^Last Name~First Name~
- ;; Middle Name^SSN^DOB^SEX^
- ;; ^TMP($J,"XUPSQRY",n,1) - Provider Type^
- ;; ^TMP($J,"XUPSQRY",n,2) - Provider Classification^
- ;; ^TMP($J,"XUPSQRY",n,3) - Provider Area of Specialization^
- ;; ^TMP($J,"XUPSQRY",n,4) - VA CODE^X12 CODE^Specialty Code^
- ;; end-of-record character "|"
- ;;
- EN1(RESULT,XUPSECID,XUPSLNAM,XUPSFNAM,XUPSSSN,XUPSPROV,XUPSSTN,XUPSMNM,XUPSDATE) ;
- N %,XUPSNDAT
- K ^TMP($J,"XUPSQRY")
- K RESULT
- S RESULT=$NA(^TMP($J,"XUPSQRY")) ;set variable to name of global array where output data will be stored
- S ^TMP($J,"XUPSQRY",1)=0 ;initialize to not found
- I $G(XUPSLNAM)="",($G(XUPSECID)="") Q ;last name parameter empty, and is required
- S XUPSFNAM=$G(XUPSFNAM) ;Set to null if missing
- S XUPSSSN=$G(XUPSSSN) ;Set to null if missing
- S XUPSPROV=$G(XUPSPROV) ;Set to null if missing
- S XUPSSTN=$G(XUPSSTN) ;Set to null if missing
- I $G(XUPSDATE)="" S XUPSDATE="" ;set to null if missing
- D NOW^%DTC S XUPSNDAT=%\1 ;set date to today and truncate time
- S XUPSDATE=$S(XUPSDATE="":XUPSNDAT,1:$$FMDATE^HLFNC(XUPSDATE)) ;change date from hl7 format to fileman format
- N XUPSCNT,XUPSNAME,XUPSIEN,XUPSDOB,XUPSSEX,XUPSPC,XUPSX12,XUPSPASS ;initialize new set of variables
- S:$G(XUPSMNM)="" XUPSMNM=50 ;set to default
- S XUPSCNT=0 ;Initialize variable
- ;
- ;Lookup by SecID
- I $G(XUPSECID)'="" D Q
- .S XUPSIEN=$$SECMATCH^XUESSO2(XUPSECID)
- .I +XUPSIEN>0 D
- ..D FILTER
- ..Q:XUPSPASS=0
- ..S XUPSCNT=XUPSCNT+1
- ..D FOUND(XUPSCNT,XUPSIEN,XUPSDATE) ;set array with person data
- ;
- S XUPSIEN=0,XUPSNAME=XUPSLNAM ;initialize variables
- ;;
- ;;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
- ;;
- 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
- .D FILTER
- .Q:XUPSPASS=0
- .S XUPSCNT=XUPSCNT+1
- .D FOUND(XUPSCNT,XUPSIEN,XUPSDATE) ;set array with person data
- Q
- FILTER ;
- ; ZEXCEPT: XUPSDATE,XUPSFNAM,XUPSIEN,XUPSPASS,XUPSPROV,XUPSSSN,XUPSSTN ;global variables within this routine
- S XUPSPASS=1 ;initialize found flag to found
- I '$$ACTIVE^XUSER(XUPSIEN),($O(^VA(200,XUPSIEN,8910,0))>0) S XUPSPASS=0 Q ;skip visitors
- I XUPSFNAM]"" S XUPSPASS=$$NMATCH^XUPSUTL1(XUPSIEN,XUPSFNAM) ;check if matches name filter
- Q:'XUPSPASS ;failed to match
- I XUPSSSN]"",($P($G(^VA(200,XUPSIEN,1)),"^",9)'=XUPSSSN) S XUPSPASS=0 Q ;check ssn filter
- I XUPSSTN]"" S XUPSPASS=$$STNMAT^XUPSUTL1(XUPSIEN,XUPSSTN) ;check station number
- Q:'XUPSPASS ;failed match
- I XUPSPROV]"",($$GET^XUA4A72(XUPSIEN,XUPSDATE)<0) S XUPSPASS=0 Q ;check if active person class
- Q
- FOUND(XUPSCNT,XUPSIEN,XUPSDATE) ;format output array
- ; ZEXCEPT: XUPSPC,XUPSX12 ;global variables within this routine
- N XUPSNAME,XUPSSSN,XUPSECID,XUPSSEX,XUPSDOB,I,Y
- S Y=$P(^VA(200,XUPSIEN,0),"^",1) ;get full name
- S XUPSNAME=$$HLNAME^HLFNC(Y,"~|\/") ;format name into last name~first name~middle name
- I $L(XUPSNAME,"~")<3 S $P(XUPSNAME,"~",3)="" ;make sure formatted name has all 3 pieces
- S Y=$G(^VA(200,XUPSIEN,1)) ;get ssn,dob,sex
- S XUPSSSN=$P(Y,"^",9) ;ssn
- S XUPSECID=$P(Y,"^",1) ;secid
- S XUPSSEX=$P(Y,"^",2) ;sex
- S XUPSDOB=$P(Y,"^",3) ;dob fileman format
- I XUPSDOB]"" S XUPSDOB=$$HLDATE^HLFNC(XUPSDOB,"DT") ;format dob to correct hl7 format yyyymmdd
- S ^TMP($J,"XUPSQRY",1)=1 ;set to indicate match found
- S ^TMP($J,"XUPSQRY",XUPSCNT,0)=XUPSECID_"^"_XUPSIEN_"^"_XUPSNAME_"^"_XUPSSSN_"^"_XUPSDOB_"^"_XUPSSEX_"^"
- S XUPSPC=$$GET^XUA4A72(XUPSIEN,XUPSDATE) ;get active person class data
- S:XUPSPC<0 XUPSPC="" ;no active person class
- 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
- S XUPSX12=$S(XUPSPC="":"",1:$P(^USC(8932.1,+XUPSPC,0),"^",7)) ;get x12 code which is not returned by api
- 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
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUPSQRY 5636 printed Feb 18, 2025@23:38:12 Page 2
- XUPSQRY ;EDS/GRR - Query New Person file ;03/17/15 08:30
- +1 ;;8.0;KERNEL;**325,655**; Jul 10, 1995;Build 16
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Input Parameter:
- +4 ;; XUPSECID - SecID of the user, internal format with "^"
- +5 ;; replaced with "%" (Required for lookup by SecID)
- +6 ;; XUPSLNAM - Part or all of the last name to use for basis
- +7 ;; of query (Required for lookup by name)
- +8 ;; XUPSFNAM - Part or all of the first name to use for basis
- +9 ;; of query filter (optional, can be null)
- +10 ;; XUPSSSN - Social Security Number (null or full 9 digits) to
- +11 ;; use as additional filter for query
- +12 ;; XUPSPROV - If value set to "P", screen for only providers
- +13 ;; (only persons with active person class)
- +14 ;; XUPSSTN - Filter persons based on station number entered
- +15 ;; (optional, can be null)
- +16 ;; XUPSMNM - Maximum Number of entries to return
- +17 ;; (Number between 1 and 50. Null defaults to 50)
- +18 ;; XUPSDATE - Date to be used to determine whether person has
- +19 ;; active person class. If null, current date is used.
- +20 ;;
- +21 ;;Output:
- +22 ;; RESULT - Name of global array were output data is stored
- +23 ;; ^TMP($J,"XUPSQRY",1) - 1 if found, 0 if not found
- +24 ;; ^TMP($J,"XUPSQRY",n,0) - SecID^IEN^Last Name~First Name~
- +25 ;; Middle Name^SSN^DOB^SEX^
- +26 ;; ^TMP($J,"XUPSQRY",n,1) - Provider Type^
- +27 ;; ^TMP($J,"XUPSQRY",n,2) - Provider Classification^
- +28 ;; ^TMP($J,"XUPSQRY",n,3) - Provider Area of Specialization^
- +29 ;; ^TMP($J,"XUPSQRY",n,4) - VA CODE^X12 CODE^Specialty Code^
- +30 ;; end-of-record character "|"
- +31 ;;
- EN1(RESULT,XUPSECID,XUPSLNAM,XUPSFNAM,XUPSSSN,XUPSPROV,XUPSSTN,XUPSMNM,XUPSDATE) ;
- +1 NEW %,XUPSNDAT
- +2 KILL ^TMP($JOB,"XUPSQRY")
- +3 KILL RESULT
- +4 ;set variable to name of global array where output data will be stored
- SET RESULT=$NAME(^TMP($JOB,"XUPSQRY"))
- +5 ;initialize to not found
- SET ^TMP($JOB,"XUPSQRY",1)=0
- +6 ;last name parameter empty, and is required
- IF $GET(XUPSLNAM)=""
- IF ($GET(XUPSECID)="")
- QUIT
- +7 ;Set to null if missing
- SET XUPSFNAM=$GET(XUPSFNAM)
- +8 ;Set to null if missing
- SET XUPSSSN=$GET(XUPSSSN)
- +9 ;Set to null if missing
- SET XUPSPROV=$GET(XUPSPROV)
- +10 ;Set to null if missing
- SET XUPSSTN=$GET(XUPSSTN)
- +11 ;set to null if missing
- IF $GET(XUPSDATE)=""
- SET XUPSDATE=""
- +12 ;set date to today and truncate time
- DO NOW^%DTC
- SET XUPSNDAT=%\1
- +13 ;change date from hl7 format to fileman format
- SET XUPSDATE=$SELECT(XUPSDATE="":XUPSNDAT,1:$$FMDATE^HLFNC(XUPSDATE))
- +14 ;initialize new set of variables
- NEW XUPSCNT,XUPSNAME,XUPSIEN,XUPSDOB,XUPSSEX,XUPSPC,XUPSX12,XUPSPASS
- +15 ;set to default
- if $GET(XUPSMNM)=""
- SET XUPSMNM=50
- +16 ;Initialize variable
- SET XUPSCNT=0
- +17 ;
- +18 ;Lookup by SecID
- +19 IF $GET(XUPSECID)'=""
- Begin DoDot:1
- +20 SET XUPSIEN=$$SECMATCH^XUESSO2(XUPSECID)
- +21 IF +XUPSIEN>0
- Begin DoDot:2
- +22 DO FILTER
- +23 if XUPSPASS=0
- QUIT
- +24 SET XUPSCNT=XUPSCNT+1
- +25 ;set array with person data
- DO FOUND(XUPSCNT,XUPSIEN,XUPSDATE)
- End DoDot:2
- End DoDot:1
- QUIT
- +26 ;
- +27 ;initialize variables
- SET XUPSIEN=0
- SET XUPSNAME=XUPSLNAM
- +28 ;;
- +29 ;;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
- +30 ;;
- +31 FOR
- SET XUPSNAME=$ORDER(^VA(200,"B",XUPSNAME))
- if XUPSNAME=""!($EXTRACT(XUPSNAME,1,$LENGTH(XUPSLNAM))'[XUPSLNAM)!(XUPSCNT+1>XUPSMNM)
- QUIT
- SET XUPSIEN=0
- FOR
- SET XUPSIEN=$ORDER(^VA(200,"B",XUPSNAME,XUPSIEN))
- if XUPSIEN=""
- QUIT
- Begin DoDot:1
- +32 DO FILTER
- +33 if XUPSPASS=0
- QUIT
- +34 SET XUPSCNT=XUPSCNT+1
- +35 ;set array with person data
- DO FOUND(XUPSCNT,XUPSIEN,XUPSDATE)
- End DoDot:1
- +36 QUIT
- FILTER ;
- +1 ; ZEXCEPT: XUPSDATE,XUPSFNAM,XUPSIEN,XUPSPASS,XUPSPROV,XUPSSSN,XUPSSTN ;global variables within this routine
- +2 ;initialize found flag to found
- SET XUPSPASS=1
- +3 ;skip visitors
- IF '$$ACTIVE^XUSER(XUPSIEN)
- IF ($ORDER(^VA(200,XUPSIEN,8910,0))>0)
- SET XUPSPASS=0
- QUIT
- +4 ;check if matches name filter
- IF XUPSFNAM]""
- SET XUPSPASS=$$NMATCH^XUPSUTL1(XUPSIEN,XUPSFNAM)
- +5 ;failed to match
- if 'XUPSPASS
- QUIT
- +6 ;check ssn filter
- IF XUPSSSN]""
- IF ($PIECE($GET(^VA(200,XUPSIEN,1)),"^",9)'=XUPSSSN)
- SET XUPSPASS=0
- QUIT
- +7 ;check station number
- IF XUPSSTN]""
- SET XUPSPASS=$$STNMAT^XUPSUTL1(XUPSIEN,XUPSSTN)
- +8 ;failed match
- if 'XUPSPASS
- QUIT
- +9 ;check if active person class
- IF XUPSPROV]""
- IF ($$GET^XUA4A72(XUPSIEN,XUPSDATE)<0)
- SET XUPSPASS=0
- QUIT
- +10 QUIT
- FOUND(XUPSCNT,XUPSIEN,XUPSDATE) ;format output array
- +1 ; ZEXCEPT: XUPSPC,XUPSX12 ;global variables within this routine
- +2 NEW XUPSNAME,XUPSSSN,XUPSECID,XUPSSEX,XUPSDOB,I,Y
- +3 ;get full name
- SET Y=$PIECE(^VA(200,XUPSIEN,0),"^",1)
- +4 ;format name into last name~first name~middle name
- SET XUPSNAME=$$HLNAME^HLFNC(Y,"~|\/")
- +5 ;make sure formatted name has all 3 pieces
- IF $LENGTH(XUPSNAME,"~")<3
- SET $PIECE(XUPSNAME,"~",3)=""
- +6 ;get ssn,dob,sex
- SET Y=$GET(^VA(200,XUPSIEN,1))
- +7 ;ssn
- SET XUPSSSN=$PIECE(Y,"^",9)
- +8 ;secid
- SET XUPSECID=$PIECE(Y,"^",1)
- +9 ;sex
- SET XUPSSEX=$PIECE(Y,"^",2)
- +10 ;dob fileman format
- SET XUPSDOB=$PIECE(Y,"^",3)
- +11 ;format dob to correct hl7 format yyyymmdd
- IF XUPSDOB]""
- SET XUPSDOB=$$HLDATE^HLFNC(XUPSDOB,"DT")
- +12 ;set to indicate match found
- SET ^TMP($JOB,"XUPSQRY",1)=1
- +13 SET ^TMP($JOB,"XUPSQRY",XUPSCNT,0)=XUPSECID_"^"_XUPSIEN_"^"_XUPSNAME_"^"_XUPSSSN_"^"_XUPSDOB_"^"_XUPSSEX_"^"
- +14 ;get active person class data
- SET XUPSPC=$$GET^XUA4A72(XUPSIEN,XUPSDATE)
- +15 ;no active person class
- if XUPSPC<0
- SET XUPSPC=""
- +16 ;put provider type, provider class, and are of specialization in output array
- FOR I=1:1:3
- SET ^TMP($JOB,"XUPSQRY",XUPSCNT,I)=$PIECE(XUPSPC,"^",(1+I))_"^"
- +17 ;get x12 code which is not returned by api
- SET XUPSX12=$SELECT(XUPSPC="":"",1:$PIECE(^USC(8932.1,+XUPSPC,0),"^",7))
- +18 ;put va code, x12 code, specialty code, and end-of-record character in output array
- SET ^TMP($JOB,"XUPSQRY",XUPSCNT,4)=$PIECE(XUPSPC,"^",7)_"^"_XUPSX12_"^"_$PIECE(XUPSPC,"^",8)_"^|"
- +19 QUIT