- 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 Feb 18, 2025@23:07:04 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 ;