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 Dec 13, 2024@02:11:46 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
