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

LA7VLCM5.m

Go to the documentation of this file. 
  1. LA7VLCM5 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;07/07/09  14:22
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
  1.  ;
  1.  Q
  1.  ;
  1. LOOKUP(GBL,FIND,OUT,ACTN,SCRN,IDARR) ;
  1.  ; DIC clone for use with "special" cross reference.
  1.  ; Allows programmer to display user choices from the xref of
  1.  ; their choosing.
  1.  ; Useful when trying to work with sub-file entries as top-level
  1.  ; "pick-list" entries and the sub-file has a "Whole File" xref
  1.  ; defined.
  1.  ;
  1.  ; Inputs
  1.  ;     GBL Open global reference of the xref to use (up to xref)
  1.  ;         Should be a "standard B" xref type structure (ie #
  1.  ;         of subscripts in node doesnt change between nodes)
  1.  ;         xref: ^XYZ(123,"AF",1,2)="" then GBL = ^XYZ(123,"AF",
  1.  ;    FIND The target text to find in the xref
  1.  ;     OUT <byref> See Outputs below
  1.  ;    ACTN See Outputs below
  1.  ;    SCRN <opt> Data Screen
  1.  ;   IDARR <opt><byref>
  1.  ;         IDARR("NODE0") = full global reference to data zero node
  1.  ;          ie: IDENT("NODE0")="^XYZ(123.2,DA(1),1,DA,0)"
  1.  ;         IDARR("DA",n)= DA location in GBL node
  1.  ;          ie: IDENT("DA",0)=3 ;DA is subscr #3 in GBL var
  1.  ;         IDARR("W") = additional Identifier to display
  1.  ;          ie: IDENT("W")="W "Another Identifier"""
  1.  ;         IDARR("NOIDENT") : if set FM IDENTIFIER wont display
  1.  ;         IDARR("POINTER") : defines File# if NODE is a POINTER
  1.  ;                            ie IDARR("POINTER")=61.2
  1.  ;                            If VPointer specify as FM var pointer:
  1.  ;                            ie "LAB(61.2;LAB(62.49;" etc..
  1.  ;         IDARR("UNIQUE") : If set only displays the matches that
  1.  ;                           havent been displayed already.
  1.  ;
  1.  ; Outputs
  1.  ;  Returns 0 if FIND not found, 1 if FIND was found.
  1.  ;   If return = 0 should check ACTN for return status
  1.  ;
  1.  ;     OUT <byref> If FIND was found OUT will contain:
  1.  ;           OUT = Text value of selected entry
  1.  ;           OUT(1) = GBL's full node of the selected entry
  1.  ;    ACTN "^" = abort listing, >-1 = # records displayed
  1.  ;          -1 = FIND was not found in xref
  1.  ;
  1.  N NODE,NODETOP,NODE0,STOP,FOUND,X,X2,I,SUBSCR
  1.  N SHOWALL,CNT,CNTLST,CNT2,ISPTR,ISVPTR,UNIQUE
  1.  N VAL,LASTVAL,STATUS,TMPNM,IN,DA,IDENT,DIC,DO,IOCUU,%ZIS
  1.  N DIR,DUOUT,DIRUT
  1.  S TMPNM="LA7VLCM5-LOOKUP"
  1.  K ^TMP(TMPNM,$J)
  1.  S GBL=$G(GBL)
  1.  S SCRN=$G(SCRN)
  1.  K OUT,ACTN
  1.  S ACTN=0
  1.  S (FOUND,STOP,SHOWALL,CNT,CNTLST,CNT2,STATUS)=0
  1.  S NODE0=$G(IDARR("NODE0"))
  1.  S NODE=GBL
  1.  S NODETOP=""
  1.  ; setup screen control variables
  1.  I FIND="??" I $G(IOST(0))'="" D  ;
  1.  . S X="IOCUU" ;cursor up
  1.  . D ENDR^%ZISS
  1.  . K %ZIS
  1.  I FIND'="??" D  ;
  1.  . S NODE=NODE_""""_FIND_""")"
  1.  . S SUBSCR=$QL(NODE)
  1.  I FIND="??" D  ;
  1.  . S NODE=$$TRIM^XLFSTR(NODE,"R",",")
  1.  . I $E(NODE,1,$L(NODE))'=")" S NODE=NODE_")"
  1.  . S SUBSCR=$QL(NODE)+1
  1.  ;
  1.  S (ISPTR,ISVPTR,UNIQUE)=0
  1.  I $G(IDARR("POINTER"))'="" D  ;
  1.  . S ISPTR=1
  1.  . I IDARR("POINTER")[";" S ISVPTR=1
  1.  I $D(IDARR("UNIQUE")) S UNIQUE=1
  1.  ;
  1.  I FIND="??" S SHOWALL=1
  1.  S LASTVAL=""
  1.  F  S NODE=$Q(@NODE) S X=$TR($E(NODE,1,$L(GBL)),"""","") S X2=$TR(GBL,"""","") Q:X'[X2  D  Q:STOP  Q:FOUND  ;
  1.  . I CNT2=0 I SHOWALL W !,"Choose from:"
  1.  . ; dont process NODE if # of subscripts doesnt match
  1.  . I NODETOP="" S NODETOP=NODE
  1.  . I NODETOP'="" I $QL(NODE)'=$QL(NODETOP) Q
  1.  . S CNT2=CNT2+1 ;number of nodes checked
  1.  . I $D(IDARR) D  ;
  1.  . . ;setup DA array
  1.  . . K DA
  1.  . . S I=""
  1.  . . F  S I=$O(IDARR("DA",I)) Q:I=""  S X=IDARR("DA",I) S:I>0 DA(I)=$QS(NODE,X) S:I=0 DA=$QS(NODE,X)
  1.  . . ; setup FileMan IDENTIFIER
  1.  . . I '$D(IDENT) I '$D(IDARR("NOIDENT")) D  ;
  1.  . . . S IDENT=""
  1.  . . . K DIC,DO
  1.  . . . S X=$G(IDARR("NODE0"))
  1.  . . . Q:X=""
  1.  . . . S X=$P(X,",DA,",1)
  1.  . . . S X=X_")"
  1.  . . . S X=$NA(@X)
  1.  . . . S X=$$TRIM^XLFSTR(X,"R",")")
  1.  . . . S X=$$TRIM^XLFSTR(X,"R",",")
  1.  . . . S DIC=X_","
  1.  . . . S DIC(0)=""
  1.  . . . D DO^DIC1
  1.  . . . S IDENT=$G(DIC("W"))
  1.  . . ;
  1.  . ;
  1.  . S VAL=$QS(NODE,SUBSCR)
  1.  . I SCRN'="" D  Q:'$T  ;
  1.  . . I NODE0'="" S X=@NODE0 ; set naked gbl reference
  1.  . . X SCRN
  1.  . . S LASTVAL=VAL
  1.  . ;
  1.  . I 'SHOWALL I $E(VAL,1,$L(FIND))'=FIND S LASTVAL=VAL Q  ; SHOWALL for "??" entry
  1.  . I 'SHOWALL I VAL=FIND D  Q:FOUND  ;
  1.  . . I $G(IDENT)'="" D  ;
  1.  . . . I NODE0'="" S X=@NODE0 ; set naked gbl reference
  1.  . . . X IDENT
  1.  . . I $G(IDARR("W"))'="" D  ;
  1.  . . . I NODE0'="" S X=@NODE0 ; set naked gbl reference
  1.  . . . X IDARR("W")
  1.  . . ; If a direct match ask "...OK  //Yes?"
  1.  . . K DIR
  1.  . . S DIR(0)="YAO"
  1.  . . S DIR("A")="        ... OK "
  1.  . . S DIR("B")="Yes"
  1.  . . D ^DIR
  1.  . . I Y D  ;
  1.  . . . S FOUND=1
  1.  . . . S ^TMP(TMPNM,$J,1,1)=VAL
  1.  . . . S ^TMP(TMPNM,$J,1,2)=NODE
  1.  . . ;
  1.  . ;
  1.  . S CNT=CNT+1
  1.  . S ^TMP(TMPNM,$J,CNT,1)=VAL
  1.  . S ^TMP(TMPNM,$J,CNT,2)=NODE
  1.  . I 'SHOWALL W !,?5,CNT,?10,VAL
  1.  . ;
  1.  . I SHOWALL I 'ISPTR D  ;
  1.  . . I 'UNIQUE W !,"   ",VAL Q
  1.  . . I VAL'=LASTVAL W !,"   ",VAL
  1.  . ;
  1.  . I SHOWALL I ISPTR D  ;
  1.  . . N MSG,DIERR
  1.  . . S X=IDARR("POINTER")
  1.  . . S X=$$GET1^DIQ(X,VAL_",",.01,"","","MSG")
  1.  . . I 'UNIQUE D  ;
  1.  . . . I X'="" W !,"   ",X
  1.  . . . I X="" W !,"   ",VAL
  1.  . . ;
  1.  . . I UNIQUE D  ;
  1.  . . . I VAL'=LASTVAL I X'="" W !,"   ",X
  1.  . . . I VAL'=LASTVAL I X="" W !,"   ",VAL
  1.  . . ;
  1.  . ;
  1.  . I $G(IDENT)'="" D  ;
  1.  . . I NODE0'="" S X=@NODE0 ; set naked gbl reference
  1.  . . X IDENT
  1.  . I $G(IDARR("W"))'="" D  ;
  1.  . . I NODE0'="" S X=@NODE0 ; set naked gbl reference
  1.  . . X IDARR("W")
  1.  . S LASTVAL=VAL
  1.  . ;
  1.  . I (SHOWALL&((CNT#($G(IOSL,24)-2)=0)))!('SHOWALL&(CNT#5=0)) D  ;
  1.  . . S CNTLST=CNT
  1.  . . K DIR
  1.  . . S DIR(0)="FAOUr^^"
  1.  . . S DIR("?")=" "
  1.  . . I 'SHOWALL D  ;
  1.  . . . S DIR("?",1)="Press <RETURN> to see more, '^' to exit this list,"
  1.  . . I SHOWALL D  ;
  1.  . . . S DIR("?",1)=""
  1.  . . ;
  1.  . . I 'SHOWALL D  ;
  1.  . . . W !,"Press <RETURN> to see more, '^' to exit this list"
  1.  . . ;
  1.  . . I 'SHOWALL S DIR("A")="OR CHOOSE 1-"_CNT_": "
  1.  . . I SHOWALL S DIR("A")="  '^' TO STOP "
  1.  . . D ^DIR
  1.  . . ;erase "'^' TO STOP" displayed
  1.  . . I SHOWALL I $G(IOCUU)'="" W $C(13)_$J("",15)_$C(13)_IOCUU
  1.  . . I +Y=Y I Y>0 I Y'>CNT S FOUND=Y Q
  1.  . . I $E(Y,1,1)="^" S STOP=1
  1.  . . I $D(DUOUT) S STOP=1
  1.  . . I Y'="" S:$D(DIRUT) STOP=1
  1.  . ;
  1.  ;
  1.  I 'SHOWALL I 'FOUND I CNT I CNT>CNTLST I 'STOP D  ;
  1.  . ; last "CHOOSE 1-X" prompt
  1.  . K DIR
  1.  . S DIR(0)="FAOUr^^"
  1.  . S DIR("?")=" "
  1.  . S DIR("A")="CHOOSE 1-"_CNT_": "
  1.  . D ^DIR
  1.  . I +Y=Y I Y>0 I Y'>CNT S FOUND=Y Q
  1.  . I $E(Y,1,1)="^" S STOP=1
  1.  . S:$D(DUOUT) STOP=1
  1.  . I Y'="" S:$D(DIRUT) STOP=1 Q
  1.  ;
  1.  I FOUND D  ;
  1.  . S OUT=^TMP(TMPNM,$J,FOUND,1)
  1.  . S OUT(1)=^TMP(TMPNM,$J,FOUND,2)
  1.  . S STATUS=1
  1.  . W "  ",OUT
  1.  . ; print selected record's IDENTIFIER
  1.  . I $D(IDARR) D  ;
  1.  . . S NODE=OUT(1)
  1.  . . ;setup DA array
  1.  . . K DA
  1.  . . S I=""
  1.  . . F  S I=$O(IDARR("DA",I)) Q:I=""  S X=IDARR("DA",I) S:I>0 DA(I)=$QS(NODE,X) S:I=0 DA=$QS(NODE,X)
  1.  . . I NODE0'="" S X=@NODE0 ; set naked gbl reference
  1.  . . I IDENT'=""  I '$D(IDARR("NOIDENT")) X IDENT
  1.  . . I $G(IDARR("W"))'="" X IDARR("W")
  1.  . ;
  1.  ;
  1.  I STOP D  ;
  1.  . S STATUS="0^1"
  1.  . S ACTN="^"
  1.  ;
  1.  I 'FOUND I 'STOP D  ;
  1.  . S STATUS=0
  1.  . S ACTN=-1
  1.  ;
  1.  I CNT S ACTN=CNT
  1.  K ^TMP(TMPNM,$J)
  1.  Q STATUS
  1.  ;