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

XUPSUTL1.m

Go to the documentation of this file.
  1. XUPSUTL1 ;EDS/GRR - Person Service Utility Routine ;4/9/04 10:08
  1. ;;8.0;KERNEL;**325**; Jul 10, 1995
  1. ;;
  1. NMATCH(XUPSIEN,XUPSFNAM) ;
  1. ;;Match on First Name
  1. ;;Input Parameters:
  1. ;; XUPSIEN - Internal Entry Number of New Person entry
  1. ;; XUPSFNAM - Part or all of Person first name
  1. ;;Output:
  1. ;; XUPSOUT - 1 if name matched, 0 if name did not match
  1. N XUPSA,XUPSHFN,XUPSFN,XUPSNFN,XUPSOUT ;establish new variables
  1. S XUPSFN=$P($G(^VA(200,XUPSIEN,0)),"^",1) ;get full name
  1. S XUPSHFN=$$HLNAME^HLFNC(XUPSFN,"~|\/") ;change to HL7 format (last name~first name~middle name)
  1. S XUPSNFN=$P(XUPSHFN,"~",2) ;get first name
  1. S XUPSOUT=$S($E(XUPSNFN,1,$L(XUPSFNAM))[XUPSFNAM:1,1:0) ; match first name to first name passed
  1. Q XUPSOUT ;return 1 if name matched, 0 if no match
  1. ;
  1. STNMAT(XUPSIEN,XUPSSTN) ;
  1. ;;Station Number matching
  1. ;;Input Parameters:
  1. ;; XUPSIEN - Internal Entry Number of New Person entry
  1. ;; XUPSSTN - 3-6 character station number to use as screen
  1. ;; (i.e. 603 or 528A4)
  1. ;;Output:
  1. ;; XUPSOUT - 1 if station matched, 0 if no station match
  1. N XUPSOUT,XUPSDIV,%,A,VASITE,XUPSNDT ;establish new variables
  1. S XUPSDIV=0,XUPSOUT=0 ;initialize new variables
  1. D NOW^%DTC S XUPSNDT=%\1 ;get current date
  1. I '$O(^VA(200,XUPSIEN,2,0)) S A=$$ALL^VASITE(XUPSNDT) G STNQ:'$D(VASITE(XUPSSTN)) S XUPSOUT=1 G STNQ ;if user has no division assigned, get default division and check for match
  1. F S XUPSDIV=$O(^VA(200,XUPSIEN,2,XUPSDIV)) Q:XUPSDIV'>0 I $P($G(^DIC(4,XUPSDIV,99)),"^",1)=XUPSSTN S XUPSOUT=1 Q ;loop through all divisions assigned and check for match
  1. STNQ Q XUPSOUT ;return 1 if match, o if no match
  1. ;