LA7VLCM5 ;DALOI/JDB - LAB CODE MAPPING FILE UTILITIES ;07/07/09 14:22
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
Q
;
LOOKUP(GBL,FIND,OUT,ACTN,SCRN,IDARR) ;
; DIC clone for use with "special" cross reference.
; Allows programmer to display user choices from the xref of
; their choosing.
; Useful when trying to work with sub-file entries as top-level
; "pick-list" entries and the sub-file has a "Whole File" xref
; defined.
;
; Inputs
; GBL Open global reference of the xref to use (up to xref)
; Should be a "standard B" xref type structure (ie #
; of subscripts in node doesnt change between nodes)
; xref: ^XYZ(123,"AF",1,2)="" then GBL = ^XYZ(123,"AF",
; FIND The target text to find in the xref
; OUT <byref> See Outputs below
; ACTN See Outputs below
; SCRN <opt> Data Screen
; IDARR <opt><byref>
; IDARR("NODE0") = full global reference to data zero node
; ie: IDENT("NODE0")="^XYZ(123.2,DA(1),1,DA,0)"
; IDARR("DA",n)= DA location in GBL node
; ie: IDENT("DA",0)=3 ;DA is subscr #3 in GBL var
; IDARR("W") = additional Identifier to display
; ie: IDENT("W")="W "Another Identifier"""
; IDARR("NOIDENT") : if set FM IDENTIFIER wont display
; IDARR("POINTER") : defines File# if NODE is a POINTER
; ie IDARR("POINTER")=61.2
; If VPointer specify as FM var pointer:
; ie "LAB(61.2;LAB(62.49;" etc..
; IDARR("UNIQUE") : If set only displays the matches that
; havent been displayed already.
;
; Outputs
; Returns 0 if FIND not found, 1 if FIND was found.
; If return = 0 should check ACTN for return status
;
; OUT <byref> If FIND was found OUT will contain:
; OUT = Text value of selected entry
; OUT(1) = GBL's full node of the selected entry
; ACTN "^" = abort listing, >-1 = # records displayed
; -1 = FIND was not found in xref
;
N NODE,NODETOP,NODE0,STOP,FOUND,X,X2,I,SUBSCR
N SHOWALL,CNT,CNTLST,CNT2,ISPTR,ISVPTR,UNIQUE
N VAL,LASTVAL,STATUS,TMPNM,IN,DA,IDENT,DIC,DO,IOCUU,%ZIS
N DIR,DUOUT,DIRUT
S TMPNM="LA7VLCM5-LOOKUP"
K ^TMP(TMPNM,$J)
S GBL=$G(GBL)
S SCRN=$G(SCRN)
K OUT,ACTN
S ACTN=0
S (FOUND,STOP,SHOWALL,CNT,CNTLST,CNT2,STATUS)=0
S NODE0=$G(IDARR("NODE0"))
S NODE=GBL
S NODETOP=""
; setup screen control variables
I FIND="??" I $G(IOST(0))'="" D ;
. S X="IOCUU" ;cursor up
. D ENDR^%ZISS
. K %ZIS
I FIND'="??" D ;
. S NODE=NODE_""""_FIND_""")"
. S SUBSCR=$QL(NODE)
I FIND="??" D ;
. S NODE=$$TRIM^XLFSTR(NODE,"R",",")
. I $E(NODE,1,$L(NODE))'=")" S NODE=NODE_")"
. S SUBSCR=$QL(NODE)+1
;
S (ISPTR,ISVPTR,UNIQUE)=0
I $G(IDARR("POINTER"))'="" D ;
. S ISPTR=1
. I IDARR("POINTER")[";" S ISVPTR=1
I $D(IDARR("UNIQUE")) S UNIQUE=1
;
I FIND="??" S SHOWALL=1
S LASTVAL=""
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 ;
. I CNT2=0 I SHOWALL W !,"Choose from:"
. ; dont process NODE if # of subscripts doesnt match
. I NODETOP="" S NODETOP=NODE
. I NODETOP'="" I $QL(NODE)'=$QL(NODETOP) Q
. S CNT2=CNT2+1 ;number of nodes checked
. I $D(IDARR) D ;
. . ;setup DA array
. . K DA
. . S I=""
. . 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)
. . ; setup FileMan IDENTIFIER
. . I '$D(IDENT) I '$D(IDARR("NOIDENT")) D ;
. . . S IDENT=""
. . . K DIC,DO
. . . S X=$G(IDARR("NODE0"))
. . . Q:X=""
. . . S X=$P(X,",DA,",1)
. . . S X=X_")"
. . . S X=$NA(@X)
. . . S X=$$TRIM^XLFSTR(X,"R",")")
. . . S X=$$TRIM^XLFSTR(X,"R",",")
. . . S DIC=X_","
. . . S DIC(0)=""
. . . D DO^DIC1
. . . S IDENT=$G(DIC("W"))
. . ;
. ;
. S VAL=$QS(NODE,SUBSCR)
. I SCRN'="" D Q:'$T ;
. . I NODE0'="" S X=@NODE0 ; set naked gbl reference
. . X SCRN
. . S LASTVAL=VAL
. ;
. I 'SHOWALL I $E(VAL,1,$L(FIND))'=FIND S LASTVAL=VAL Q ; SHOWALL for "??" entry
. I 'SHOWALL I VAL=FIND D Q:FOUND ;
. . I $G(IDENT)'="" D ;
. . . I NODE0'="" S X=@NODE0 ; set naked gbl reference
. . . X IDENT
. . I $G(IDARR("W"))'="" D ;
. . . I NODE0'="" S X=@NODE0 ; set naked gbl reference
. . . X IDARR("W")
. . ; If a direct match ask "...OK //Yes?"
. . K DIR
. . S DIR(0)="YAO"
. . S DIR("A")=" ... OK "
. . S DIR("B")="Yes"
. . D ^DIR
. . I Y D ;
. . . S FOUND=1
. . . S ^TMP(TMPNM,$J,1,1)=VAL
. . . S ^TMP(TMPNM,$J,1,2)=NODE
. . ;
. ;
. S CNT=CNT+1
. S ^TMP(TMPNM,$J,CNT,1)=VAL
. S ^TMP(TMPNM,$J,CNT,2)=NODE
. I 'SHOWALL W !,?5,CNT,?10,VAL
. ;
. I SHOWALL I 'ISPTR D ;
. . I 'UNIQUE W !," ",VAL Q
. . I VAL'=LASTVAL W !," ",VAL
. ;
. I SHOWALL I ISPTR D ;
. . N MSG,DIERR
. . S X=IDARR("POINTER")
. . S X=$$GET1^DIQ(X,VAL_",",.01,"","","MSG")
. . I 'UNIQUE D ;
. . . I X'="" W !," ",X
. . . I X="" W !," ",VAL
. . ;
. . I UNIQUE D ;
. . . I VAL'=LASTVAL I X'="" W !," ",X
. . . I VAL'=LASTVAL I X="" W !," ",VAL
. . ;
. ;
. I $G(IDENT)'="" D ;
. . I NODE0'="" S X=@NODE0 ; set naked gbl reference
. . X IDENT
. I $G(IDARR("W"))'="" D ;
. . I NODE0'="" S X=@NODE0 ; set naked gbl reference
. . X IDARR("W")
. S LASTVAL=VAL
. ;
. I (SHOWALL&((CNT#($G(IOSL,24)-2)=0)))!('SHOWALL&(CNT#5=0)) D ;
. . S CNTLST=CNT
. . K DIR
. . S DIR(0)="FAOUr^^"
. . S DIR("?")=" "
. . I 'SHOWALL D ;
. . . S DIR("?",1)="Press <RETURN> to see more, '^' to exit this list,"
. . I SHOWALL D ;
. . . S DIR("?",1)=""
. . ;
. . I 'SHOWALL D ;
. . . W !,"Press <RETURN> to see more, '^' to exit this list"
. . ;
. . I 'SHOWALL S DIR("A")="OR CHOOSE 1-"_CNT_": "
. . I SHOWALL S DIR("A")=" '^' TO STOP "
. . D ^DIR
. . ;erase "'^' TO STOP" displayed
. . I SHOWALL I $G(IOCUU)'="" W $C(13)_$J("",15)_$C(13)_IOCUU
. . I +Y=Y I Y>0 I Y'>CNT S FOUND=Y Q
. . I $E(Y,1,1)="^" S STOP=1
. . I $D(DUOUT) S STOP=1
. . I Y'="" S:$D(DIRUT) STOP=1
. ;
;
I 'SHOWALL I 'FOUND I CNT I CNT>CNTLST I 'STOP D ;
. ; last "CHOOSE 1-X" prompt
. K DIR
. S DIR(0)="FAOUr^^"
. S DIR("?")=" "
. S DIR("A")="CHOOSE 1-"_CNT_": "
. D ^DIR
. I +Y=Y I Y>0 I Y'>CNT S FOUND=Y Q
. I $E(Y,1,1)="^" S STOP=1
. S:$D(DUOUT) STOP=1
. I Y'="" S:$D(DIRUT) STOP=1 Q
;
I FOUND D ;
. S OUT=^TMP(TMPNM,$J,FOUND,1)
. S OUT(1)=^TMP(TMPNM,$J,FOUND,2)
. S STATUS=1
. W " ",OUT
. ; print selected record's IDENTIFIER
. I $D(IDARR) D ;
. . S NODE=OUT(1)
. . ;setup DA array
. . K DA
. . S I=""
. . 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)
. . I NODE0'="" S X=@NODE0 ; set naked gbl reference
. . I IDENT'="" I '$D(IDARR("NOIDENT")) X IDENT
. . I $G(IDARR("W"))'="" X IDARR("W")
. ;
;
I STOP D ;
. S STATUS="0^1"
. S ACTN="^"
;
I 'FOUND I 'STOP D ;
. S STATUS=0
. S ACTN=-1
;
I CNT S ACTN=CNT
K ^TMP(TMPNM,$J)
Q STATUS
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7VLCM5 7164 printed Nov 22, 2024@16:50:53 Page 2
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
+2 ;
+3 QUIT
+4 ;
LOOKUP(GBL,FIND,OUT,ACTN,SCRN,IDARR) ;
+1 ; DIC clone for use with "special" cross reference.
+2 ; Allows programmer to display user choices from the xref of
+3 ; their choosing.
+4 ; Useful when trying to work with sub-file entries as top-level
+5 ; "pick-list" entries and the sub-file has a "Whole File" xref
+6 ; defined.
+7 ;
+8 ; Inputs
+9 ; GBL Open global reference of the xref to use (up to xref)
+10 ; Should be a "standard B" xref type structure (ie #
+11 ; of subscripts in node doesnt change between nodes)
+12 ; xref: ^XYZ(123,"AF",1,2)="" then GBL = ^XYZ(123,"AF",
+13 ; FIND The target text to find in the xref
+14 ; OUT <byref> See Outputs below
+15 ; ACTN See Outputs below
+16 ; SCRN <opt> Data Screen
+17 ; IDARR <opt><byref>
+18 ; IDARR("NODE0") = full global reference to data zero node
+19 ; ie: IDENT("NODE0")="^XYZ(123.2,DA(1),1,DA,0)"
+20 ; IDARR("DA",n)= DA location in GBL node
+21 ; ie: IDENT("DA",0)=3 ;DA is subscr #3 in GBL var
+22 ; IDARR("W") = additional Identifier to display
+23 ; ie: IDENT("W")="W "Another Identifier"""
+24 ; IDARR("NOIDENT") : if set FM IDENTIFIER wont display
+25 ; IDARR("POINTER") : defines File# if NODE is a POINTER
+26 ; ie IDARR("POINTER")=61.2
+27 ; If VPointer specify as FM var pointer:
+28 ; ie "LAB(61.2;LAB(62.49;" etc..
+29 ; IDARR("UNIQUE") : If set only displays the matches that
+30 ; havent been displayed already.
+31 ;
+32 ; Outputs
+33 ; Returns 0 if FIND not found, 1 if FIND was found.
+34 ; If return = 0 should check ACTN for return status
+35 ;
+36 ; OUT <byref> If FIND was found OUT will contain:
+37 ; OUT = Text value of selected entry
+38 ; OUT(1) = GBL's full node of the selected entry
+39 ; ACTN "^" = abort listing, >-1 = # records displayed
+40 ; -1 = FIND was not found in xref
+41 ;
+42 NEW NODE,NODETOP,NODE0,STOP,FOUND,X,X2,I,SUBSCR
+43 NEW SHOWALL,CNT,CNTLST,CNT2,ISPTR,ISVPTR,UNIQUE
+44 NEW VAL,LASTVAL,STATUS,TMPNM,IN,DA,IDENT,DIC,DO,IOCUU,%ZIS
+45 NEW DIR,DUOUT,DIRUT
+46 SET TMPNM="LA7VLCM5-LOOKUP"
+47 KILL ^TMP(TMPNM,$JOB)
+48 SET GBL=$GET(GBL)
+49 SET SCRN=$GET(SCRN)
+50 KILL OUT,ACTN
+51 SET ACTN=0
+52 SET (FOUND,STOP,SHOWALL,CNT,CNTLST,CNT2,STATUS)=0
+53 SET NODE0=$GET(IDARR("NODE0"))
+54 SET NODE=GBL
+55 SET NODETOP=""
+56 ; setup screen control variables
+57 ;
IF FIND="??"
IF $GET(IOST(0))'=""
Begin DoDot:1
+58 ;cursor up
SET X="IOCUU"
+59 DO ENDR^%ZISS
+60 KILL %ZIS
End DoDot:1
+61 ;
IF FIND'="??"
Begin DoDot:1
+62 SET NODE=NODE_""""_FIND_""")"
+63 SET SUBSCR=$QLENGTH(NODE)
End DoDot:1
+64 ;
IF FIND="??"
Begin DoDot:1
+65 SET NODE=$$TRIM^XLFSTR(NODE,"R",",")
+66 IF $EXTRACT(NODE,1,$LENGTH(NODE))'=")"
SET NODE=NODE_")"
+67 SET SUBSCR=$QLENGTH(NODE)+1
End DoDot:1
+68 ;
+69 SET (ISPTR,ISVPTR,UNIQUE)=0
+70 ;
IF $GET(IDARR("POINTER"))'=""
Begin DoDot:1
+71 SET ISPTR=1
+72 IF IDARR("POINTER")[";"
SET ISVPTR=1
End DoDot:1
+73 IF $DATA(IDARR("UNIQUE"))
SET UNIQUE=1
+74 ;
+75 IF FIND="??"
SET SHOWALL=1
+76 SET LASTVAL=""
+77 ;
FOR
SET NODE=$QUERY(@NODE)
SET X=$TRANSLATE($EXTRACT(NODE,1,$LENGTH(GBL)),"""","")
SET X2=$TRANSLATE(GBL,"""","")
if X'[X2
QUIT
Begin DoDot:1
+78 IF CNT2=0
IF SHOWALL
WRITE !,"Choose from:"
+79 ; dont process NODE if # of subscripts doesnt match
+80 IF NODETOP=""
SET NODETOP=NODE
+81 IF NODETOP'=""
IF $QLENGTH(NODE)'=$QLENGTH(NODETOP)
QUIT
+82 ;number of nodes checked
SET CNT2=CNT2+1
+83 ;
IF $DATA(IDARR)
Begin DoDot:2
+84 ;setup DA array
+85 KILL DA
+86 SET I=""
+87 FOR
SET I=$ORDER(IDARR("DA",I))
if I=""
QUIT
SET X=IDARR("DA",I)
if I>0
SET DA(I)=$QSUBSCRIPT(NODE,X)
if I=0
SET DA=$QSUBSCRIPT(NODE,X)
+88 ; setup FileMan IDENTIFIER
+89 ;
IF '$DATA(IDENT)
IF '$DATA(IDARR("NOIDENT"))
Begin DoDot:3
+90 SET IDENT=""
+91 KILL DIC,DO
+92 SET X=$GET(IDARR("NODE0"))
+93 if X=""
QUIT
+94 SET X=$PIECE(X,",DA,",1)
+95 SET X=X_")"
+96 SET X=$NAME(@X)
+97 SET X=$$TRIM^XLFSTR(X,"R",")")
+98 SET X=$$TRIM^XLFSTR(X,"R",",")
+99 SET DIC=X_","
+100 SET DIC(0)=""
+101 DO DO^DIC1
+102 SET IDENT=$GET(DIC("W"))
End DoDot:3
+103 ;
End DoDot:2
+104 ;
+105 SET VAL=$QSUBSCRIPT(NODE,SUBSCR)
+106 ;
IF SCRN'=""
Begin DoDot:2
+107 ; set naked gbl reference
IF NODE0'=""
SET X=@NODE0
+108 XECUTE SCRN
+109 SET LASTVAL=VAL
End DoDot:2
if '$TEST
QUIT
+110 ;
+111 ; SHOWALL for "??" entry
IF 'SHOWALL
IF $EXTRACT(VAL,1,$LENGTH(FIND))'=FIND
SET LASTVAL=VAL
QUIT
+112 ;
IF 'SHOWALL
IF VAL=FIND
Begin DoDot:2
+113 ;
IF $GET(IDENT)'=""
Begin DoDot:3
+114 ; set naked gbl reference
IF NODE0'=""
SET X=@NODE0
+115 XECUTE IDENT
End DoDot:3
+116 ;
IF $GET(IDARR("W"))'=""
Begin DoDot:3
+117 ; set naked gbl reference
IF NODE0'=""
SET X=@NODE0
+118 XECUTE IDARR("W")
End DoDot:3
+119 ; If a direct match ask "...OK //Yes?"
+120 KILL DIR
+121 SET DIR(0)="YAO"
+122 SET DIR("A")=" ... OK "
+123 SET DIR("B")="Yes"
+124 DO ^DIR
+125 ;
IF Y
Begin DoDot:3
+126 SET FOUND=1
+127 SET ^TMP(TMPNM,$JOB,1,1)=VAL
+128 SET ^TMP(TMPNM,$JOB,1,2)=NODE
End DoDot:3
+129 ;
End DoDot:2
if FOUND
QUIT
+130 ;
+131 SET CNT=CNT+1
+132 SET ^TMP(TMPNM,$JOB,CNT,1)=VAL
+133 SET ^TMP(TMPNM,$JOB,CNT,2)=NODE
+134 IF 'SHOWALL
WRITE !,?5,CNT,?10,VAL
+135 ;
+136 ;
IF SHOWALL
IF 'ISPTR
Begin DoDot:2
+137 IF 'UNIQUE
WRITE !," ",VAL
QUIT
+138 IF VAL'=LASTVAL
WRITE !," ",VAL
End DoDot:2
+139 ;
+140 ;
IF SHOWALL
IF ISPTR
Begin DoDot:2
+141 NEW MSG,DIERR
+142 SET X=IDARR("POINTER")
+143 SET X=$$GET1^DIQ(X,VAL_",",.01,"","","MSG")
+144 ;
IF 'UNIQUE
Begin DoDot:3
+145 IF X'=""
WRITE !," ",X
+146 IF X=""
WRITE !," ",VAL
End DoDot:3
+147 ;
+148 ;
IF UNIQUE
Begin DoDot:3
+149 IF VAL'=LASTVAL
IF X'=""
WRITE !," ",X
+150 IF VAL'=LASTVAL
IF X=""
WRITE !," ",VAL
End DoDot:3
+151 ;
End DoDot:2
+152 ;
+153 ;
IF $GET(IDENT)'=""
Begin DoDot:2
+154 ; set naked gbl reference
IF NODE0'=""
SET X=@NODE0
+155 XECUTE IDENT
End DoDot:2
+156 ;
IF $GET(IDARR("W"))'=""
Begin DoDot:2
+157 ; set naked gbl reference
IF NODE0'=""
SET X=@NODE0
+158 XECUTE IDARR("W")
End DoDot:2
+159 SET LASTVAL=VAL
+160 ;
+161 ;
IF (SHOWALL&((CNT#($GET(IOSL,24)-2)=0)))!('SHOWALL&(CNT#5=0))
Begin DoDot:2
+162 SET CNTLST=CNT
+163 KILL DIR
+164 SET DIR(0)="FAOUr^^"
+165 SET DIR("?")=" "
+166 ;
IF 'SHOWALL
Begin DoDot:3
+167 SET DIR("?",1)="Press <RETURN> to see more, '^' to exit this list,"
End DoDot:3
+168 ;
IF SHOWALL
Begin DoDot:3
+169 SET DIR("?",1)=""
End DoDot:3
+170 ;
+171 ;
IF 'SHOWALL
Begin DoDot:3
+172 WRITE !,"Press <RETURN> to see more, '^' to exit this list"
End DoDot:3
+173 ;
+174 IF 'SHOWALL
SET DIR("A")="OR CHOOSE 1-"_CNT_": "
+175 IF SHOWALL
SET DIR("A")=" '^' TO STOP "
+176 DO ^DIR
+177 ;erase "'^' TO STOP" displayed
+178 IF SHOWALL
IF $GET(IOCUU)'=""
WRITE $CHAR(13)_$JUSTIFY("",15)_$CHAR(13)_IOCUU
+179 IF +Y=Y
IF Y>0
IF Y'>CNT
SET FOUND=Y
QUIT
+180 IF $EXTRACT(Y,1,1)="^"
SET STOP=1
+181 IF $DATA(DUOUT)
SET STOP=1
+182 IF Y'=""
if $DATA(DIRUT)
SET STOP=1
End DoDot:2
+183 ;
End DoDot:1
if STOP
QUIT
if FOUND
QUIT
+184 ;
+185 ;
IF 'SHOWALL
IF 'FOUND
IF CNT
IF CNT>CNTLST
IF 'STOP
Begin DoDot:1
+186 ; last "CHOOSE 1-X" prompt
+187 KILL DIR
+188 SET DIR(0)="FAOUr^^"
+189 SET DIR("?")=" "
+190 SET DIR("A")="CHOOSE 1-"_CNT_": "
+191 DO ^DIR
+192 IF +Y=Y
IF Y>0
IF Y'>CNT
SET FOUND=Y
QUIT
+193 IF $EXTRACT(Y,1,1)="^"
SET STOP=1
+194 if $DATA(DUOUT)
SET STOP=1
+195 IF Y'=""
if $DATA(DIRUT)
SET STOP=1
QUIT
End DoDot:1
+196 ;
+197 ;
IF FOUND
Begin DoDot:1
+198 SET OUT=^TMP(TMPNM,$JOB,FOUND,1)
+199 SET OUT(1)=^TMP(TMPNM,$JOB,FOUND,2)
+200 SET STATUS=1
+201 WRITE " ",OUT
+202 ; print selected record's IDENTIFIER
+203 ;
IF $DATA(IDARR)
Begin DoDot:2
+204 SET NODE=OUT(1)
+205 ;setup DA array
+206 KILL DA
+207 SET I=""
+208 FOR
SET I=$ORDER(IDARR("DA",I))
if I=""
QUIT
SET X=IDARR("DA",I)
if I>0
SET DA(I)=$QSUBSCRIPT(NODE,X)
if I=0
SET DA=$QSUBSCRIPT(NODE,X)
+209 ; set naked gbl reference
IF NODE0'=""
SET X=@NODE0
+210 IF IDENT'=""
IF '$DATA(IDARR("NOIDENT"))
XECUTE IDENT
+211 IF $GET(IDARR("W"))'=""
XECUTE IDARR("W")
End DoDot:2
+212 ;
End DoDot:1
+213 ;
+214 ;
IF STOP
Begin DoDot:1
+215 SET STATUS="0^1"
+216 SET ACTN="^"
End DoDot:1
+217 ;
+218 ;
IF 'FOUND
IF 'STOP
Begin DoDot:1
+219 SET STATUS=0
+220 SET ACTN=-1
End DoDot:1
+221 ;
+222 IF CNT
SET ACTN=CNT
+223 KILL ^TMP(TMPNM,$JOB)
+224 QUIT STATUS
+225 ;
