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. ;