SCMCNPER ;ALB/ART - PCMM Web Query New Person file ; 03/13/2015
;;5.3;Scheduling;**603,811**;Aug 13, 1993;Build 3
;
QUIT
;
;Cloned from XUPSQRY - PCMM Web needs Application Proxy Access
;added new parameter to lookup by DUZ, and add phone and pager to return
;don't filter out inactive, return info to PCMM Web
;
;Public, Supported ICRs
; #1625 - PERSON CLASS API'S
; #2343 - DBIA2343 (XUSER)
; #4574 - XUPS APIs
; #10000 - Classic FileMan API: Date/Time Manipulation (%DTC)
; #10060 - NEW PERSON FILE
; #10106 - HLFNC (HL7 APIs)
; #10112 - VASITE - Supported APIs for site info
;
;XUPSQRY ;EDS/GRR - Query New Person file ;4/9/04 10:40
;;8.0;KERNEL;**325**; Jul 10, 1995
;
;Input Parameter:
; SCMCVPID - VPID of the user (Required for lookup by VPID)
; SCMCDUZ - File 200 IEN (Required for lookup by IEN)
; SCMCLNAM - Part or all of the last name to use for basis
; of query (Required for lookup by name)
; SCMCFNAM - Part or all of the first name to use for basis
; of query filter (optional, can be null)
; SCMCSSN - Social Security Number (null or full 9 digits) to
; use as additional filter for query
; SCMCPROV - If value set to "P", screen for only providers
; (only persons with active person class)
; SCMCSTN - Filter persons based on station number entered
; (optional, can be null) This parameter is no longer used, but left as a place holder.
; SCMCMNM - Maximum Number of entries to return (*811 - parameter no longer used)
; (Number between 1 and 50. Null defaults to "*", all results)
; SCMCDATE - 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,"SCMCQRY",1) - 1 if found, 0 if not found
; ^TMP($J,"SCMCQRY",n,0) - VPID^IEN^Last Name~First Name~Middle Name^SSN^DOB^SEX^Phone^Pager^
; ^TMP($J,"SCMCQRY",n,1) - Provider Type^
; ^TMP($J,"SCMCQRY",n,2) - Provider Classification^
; ^TMP($J,"SCMCQRY",n,3) - Provider Area of Specialization^
; ^TMP($J,"SCMCQRY",n,4) - VA CODE^X12 CODE^Specialty Code
; ^TMP($J,"SCMCQRY",n,5) - Result of call to $$ACTIVE^XUSER(SCMCIEN)^end-of-record character "|"
;
EN1(RESULT,SCMCVPID,SCMCDUZ,SCMCLNAM,SCMCFNAM,SCMCSSN,SCMCPROV,SCMCSTN,SCMCMNM,SCMCDATE) ;
N %,SCMCNDAT
K ^TMP($J,"SCMCQRY")
K RESULT
S RESULT=$NA(^TMP($J,"SCMCQRY")) ;set variable to name of global array where output data will be stored
S ^TMP($J,"SCMCQRY",1)=0 ;initialize to not found
I $G(SCMCLNAM)="",($G(SCMCVPID)=""),($G(SCMCDUZ)="") Q ;one of the 3 lookup parameters is required
S SCMCFNAM=$G(SCMCFNAM) ;Set to null if missing
S SCMCSSN=$G(SCMCSSN) ;Set to null if missing
S SCMCPROV=$G(SCMCPROV) ;Set to null if missing
S SCMCSTN=$G(SCMCSTN) ;Set to null if missing
I $G(SCMCDATE)="" S SCMCDATE="" ;set to null if missing
D NOW^%DTC
S SCMCNDAT=%\1 ;set date to today and truncate time
S SCMCDATE=$S(SCMCDATE="":SCMCNDAT,1:$$FMDATE^HLFNC(SCMCDATE)) ;change date from hl7 format to fileman format
;
N SCMCCNT,SCMCNAME,SCMCIEN,SCMCDOB,SCMCSEX,SCMCPC,SCMCX12,SCMCPASS ;initialize new set of variables
S:$G(SCMCMNM)="" SCMCMNM="*" ;set to default ; *811 - setting default to all results (parameter no longer used)
S SCMCCNT=0 ;Initialize variable
;
;Lookup by VPID
I $G(SCMCVPID)'="" D Q
.S SCMCIEN=$$IEN^XUPS(SCMCVPID)
.I +SCMCIEN>0 D
..D FILTER
..Q:SCMCPASS=0
..S SCMCCNT=SCMCCNT+1
..D FOUND(SCMCCNT,SCMCIEN,SCMCDATE) ;set array with person data
;
;Lookup by DUZ
I $G(SCMCDUZ)'="" D Q
.Q:$$GET1^DIQ(200,SCMCDUZ_",",.01,"I")=""
.S SCMCIEN=SCMCDUZ
.D FILTER
.Q:SCMCPASS=0
.S SCMCCNT=SCMCCNT+1
.D FOUND(SCMCCNT,SCMCIEN,SCMCDATE) ;set array with person data
;
;Lookup by name
S SCMCIEN=0,SCMCNAME=SCMCLNAM ;initialize variables
N SCMCRET,SCMCMSG,SCI
D FIND^DIC(200,,"@;.01","PQ",SCMCLNAM,"*","B",,,"SCMCRET","SCMCMSG") ;* 811 - modifying to return all results "*" (was 500)
S SCI=0
F S SCI=$O(SCMCRET("DILIST",SCI)) Q:SCI="" D
.S SCMCIEN=$P(SCMCRET("DILIST",SCI,0),U,1)
.D FILTER
.Q:SCMCPASS=0
.S SCMCCNT=SCMCCNT+1
.D FOUND(SCMCCNT,SCMCIEN,SCMCDATE) ;set array with person data
Q
;
FILTER ;
S SCMCPASS=1 ;initialize found flag to found
I SCMCFNAM]"" S SCMCPASS=$$NMATCH(SCMCIEN,SCMCFNAM) ;check if matches name filter
Q:'SCMCPASS ;failed to match
I SCMCSSN]"",($$GET1^DIQ(200,SCMCIEN_",",9)'=SCMCSSN) S SCMCPASS=0 Q ;check ssn filter
;possible future use
;I SCMCSTN]"" S SCMCPASS=$$STNMAT(SCMCIEN,SCMCSTN) ;check station number
;Q:'SCMCPASS ;failed match
I SCMCPROV]"",($$GET^XUA4A72(SCMCIEN,SCMCDATE)<0) S SCMCPASS=0 Q ;check if active person class
Q
;
FOUND(SCMCCNT,SCMCIEN,SCMCDATE) ;format output array
N SCMCNAME,SCMCSSN,SCMCVPID,SCMCSEX,SCMCDOB,SCMCPHON,SCMCPAGR,I,Y
S Y=$$GET1^DIQ(200,SCMCIEN_",",.01) ;get full name
S SCMCNAME=$$HLNAME^HLFNC(Y,"~|\/") ;format name into last name~first name~middle name
I $L(SCMCNAME,"~")<3 S $P(SCMCNAME,"~",3)="" ;make sure formatted name has all 3 pieces
S SCMCSSN=$$GET1^DIQ(200,SCMCIEN_",",9) ;ssn
S SCMCVPID=$$GET1^DIQ(200,SCMCIEN_",",9000) ;vpid
S SCMCSEX=$$GET1^DIQ(200,SCMCIEN_",",4,"I") ;sex
S SCMCDOB=$$GET1^DIQ(200,SCMCIEN_",",5,"I") ;dob fileman format
I SCMCDOB]"" S SCMCDOB=$$HLDATE^HLFNC(SCMCDOB,"DT") ;format dob to correct hl7 format yyyymmdd
S SCMCPHON=$$GET1^DIQ(200,SCMCIEN_",",.132) ;office phone
S SCMCPAGR=$$GET1^DIQ(200,SCMCIEN_",",.138) ;digital pager
S ^TMP($J,"SCMCQRY",1)=1 ;set to indicate match found
S ^TMP($J,"SCMCQRY",SCMCCNT,0)=SCMCVPID_"^"_SCMCIEN_"^"_SCMCNAME_"^"_SCMCSSN_"^"_SCMCDOB_"^"_SCMCSEX_"^"_SCMCPHON_"^"_SCMCPAGR_"^"
S SCMCPC=$$GET^XUA4A72(SCMCIEN,SCMCDATE) ;get active person class data
S:SCMCPC<0 SCMCPC="" ;no active person class
F I=1:1:3 S ^TMP($J,"SCMCQRY",SCMCCNT,I)=$P(SCMCPC,"^",(1+I))_"^" ;put provider type, provider class, and are of specialization in output array
S SCMCX12="" ;PCMM Web does not use this - 603
S ^TMP($J,"SCMCQRY",SCMCCNT,4)=$P(SCMCPC,"^",7)_"^"_SCMCX12_"^"_$P(SCMCPC,"^",8)_"^" ;put va code, x12 code, specialty code
S ^TMP($J,"SCMCQRY",SCMCCNT,5)=$$ACTIVE^XUSER(SCMCIEN)_"^|" ;603
Q
;
NMATCH(SCMCIEN,SCMCFNAM) ;
;Match on First Name
;Input Parameters:
; SCMCIEN - Internal Entry Number of New Person entry
; SCMCFNAM - Part or all of Person first name
;Output:
; SCMCOUT - 1 if name matched, 0 if name did not match
;
N SCMCA,SCMCHFN,SCMCFN,SCMCNFN,SCMCOUT ;establish new variables
S SCMCFN=$$GET1^DIQ(200,SCMCIEN_",",.01) ;get full name
S SCMCHFN=$$HLNAME^HLFNC(SCMCFN,"~|\/") ;change to HL7 format (last name~first name~middle name)
S SCMCNFN=$P(SCMCHFN,"~",2) ;get first name
S SCMCOUT=$S($E(SCMCNFN,1,$L(SCMCFNAM))[SCMCFNAM:1,1:0) ; match first name to first name passed
Q SCMCOUT ;return 1 if name matched, 0 if no match
;
;STNMAT(SCMCIEN,SCMCSTN) ;Station Number matching (possible future use)
;Input Parameters:
; SCMCIEN - Internal Entry Number of New Person entry
; SCMCSTN - 3-6 character station number to use as screen
; (i.e. 603 or 528A4)
;Output:
; SCMCOUT - 1 if station matched, 0 if no station match
;
; NOTE: If this code is ever used, needs to be tested and subscription to ICR 4055
;
;NEW SCMCOUT,SCMCRET,SCI,SCHIT
;SET SCMCOUT=0
;DO DIVGET^XUSRB2(.SCMCRET,SCMCIEN)
;IF +SCMCRET(0)'=0 DO
;. SET SCHIT=0
;. SET SCI=""
;. FOR SET SCI=$ORDER(SCMCRET(SCI)) QUIT:SCI=""!(SCHIT) DO
;. . IF $PIECE(SCMCRET(SCI),U,3)=SCMCSTN DO
;. . . SET SCMCOUT=1
;. . . SET SCHIT=1
;QUIT SCMCOUT ;return 1 if match, 0 if no match
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCNPER 7888 printed Oct 16, 2024@18:41:41 Page 2
SCMCNPER ;ALB/ART - PCMM Web Query New Person file ; 03/13/2015
+1 ;;5.3;Scheduling;**603,811**;Aug 13, 1993;Build 3
+2 ;
+3 QUIT
+4 ;
+5 ;Cloned from XUPSQRY - PCMM Web needs Application Proxy Access
+6 ;added new parameter to lookup by DUZ, and add phone and pager to return
+7 ;don't filter out inactive, return info to PCMM Web
+8 ;
+9 ;Public, Supported ICRs
+10 ; #1625 - PERSON CLASS API'S
+11 ; #2343 - DBIA2343 (XUSER)
+12 ; #4574 - XUPS APIs
+13 ; #10000 - Classic FileMan API: Date/Time Manipulation (%DTC)
+14 ; #10060 - NEW PERSON FILE
+15 ; #10106 - HLFNC (HL7 APIs)
+16 ; #10112 - VASITE - Supported APIs for site info
+17 ;
+18 ;XUPSQRY ;EDS/GRR - Query New Person file ;4/9/04 10:40
+19 ;;8.0;KERNEL;**325**; Jul 10, 1995
+20 ;
+21 ;Input Parameter:
+22 ; SCMCVPID - VPID of the user (Required for lookup by VPID)
+23 ; SCMCDUZ - File 200 IEN (Required for lookup by IEN)
+24 ; SCMCLNAM - Part or all of the last name to use for basis
+25 ; of query (Required for lookup by name)
+26 ; SCMCFNAM - Part or all of the first name to use for basis
+27 ; of query filter (optional, can be null)
+28 ; SCMCSSN - Social Security Number (null or full 9 digits) to
+29 ; use as additional filter for query
+30 ; SCMCPROV - If value set to "P", screen for only providers
+31 ; (only persons with active person class)
+32 ; SCMCSTN - Filter persons based on station number entered
+33 ; (optional, can be null) This parameter is no longer used, but left as a place holder.
+34 ; SCMCMNM - Maximum Number of entries to return (*811 - parameter no longer used)
+35 ; (Number between 1 and 50. Null defaults to "*", all results)
+36 ; SCMCDATE - Date to be used to determine whether person has
+37 ; active person class. If null, current date is used.
+38 ;
+39 ;Output:
+40 ; RESULT - Name of global array were output data is stored
+41 ; ^TMP($J,"SCMCQRY",1) - 1 if found, 0 if not found
+42 ; ^TMP($J,"SCMCQRY",n,0) - VPID^IEN^Last Name~First Name~Middle Name^SSN^DOB^SEX^Phone^Pager^
+43 ; ^TMP($J,"SCMCQRY",n,1) - Provider Type^
+44 ; ^TMP($J,"SCMCQRY",n,2) - Provider Classification^
+45 ; ^TMP($J,"SCMCQRY",n,3) - Provider Area of Specialization^
+46 ; ^TMP($J,"SCMCQRY",n,4) - VA CODE^X12 CODE^Specialty Code
+47 ; ^TMP($J,"SCMCQRY",n,5) - Result of call to $$ACTIVE^XUSER(SCMCIEN)^end-of-record character "|"
+48 ;
EN1(RESULT,SCMCVPID,SCMCDUZ,SCMCLNAM,SCMCFNAM,SCMCSSN,SCMCPROV,SCMCSTN,SCMCMNM,SCMCDATE) ;
+1 NEW %,SCMCNDAT
+2 KILL ^TMP($JOB,"SCMCQRY")
+3 KILL RESULT
+4 ;set variable to name of global array where output data will be stored
SET RESULT=$NAME(^TMP($JOB,"SCMCQRY"))
+5 ;initialize to not found
SET ^TMP($JOB,"SCMCQRY",1)=0
+6 ;one of the 3 lookup parameters is required
IF $GET(SCMCLNAM)=""
IF ($GET(SCMCVPID)="")
IF ($GET(SCMCDUZ)="")
QUIT
+7 ;Set to null if missing
SET SCMCFNAM=$GET(SCMCFNAM)
+8 ;Set to null if missing
SET SCMCSSN=$GET(SCMCSSN)
+9 ;Set to null if missing
SET SCMCPROV=$GET(SCMCPROV)
+10 ;Set to null if missing
SET SCMCSTN=$GET(SCMCSTN)
+11 ;set to null if missing
IF $GET(SCMCDATE)=""
SET SCMCDATE=""
+12 DO NOW^%DTC
+13 ;set date to today and truncate time
SET SCMCNDAT=%\1
+14 ;change date from hl7 format to fileman format
SET SCMCDATE=$SELECT(SCMCDATE="":SCMCNDAT,1:$$FMDATE^HLFNC(SCMCDATE))
+15 ;
+16 ;initialize new set of variables
NEW SCMCCNT,SCMCNAME,SCMCIEN,SCMCDOB,SCMCSEX,SCMCPC,SCMCX12,SCMCPASS
+17 ;set to default ; *811 - setting default to all results (parameter no longer used)
if $GET(SCMCMNM)=""
SET SCMCMNM="*"
+18 ;Initialize variable
SET SCMCCNT=0
+19 ;
+20 ;Lookup by VPID
+21 IF $GET(SCMCVPID)'=""
Begin DoDot:1
+22 SET SCMCIEN=$$IEN^XUPS(SCMCVPID)
+23 IF +SCMCIEN>0
Begin DoDot:2
+24 DO FILTER
+25 if SCMCPASS=0
QUIT
+26 SET SCMCCNT=SCMCCNT+1
+27 ;set array with person data
DO FOUND(SCMCCNT,SCMCIEN,SCMCDATE)
End DoDot:2
End DoDot:1
QUIT
+28 ;
+29 ;Lookup by DUZ
+30 IF $GET(SCMCDUZ)'=""
Begin DoDot:1
+31 if $$GET1^DIQ(200,SCMCDUZ_",",.01,"I")=""
QUIT
+32 SET SCMCIEN=SCMCDUZ
+33 DO FILTER
+34 if SCMCPASS=0
QUIT
+35 SET SCMCCNT=SCMCCNT+1
+36 ;set array with person data
DO FOUND(SCMCCNT,SCMCIEN,SCMCDATE)
End DoDot:1
QUIT
+37 ;
+38 ;Lookup by name
+39 ;initialize variables
SET SCMCIEN=0
SET SCMCNAME=SCMCLNAM
+40 NEW SCMCRET,SCMCMSG,SCI
+41 ;* 811 - modifying to return all results "*" (was 500)
DO FIND^DIC(200,,"@;.01","PQ",SCMCLNAM,"*","B",,,"SCMCRET","SCMCMSG")
+42 SET SCI=0
+43 FOR
SET SCI=$ORDER(SCMCRET("DILIST",SCI))
if SCI=""
QUIT
Begin DoDot:1
+44 SET SCMCIEN=$PIECE(SCMCRET("DILIST",SCI,0),U,1)
+45 DO FILTER
+46 if SCMCPASS=0
QUIT
+47 SET SCMCCNT=SCMCCNT+1
+48 ;set array with person data
DO FOUND(SCMCCNT,SCMCIEN,SCMCDATE)
End DoDot:1
+49 QUIT
+50 ;
FILTER ;
+1 ;initialize found flag to found
SET SCMCPASS=1
+2 ;check if matches name filter
IF SCMCFNAM]""
SET SCMCPASS=$$NMATCH(SCMCIEN,SCMCFNAM)
+3 ;failed to match
if 'SCMCPASS
QUIT
+4 ;check ssn filter
IF SCMCSSN]""
IF ($$GET1^DIQ(200,SCMCIEN_",",9)'=SCMCSSN)
SET SCMCPASS=0
QUIT
+5 ;possible future use
+6 ;I SCMCSTN]"" S SCMCPASS=$$STNMAT(SCMCIEN,SCMCSTN) ;check station number
+7 ;Q:'SCMCPASS ;failed match
+8 ;check if active person class
IF SCMCPROV]""
IF ($$GET^XUA4A72(SCMCIEN,SCMCDATE)<0)
SET SCMCPASS=0
QUIT
+9 QUIT
+10 ;
FOUND(SCMCCNT,SCMCIEN,SCMCDATE) ;format output array
+1 NEW SCMCNAME,SCMCSSN,SCMCVPID,SCMCSEX,SCMCDOB,SCMCPHON,SCMCPAGR,I,Y
+2 ;get full name
SET Y=$$GET1^DIQ(200,SCMCIEN_",",.01)
+3 ;format name into last name~first name~middle name
SET SCMCNAME=$$HLNAME^HLFNC(Y,"~|\/")
+4 ;make sure formatted name has all 3 pieces
IF $LENGTH(SCMCNAME,"~")<3
SET $PIECE(SCMCNAME,"~",3)=""
+5 ;ssn
SET SCMCSSN=$$GET1^DIQ(200,SCMCIEN_",",9)
+6 ;vpid
SET SCMCVPID=$$GET1^DIQ(200,SCMCIEN_",",9000)
+7 ;sex
SET SCMCSEX=$$GET1^DIQ(200,SCMCIEN_",",4,"I")
+8 ;dob fileman format
SET SCMCDOB=$$GET1^DIQ(200,SCMCIEN_",",5,"I")
+9 ;format dob to correct hl7 format yyyymmdd
IF SCMCDOB]""
SET SCMCDOB=$$HLDATE^HLFNC(SCMCDOB,"DT")
+10 ;office phone
SET SCMCPHON=$$GET1^DIQ(200,SCMCIEN_",",.132)
+11 ;digital pager
SET SCMCPAGR=$$GET1^DIQ(200,SCMCIEN_",",.138)
+12 ;set to indicate match found
SET ^TMP($JOB,"SCMCQRY",1)=1
+13 SET ^TMP($JOB,"SCMCQRY",SCMCCNT,0)=SCMCVPID_"^"_SCMCIEN_"^"_SCMCNAME_"^"_SCMCSSN_"^"_SCMCDOB_"^"_SCMCSEX_"^"_SCMCPHON_"^"_SCMCPAGR_"^"
+14 ;get active person class data
SET SCMCPC=$$GET^XUA4A72(SCMCIEN,SCMCDATE)
+15 ;no active person class
if SCMCPC<0
SET SCMCPC=""
+16 ;put provider type, provider class, and are of specialization in output array
FOR I=1:1:3
SET ^TMP($JOB,"SCMCQRY",SCMCCNT,I)=$PIECE(SCMCPC,"^",(1+I))_"^"
+17 ;PCMM Web does not use this - 603
SET SCMCX12=""
+18 ;put va code, x12 code, specialty code
SET ^TMP($JOB,"SCMCQRY",SCMCCNT,4)=$PIECE(SCMCPC,"^",7)_"^"_SCMCX12_"^"_$PIECE(SCMCPC,"^",8)_"^"
+19 ;603
SET ^TMP($JOB,"SCMCQRY",SCMCCNT,5)=$$ACTIVE^XUSER(SCMCIEN)_"^|"
+20 QUIT
+21 ;
NMATCH(SCMCIEN,SCMCFNAM) ;
+1 ;Match on First Name
+2 ;Input Parameters:
+3 ; SCMCIEN - Internal Entry Number of New Person entry
+4 ; SCMCFNAM - Part or all of Person first name
+5 ;Output:
+6 ; SCMCOUT - 1 if name matched, 0 if name did not match
+7 ;
+8 ;establish new variables
NEW SCMCA,SCMCHFN,SCMCFN,SCMCNFN,SCMCOUT
+9 ;get full name
SET SCMCFN=$$GET1^DIQ(200,SCMCIEN_",",.01)
+10 ;change to HL7 format (last name~first name~middle name)
SET SCMCHFN=$$HLNAME^HLFNC(SCMCFN,"~|\/")
+11 ;get first name
SET SCMCNFN=$PIECE(SCMCHFN,"~",2)
+12 ; match first name to first name passed
SET SCMCOUT=$SELECT($EXTRACT(SCMCNFN,1,$LENGTH(SCMCFNAM))[SCMCFNAM:1,1:0)
+13 ;return 1 if name matched, 0 if no match
QUIT SCMCOUT
+14 ;
+15 ;STNMAT(SCMCIEN,SCMCSTN) ;Station Number matching (possible future use)
+16 ;Input Parameters:
+17 ; SCMCIEN - Internal Entry Number of New Person entry
+18 ; SCMCSTN - 3-6 character station number to use as screen
+19 ; (i.e. 603 or 528A4)
+20 ;Output:
+21 ; SCMCOUT - 1 if station matched, 0 if no station match
+22 ;
+23 ; NOTE: If this code is ever used, needs to be tested and subscription to ICR 4055
+24 ;
+25 ;NEW SCMCOUT,SCMCRET,SCI,SCHIT
+26 ;SET SCMCOUT=0
+27 ;DO DIVGET^XUSRB2(.SCMCRET,SCMCIEN)
+28 ;IF +SCMCRET(0)'=0 DO
+29 ;. SET SCHIT=0
+30 ;. SET SCI=""
+31 ;. FOR SET SCI=$ORDER(SCMCRET(SCI)) QUIT:SCI=""!(SCHIT) DO
+32 ;. . IF $PIECE(SCMCRET(SCI),U,3)=SCMCSTN DO
+33 ;. . . SET SCMCOUT=1
+34 ;. . . SET SCHIT=1
+35 ;QUIT SCMCOUT ;return 1 if match, 0 if no match
+36 ;
