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

MAGVRS42.m

Go to the documentation of this file. 
  1. MAGVRS42 ;WOIFO/MLH/NST - Utility for file lookup by name/value pairs ; 06 Feb 2012 07:10 PM
  1.  ;;3.0;IMAGING;**118**;Mar 19, 2002;Build 4525;May 01, 2013
  1.  ;; Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;; +---------------------------------------------------------------+
  1.  ;; | Property of the US Government.                                |
  1.  ;; | No permission to copy or redistribute this software is given. |
  1.  ;; | Use of unreleased versions of this software requires the user |
  1.  ;; | to execute a written test agreement with the VistA Imaging    |
  1.  ;; | Development Office of the Department of Veterans Affairs,     |
  1.  ;; | telephone (301) 734-0100.                                     |
  1.  ;; | The Food and Drug Administration classifies this software as  |
  1.  ;; | a medical device.  As such, it may not be changed in any way. |
  1.  ;; | Modifications to this software may result in an adulterated   |
  1.  ;; | medical device under 21CFR820, the use of which is considered |
  1.  ;; | to be a violation of US Federal Statutes.                     |
  1.  ;; +---------------------------------------------------------------+
  1.  ;;
  1.  Q
  1. FINDBYAT(OUT,FILE,ATTSARY) ; Find by name/value pairs
  1.  ; inputs:    FILE    a FileMan file number (must be a parent file)
  1.  ;            ATTSARY array of name/value pairs - names must be those
  1.  ;                    of main-level fields (not multiples or children)
  1.  ;
  1.  ; Performs a name/value pair lookup on a flat FileMan file.
  1.  ; 
  1.  N OSEP,ISEP,SSEP ; separators
  1.  N ATTIX ; attribute array index
  1.  N ATTNAME,ATTVAL ; attribute name and value
  1.  N SRCHFLD ; search field number
  1.  N SRCHARY ; search fields array
  1.  N SCREEN ; screening logic string
  1.  N SCRLOGIC ; single piece of screening logic
  1.  N XREFINFO ; cross-reference information from data dictionary
  1.  N XREFNAME ; index to pass to the FileMan search function
  1.  N XREFIX ; index of cross references for a field
  1.  N XREFVAL ; value to be looked up on the cross reference
  1.  N DIC ; file reference of the global node
  1.  N DLAYGO ; FileMan parameter enabling LAYGO for referenced file.
  1.  N OUTIX ; output index
  1.  ;
  1.  K OUT
  1.  S OSEP=$$OUTSEP^MAGVRS41,ISEP=$$INPUTSEP^MAGVRS41,SSEP=$$STATSEP^MAGVRS41
  1.  ; validate input parameters
  1.  I 'FILE S OUT(1)="-1"_SSEP_"No file specified" Q
  1.  I ($E(FILE,1,4)'=2005),($E(FILE,1,4)'=2006) S OUT(1)="-12"_SSEP_"File not in valid search range" Q
  1.  D  Q:$D(OUT)  ; does the file exist?
  1.  . N MAGATTS
  1.  . D FILE^DID(FILE,"N","NAME","MAGATTS")
  1.  . I '$D(MAGATTS("NAME")) S OUT(1)="-2"_SSEP_"Invalid file number ("_FILE_")" Q
  1.  . Q
  1.  I $D(ATTSARY)<10 S OUT(1)="-3"_SSEP_"No search attributes specified" Q
  1.  ;
  1.  S ATTIX=0
  1.  ; Parse the attributes.  Find a cross-reference to look up on, and build a
  1.  ; screen if there are multiple search criteria.  At least one of the
  1.  ; search fields must be cross-referenced.
  1.  F  S ATTIX=$O(ATTSARY(ATTIX)) Q:'ATTIX  D  Q:$D(OUT)
  1.  . S ATTNAME=$P(ATTSARY(ATTIX),ISEP,1),ATTVAL=$P(ATTSARY(ATTIX),ISEP,2)
  1.  . I ATTNAME="" D  Q
  1.  . . S OUT(1)="-4"_SSEP_"Field name missing"
  1.  . . Q
  1.  . ; Set SERVICE INSTITUTION based on value sent for CREATING ENTITY
  1.  . ;;;;
  1.  . I "^2005.6^2005.61^"[("^"_FILE_"^"),ATTNAME="CREATING ENTITY" D  Q:$D(OUT)
  1.  . . N SIFLD,SIVAL,Y,X
  1.  . . ; Note: This must be refined (preferably recast as a service)
  1.  . . ;       if external (non-VA) institution files are introduced in future
  1.  . . S SIFLD="SERVICE INSTITUTION REFERENCE"
  1.  . . S DIC=2005.8,DIC(0)="X",X=ATTVAL D ^DIC S SIVAL=$P(Y,"^",1)
  1.  . . I SIVAL<0 S OUT(1)=-101_SSEP_"CREATING ENTITY ("_ATTVAL_") not found in IMAGING SERVICE INSTITUTION File" Q
  1.  . . S ATTVAL=SIVAL,ATTNAME=SIFLD
  1.  . . Q
  1.  . ;;;
  1.  . S SRCHFLD=$S(ATTNAME?.N.1".".N:ATTNAME,1:$$GETFIELD^MAGVRS41(FILE,ATTNAME))  ; Field Name has at least one Alpha character
  1.  . I SRCHFLD="" D  Q
  1.  . . S OUT(1)="-5"_SSEP_"Unknown field name"
  1.  . . Q
  1.  . D  ; select an index and build a search string
  1.  . . N GBLINFO ; DD information about a field
  1.  . . N GBLLOC ; global location of the field on the file
  1.  . . N GBLNODE ; global node of the field on the file
  1.  . . N GBLPIECE ; piece of the field on the global node
  1.  . . ; already got a cross reference name and value?  if not, try to find one;
  1.  . . ; otherwise, add this field to the screen
  1.  . . I $D(^DD(FILE,"IX",SRCHFLD)),'$D(XREFNAME) D  Q:XREFNAME'=""  ; ICR 5550
  1.  . . . S XREFIX=0
  1.  . . . F  S XREFIX=$O(^DD(FILE,SRCHFLD,1,XREFIX)) Q:'XREFIX  D  Q:$G(XREFNAME)'=""
  1.  . . . . ; select only regular xrefs; not MUMPS / trigger xrefs, etc.
  1.  . . . . S XREFINFO=$G(^DD(FILE,SRCHFLD,1,XREFIX,0)) Q:XREFINFO=""
  1.  . . . . S:$P(XREFINFO,"^",3)="" XREFNAME=$P(XREFINFO,"^",2)
  1.  . . . . S:XREFNAME'="" XREFVAL=ATTVAL
  1.  . . . . Q
  1.  . . . Q
  1.  . . ; add this field to the screen
  1.  . . D FIELD^DID(FILE,SRCHFLD,,"GLOBAL SUBSCRIPT LOCATION","GBLINFO")
  1.  . . I $D(^TMP("DIERR",$J)) D  Q
  1.  . . . S OUT(1)="-13"_SSEP_$G(^TMP("DIERR",$J,1))_"FM "_$G(^(1,"TEXT",1))
  1.  . . . Q
  1.  . . S GBLLOC=$G(GBLINFO("GLOBAL SUBSCRIPT LOCATION"))
  1.  . . I GBLLOC="" S OUT(1)="-11"_SSEP_"DD information not available for attribute "_ATTNAME Q
  1.  . . S GBLNODE=$P(GBLLOC,";",1),GBLPIECE=+$P(GBLLOC,";",2)
  1.  . . I 'GBLPIECE D  Q
  1.  . . . S OUT(1)="-6"_SSEP_"Not a top-level field name"
  1.  . . . Q
  1.  . . I GBLNODE="" D  Q
  1.  . . . S OUT(1)="-7"_SSEP_"Corrupt field definition in DD"
  1.  . . . Q
  1.  . . I GBLNODE'=+GBLNODE S GBLNODE=""""""_GBLNODE_""""""
  1.  . . S SCRLOGIC="$P(@(DIC_Y_"","_GBLNODE_")""),""^"","_GBLPIECE_")="""_ATTVAL_""""
  1.  . . S SCREEN=$S('$D(SCREEN):"I "_SCRLOGIC,1:SCREEN_","_SCRLOGIC)
  1.  . . Q
  1.  . Q
  1.  Q:$D(OUT)
  1.  I ('$D(XREFVAL))!('$D(XREFNAME)) S OUT(1)="-9"_SSEP_"No cross reference found to search on" Q
  1.  D FIND^DIC(FILE,,"@","QX",XREFVAL,,XREFNAME,$G(SCREEN))
  1.  ; retrieve search results and massage into expected format
  1.  I '$D(^TMP("DILIST",$J,2)) S OUT(1)="-10"_SSEP_"NO MATCH FOUND" Q
  1.  M OUT=^TMP("DILIST",$J,2)
  1.  S OUTIX=0
  1.  F  S OUTIX=$O(OUT(OUTIX)) Q:'OUTIX  S OUT(OUTIX)="0"_SSEP_SSEP_OUT(OUTIX)
  1.  ;
  1.  Q