KIDS Distribution saved on Sep 04, 2013@22:22:42
MEDITOR PWC
**KIDS**:XT*7.3*101^

**INSTALL NAME**
XT*7.3*101
"BLD",9037,0)
XT*7.3*101^TOOLKIT^0^3130904^y^^
"BLD",9037,1,0)
^^3^3^3120127^^^^
"BLD",9037,1,1,0)
XT*7.3*101
"BLD",9037,1,2,0)
 
"BLD",9037,1,3,0)
See the patch module for details.
"BLD",9037,4,0)
^9.64PA^^
"BLD",9037,6.3)
32
"BLD",9037,"KRN",0)
^9.67PA^8989.52^19
"BLD",9037,"KRN",.4,0)
.4
"BLD",9037,"KRN",.401,0)
.401
"BLD",9037,"KRN",.402,0)
.402
"BLD",9037,"KRN",.403,0)
.403
"BLD",9037,"KRN",.5,0)
.5
"BLD",9037,"KRN",.84,0)
.84
"BLD",9037,"KRN",3.6,0)
3.6
"BLD",9037,"KRN",3.8,0)
3.8
"BLD",9037,"KRN",9.2,0)
9.2
"BLD",9037,"KRN",9.8,0)
9.8
"BLD",9037,"KRN",9.8,"NM",0)
^9.68A^5^5
"BLD",9037,"KRN",9.8,"NM",1,0)
XTECLIPS^^0^B3789827
"BLD",9037,"KRN",9.8,"NM",2,0)
XTECGLO^^0^B221715057
"BLD",9037,"KRN",9.8,"NM",3,0)
XTECROU^^0^B51806057
"BLD",9037,"KRN",9.8,"NM",4,0)
XTMRPAR1^^0^B62027368
"BLD",9037,"KRN",9.8,"NM",5,0)
XTMRPAR2^^0^B36584102
"BLD",9037,"KRN",9.8,"NM","B","XTECGLO",2)

"BLD",9037,"KRN",9.8,"NM","B","XTECLIPS",1)

"BLD",9037,"KRN",9.8,"NM","B","XTECROU",3)

"BLD",9037,"KRN",9.8,"NM","B","XTMRPAR1",4)

"BLD",9037,"KRN",9.8,"NM","B","XTMRPAR2",5)

"BLD",9037,"KRN",19,0)
19
"BLD",9037,"KRN",19.1,0)
19.1
"BLD",9037,"KRN",101,0)
101
"BLD",9037,"KRN",409.61,0)
409.61
"BLD",9037,"KRN",771,0)
771
"BLD",9037,"KRN",870,0)
870
"BLD",9037,"KRN",8989.51,0)
8989.51
"BLD",9037,"KRN",8989.52,0)
8989.52
"BLD",9037,"KRN",8994,0)
8994
"BLD",9037,"KRN",8994,"NM",0)
^9.68A^1^1
"BLD",9037,"KRN",8994,"NM",1,0)
XT ECLIPSE M EDITOR^^0
"BLD",9037,"KRN",8994,"NM","B","XT ECLIPSE M EDITOR",1)

"BLD",9037,"KRN","B",.4,.4)

"BLD",9037,"KRN","B",.401,.401)

"BLD",9037,"KRN","B",.402,.402)

"BLD",9037,"KRN","B",.403,.403)

"BLD",9037,"KRN","B",.5,.5)

"BLD",9037,"KRN","B",.84,.84)

"BLD",9037,"KRN","B",3.6,3.6)

"BLD",9037,"KRN","B",3.8,3.8)

"BLD",9037,"KRN","B",9.2,9.2)

"BLD",9037,"KRN","B",9.8,9.8)

"BLD",9037,"KRN","B",19,19)

"BLD",9037,"KRN","B",19.1,19.1)

"BLD",9037,"KRN","B",101,101)

"BLD",9037,"KRN","B",409.61,409.61)

"BLD",9037,"KRN","B",771,771)

"BLD",9037,"KRN","B",870,870)

"BLD",9037,"KRN","B",8989.51,8989.51)

"BLD",9037,"KRN","B",8989.52,8989.52)

"BLD",9037,"KRN","B",8994,8994)

"BLD",9037,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",9037,"QUES",0)
^9.62^^
"BLD",9037,"REQB",0)
^9.611^^
"KRN",8994,3032,-1)
0^1
"KRN",8994,3032,0)
XT ECLIPSE M EDITOR^RPC^XTECLIPS^4^^^^1
"MBREQ")
0
"ORD",16,8994)
8994;16;1;;;;;;;RPCDEL^XPDIA1
"ORD",16,8994,0)
REMOTE PROCEDURE
"PKG",5,-1)
1^1
"PKG",5,0)
TOOLKIT^XT^PROGRAMMERS OPTIONS, MULTI. TERM LOOKUP
"PKG",5,22,0)
^9.49I^1^1
"PKG",5,22,1,0)
7.3^3051119^2960604
"PKG",5,22,1,"PAH",1,0)
101^3130904^1
"PKG",5,22,1,"PAH",1,1,0)
^^3^3^3130904
"PKG",5,22,1,"PAH",1,1,1,0)
XT*7.3*101
"PKG",5,22,1,"PAH",1,1,2,0)
 
"PKG",5,22,1,"PAH",1,1,3,0)
See the patch module for details.
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
5
"RTN","XTECGLO")
0^2^B221715057
"RTN","XTECGLO",1,0)
XTECGLO ;FO-OAK/JLI - Global Utilities for Eclipse ;08/10/12  06:20
"RTN","XTECGLO",2,0)
 ;;7.3;TOOLKIT;**101**;Apr 25, 1995;Build 32
"RTN","XTECGLO",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified
"RTN","XTECGLO",4,0)
 I $T(EN^XTMUNIT)'="" D EN^XTMUNIT("ZZUTXTE1")
"RTN","XTECGLO",5,0)
 Q
"RTN","XTECGLO",6,0)
 ;
"RTN","XTECGLO",7,0)
LIST(TMPGLOB,LINES,FROM,TO) ;This will list all the globals for a UCI/Namespace
"RTN","XTECGLO",8,0)
 ; TMPGLOB = The closed global reference that will contain the globals
"RTN","XTECGLO",9,0)
 ; LINES = The max number of lines to send.
"RTN","XTECGLO",10,0)
 ; FROM = The Starting range
"RTN","XTECGLO",11,0)
 ; TO = The ending range
"RTN","XTECGLO",12,0)
 N GLOBAL,CNT,FST,FLG
"RTN","XTECGLO",13,0)
 S @TMPGLOB@(0)="-1^"
"RTN","XTECGLO",14,0)
 S:LINES'>0 LINES=1000
"RTN","XTECGLO",15,0)
 I ^%ZOSF("OS")'["GT.M" D NONGTM(.TMPGLOB,FROM,TO)
"RTN","XTECGLO",16,0)
 I ^%ZOSF("OS")["GT.M" D GTM(.TMPGLOB,FROM)
"RTN","XTECGLO",17,0)
 Q
"RTN","XTECGLO",18,0)
 ;
"RTN","XTECGLO",19,0)
NONGTM(TMPGLOB,FROM,TO) ;
"RTN","XTECGLO",20,0)
 N CNT,FLG,FST,GLOBAL
"RTN","XTECGLO",21,0)
 ; if user entered name* remove *
"RTN","XTECGLO",22,0)
 S:TO["*" TO=$P(TO,"*") S:FROM["*" FROM=$P(FROM,"*")
"RTN","XTECGLO",23,0)
 S:$E(FROM)="^" FROM=$E(FROM,2,$L(FROM))
"RTN","XTECGLO",24,0)
 S:$E(TO)="^" TO=$E(TO,2,$L(TO))
"RTN","XTECGLO",25,0)
 ;
"RTN","XTECGLO",26,0)
 S FROM="^"_FROM
"RTN","XTECGLO",27,0)
 S:TO]"" TO="^"_TO
"RTN","XTECGLO",28,0)
 S CNT=0,FST=""
"RTN","XTECGLO",29,0)
 S GLOBAL=$O(^$GLOBAL(FROM),-1)
"RTN","XTECGLO",30,0)
 F  S GLOBAL=$O(^$GLOBAL(GLOBAL)) Q:GLOBAL=""  Q:TO]""&(GLOBAL]TO)  Q:$E(GLOBAL,1,$L(FROM))'=FROM  D  Q:CNT=LINES
"RTN","XTECGLO",31,0)
 . S CNT=CNT+1
"RTN","XTECGLO",32,0)
 . I FST="" S FST=GLOBAL
"RTN","XTECGLO",33,0)
 . S @TMPGLOB@(CNT)=GLOBAL
"RTN","XTECGLO",34,0)
 . Q
"RTN","XTECGLO",35,0)
 I CNT>0 S @TMPGLOB@(0)=CNT_FST_@TMPGLOB@(CNT)
"RTN","XTECGLO",36,0)
 Q
"RTN","XTECGLO",37,0)
 ;
"RTN","XTECGLO",38,0)
GTM(TMPGLOB,FROM) ;
"RTN","XTECGLO",39,0)
 N XTMCNT1,XTMCNT,GLOBAL,%ZG,XTMGLOB
"RTN","XTECGLO",40,0)
 S GLOBAL=FROM
"RTN","XTECGLO",41,0)
 S %ZG=FROM S:%ZG'["*" %ZG=%ZG_"*" D CALL^%GSEL
"RTN","XTECGLO",42,0)
 S XTMGLOB="",XTMCNT=0 F  S XTMGLOB=$O(%ZG(XTMGLOB)) Q:XTMGLOB=""  S:XTMCNT=0 GLOBAL=XTMGLOB S XTMCNT=XTMCNT+1,@TMPGLOB@(XTMCNT)=XTMGLOB
"RTN","XTECGLO",43,0)
 I XTMCNT>0 S @TMPGLOB@(0)=XTMCNT_GLOBAL_@TMPGLOB@(XTMCNT)
"RTN","XTECGLO",44,0)
 Q
"RTN","XTECGLO",45,0)
 ;
"RTN","XTECGLO",46,0)
 ; JLI 101027 Previously, the List Global Nodes functionality
"RTN","XTECGLO",47,0)
 ; scanned and entered in a global location in ^TMP all of the
"RTN","XTECGLO",48,0)
 ; nodes that matched the request.  The first 10000 nodes of
"RTN","XTECGLO",49,0)
 ; data would be sent down, and on subsequent requests the
"RTN","XTECGLO",50,0)
 ; rest would be returned in 10000 node chunks until all of it
"RTN","XTECGLO",51,0)
 ; was returned.
"RTN","XTECGLO",52,0)
 ; Changes were added to handle only those global nodes
"RTN","XTECGLO",53,0)
 ; to be returned at the current time.  This prevents the user
"RTN","XTECGLO",54,0)
 ; from selecting a global such as ^TMP which would fill up all
"RTN","XTECGLO",55,0)
 ; available space (and if ^TMP was chosen, this would be even
"RTN","XTECGLO",56,0)
 ; worse since the nodes being recorded would add to the amount
"RTN","XTECGLO",57,0)
 ; to be stored again and again).
"RTN","XTECGLO",58,0)
LNODE(TMPGLOB,LINES,GLOBAL,SERCHVAL,OPTS) ;This will list a global
"RTN","XTECGLO",59,0)
 ; TMPGLOB input - specifies root in which data will be returned
"RTN","XTECGLO",60,0)
 ; LINES input - maximum number of global nodes to be returned
"RTN","XTECGLO",61,0)
 ; GLOBAL input - text of global node to be listed
"RTN","XTECGLO",62,0)
 ; SERCHVAL input - optional - specification of search data
"RTN","XTECGLO",63,0)
 ;   FORMAT  NEWSTYLE^DATA_ONLY^CASE_SENSITIVE^VALUE_FOR_SEARCH
"RTN","XTECGLO",64,0)
 ; OPTS input - optional - contains the last count from a previous call if this
"RTN","XTECGLO",65,0)
 ;      is a continuation
"RTN","XTECGLO",66,0)
 N GLOBTOT,CNT,CNTVAL,INDX,SEPRATR,MORE,DATAONLY,CASESENS,NEWSTYLE
"RTN","XTECGLO",67,0)
 N GLOBLAST,NEWVERSN
"RTN","XTECGLO",68,0)
 D INFO^XTMLOG("ENTERED LNODE","LINES,GLOBAL,SERCHVAL,OPTS")
"RTN","XTECGLO",69,0)
 S GLOBTOT=$NA(^TMP("XTECGLO_LNODE",$J))
"RTN","XTECGLO",70,0)
 S GLOBLAST=$NA(^TMP("XTECGLO_LAST",$J))
"RTN","XTECGLO",71,0)
 I (GLOBAL="")!(GLOBAL="^") D  Q
"RTN","XTECGLO",72,0)
 . K @TMPGLOB S @TMPGLOB@(0)="-1^NO GLOBAL NAME PASSED"
"RTN","XTECGLO",73,0)
 . K @GLOBTOT,@GLOBLAST
"RTN","XTECGLO",74,0)
 . Q
"RTN","XTECGLO",75,0)
 S SEPRATR="~^~"
"RTN","XTECGLO",76,0)
 S:LINES'>0 LINES=10000 ; Actually return twice as many lines to give LINES nodes worth
"RTN","XTECGLO",77,0)
 ; new version client sends OPTS as 0^1, old client sent number of next line to start with if returning for more data
"RTN","XTECGLO",78,0)
 S OPTS=$G(OPTS),NEWVERSN=+$P(OPTS,U,2) ; indicates client side is aware of new version handling
"RTN","XTECGLO",79,0)
 S CNT=+OPTS
"RTN","XTECGLO",80,0)
 D INFO^XTMLOG("LNODE 1","LINES,OPTS,CNT")
"RTN","XTECGLO",81,0)
 S SERCHVAL=$G(SERCHVAL) S NEWSTYLE=$P(SERCHVAL,"^"),DATAONLY=$P(SERCHVAL,"^",2),CASESENS=$P(SERCHVAL,"^",3),SERCHVAL=$P(SERCHVAL,"^",4,99) I 'CASESENS S SERCHVAL=$$UP^XLFSTR(SERCHVAL)
"RTN","XTECGLO",82,0)
 I 'NEWVERSN,OPTS'>0 K @GLOBTOT S CNT=$$GETDATA(GLOBTOT,GLOBAL,SERCHVAL,DATAONLY,CASESENS,SEPRATR,NEWSTYLE) D INFO^XTMLOG("BACK FROM GETDATA","CNT")
"RTN","XTECGLO",83,0)
 I NEWVERSN K @GLOBTOT S CNT=$$GETDATA(GLOBTOT,GLOBAL,SERCHVAL,DATAONLY,CASESENS,SEPRATR,NEWSTYLE,LINES,NEWVERSN) D INFO^XTMLOG("BACK FROM GETDATA","CNT")
"RTN","XTECGLO",84,0)
 D DEBUG^XTMLOG("LNODE 2","OPTS,GLOBTOT,GLOBAL,SERCHVAL,DATAONLY,CASESENS,SEPRATR,NEWSTYLE")
"RTN","XTECGLO",85,0)
 I 'NEWVERSN,OPTS>0 S CNT=$P(@GLOBTOT@(0),SEPRATR,1,3) D INFO^XTMLOG("NO GETDATA","CNT")
"RTN","XTECGLO",86,0)
 ; EACH GLOBAL NODE IS TWO ENTRIES, FIRST THE GLOBAL NODE STRING IN THE FIRST NODE, AND THEN THE VALUE OF THE GLOBAL IN THE SECOND NODE
"RTN","XTECGLO",87,0)
 ; OPTS HAS NUMBER OF GLOBAL VALUES RETURNED ON PREVIOUS CALL, SO START AT NEXT ONE
"RTN","XTECGLO",88,0)
 S CNTVAL=2*OPTS
"RTN","XTECGLO",89,0)
 I CNT>0 D
"RTN","XTECGLO",90,0)
 . I 'NEWVERSN F INDX=((2*OPTS)+1):1:(2*(LINES+OPTS)) Q:'$D(@GLOBTOT@(INDX))  S @TMPGLOB@(INDX)=@GLOBTOT@(INDX),CNTVAL=CNTVAL+1
"RTN","XTECGLO",91,0)
 . I NEWVERSN F INDX=1:1 Q:'$D(@GLOBTOT@(INDX))  S @TMPGLOB@(INDX)=@GLOBTOT@(INDX),CNTVAL=CNTVAL+1
"RTN","XTECGLO",92,0)
 . Q
"RTN","XTECGLO",93,0)
 D INFO^XTMLOG("AFTER LOOP","INDX,CNTVAL")
"RTN","XTECGLO",94,0)
 ; INDICATOR FOR WHETHER MORE DATA IS AVAILABLE
"RTN","XTECGLO",95,0)
 S MORE=$S(NEWVERSN:$D(@GLOBLAST@("GLOBAL")),1:(+CNT>(CNTVAL/2)))
"RTN","XTECGLO",96,0)
 S @TMPGLOB@(0)="-1"
"RTN","XTECGLO",97,0)
 I CNT>0 S @GLOBTOT@(0)=CNT_SEPRATR_(CNTVAL/2)_SEPRATR_MORE,@TMPGLOB@(0)=@GLOBTOT@(0)
"RTN","XTECGLO",98,0)
 D INFO^XTMLOG("LNODE - ON EXIT",$NA(@GLOBTOT@(0)))
"RTN","XTECGLO",99,0)
 I NEWVERSN K @GLOBTOT
"RTN","XTECGLO",100,0)
 I 'MORE!'NEWVERSN K @GLOBLAST
"RTN","XTECGLO",101,0)
 Q
"RTN","XTECGLO",102,0)
 ;
"RTN","XTECGLO",103,0)
GETDATA(GLOBTOT,GLOBAL,SERCHVAL,DATAONLY,CASESENS,SEPRATR,NEWSTYLE,LINES,NEWVERSN) ; extracted to here from LNODE
"RTN","XTECGLO",104,0)
 ; LINES input - maximum number of global lines to return
"RTN","XTECGLO",105,0)
 ; ZEXCEPT: GLOBLAST ; NEWED and defined in LNODE
"RTN","XTECGLO",106,0)
 N CNT,FST,LST,GLOFIN1,GLOFINAL,GLOSTART,GLOSTR,NCOMMA,DONE,I,J
"RTN","XTECGLO",107,0)
 N ARRAY,PARTS,LAST,GLOBAL1,LAST1,LAST2,GLOBALA
"RTN","XTECGLO",108,0)
 S LINES=$G(LINES),NEWVERSN=$G(NEWVERSN)
"RTN","XTECGLO",109,0)
 S:$E(GLOBAL,1)'="^" GLOBAL="^"_GLOBAL S:$E(GLOBAL,$L(GLOBAL))="(" GLOBAL=$E(GLOBAL,1,$L(GLOBAL)-1)
"RTN","XTECGLO",110,0)
 N START,FINAL,NCOMMAS,VAL1,MAXCOMMA
"RTN","XTECGLO",111,0)
 S GLOSTART=$$GETLIMIT(GLOBAL,.MAXCOMMA,.ARRAY),GLOFINAL=GLOSTART
"RTN","XTECGLO",112,0)
 D DEBUG^XTMLOG("GETLIMIT ARRAY:","ARRAY",1)
"RTN","XTECGLO",113,0)
 S DONE=0 F I=1:1 Q:DONE  Q:'$D(ARRAY(I))  Q:ARRAY(I,1)=""  D
"RTN","XTECGLO",114,0)
 . S GLOSTART=GLOSTART_$S(I>1:",",1:"")_ARRAY(I,1)
"RTN","XTECGLO",115,0)
 . S J=$O(ARRAY(I,""),-1) S GLOFINAL=GLOFINAL_$S(I>1:",",1:"")_$S($D(ARRAY(I,J,1)):ARRAY(I,J,1),1:ARRAY(I,J))
"RTN","XTECGLO",116,0)
 . I (J'=1)!$D(ARRAY(I,1,1)) S DONE=1
"RTN","XTECGLO",117,0)
 . D DEBUG^XTMLOG("GLOSTART","I,J,GLOSTART,GLOFINAL,DONE")
"RTN","XTECGLO",118,0)
 . Q
"RTN","XTECGLO",119,0)
 I GLOSTART["(" S GLOSTART=GLOSTART_")" I GLOSTART["()" S GLOSTART=$P(GLOSTART,"(")
"RTN","XTECGLO",120,0)
 S (FST,LAST)=""
"RTN","XTECGLO",121,0)
 S CNT=0
"RTN","XTECGLO",122,0)
 D DEBUG^XTMLOG("$D(@GLOSTART)","GLOSTART,GLOFINAL")
"RTN","XTECGLO",123,0)
 S GLOBAL=GLOSTART
"RTN","XTECGLO",124,0)
 I '$D(@GLOBLAST),$D(@GLOSTART)#2,$$CHEKGLOB(GLOBAL,MAXCOMMA,.ARRAY) D STORE(GLOSTART,GLOBTOT,.CNT,.FST,SERCHVAL,DATAONLY,CASESENS,NEWSTYLE) S GLOSTR=GLOBAL I GLOBAL["(" S NCOMMA=$L(GLOBAL,","),GLOSTR=$Q(@GLOBAL),GLOSTR=$P(GLOSTR,",",1,NCOMMA)
"RTN","XTECGLO",125,0)
 S LAST1="",LAST2=""
"RTN","XTECGLO",126,0)
 I NEWVERSN,$D(@GLOBLAST@("GLOBAL")) S GLOBAL=@GLOBLAST@("GLOBAL") ; on restart use last global value from previous
"RTN","XTECGLO",127,0)
 F  Q:(NEWVERSN&((CNT/2)=LINES))  S GLOBAL=$Q(@GLOBAL) Q:GLOBAL=""  Q:$$CHEKTERM(GLOSTART,GLOBAL,MAXCOMMA,.ARRAY)  D DEBUG^XTMLOG("LOOP2","GLOBAL") D  Q:(LAST2'="")&(LAST2=LAST1)  Q:$G(GLOBAL)=""
"RTN","XTECGLO",128,0)
 . S GLOBAL=$$CHKRANGE(GLOBAL,MAXCOMMA,.ARRAY) I $$CHEKGLOB(GLOBAL,MAXCOMMA,.ARRAY) D DEBUG^XTMLOG("LOOP3","GLOBAL") D STORE(GLOBAL,GLOBTOT,.CNT,.FST,SERCHVAL,DATAONLY,CASESENS,NEWSTYLE)
"RTN","XTECGLO",129,0)
 . Q
"RTN","XTECGLO",130,0)
 K @GLOBLAST
"RTN","XTECGLO",131,0)
 I CNT>0 S LAST=@GLOBTOT@(CNT-1) I (CNT/2)=LINES S GLOBALA=$Q(@GLOBAL),GLOBALA=$$CHKRANGE(GLOBALA,MAXCOMMA,.ARRAY) I $$CHEKGLOB(GLOBALA,MAXCOMMA,.ARRAY) S @GLOBLAST@("GLOBAL")=GLOBAL
"RTN","XTECGLO",132,0)
 Q (CNT/2)_SEPRATR_FST_SEPRATR_LAST
"RTN","XTECGLO",133,0)
 ;
"RTN","XTECGLO",134,0)
STORE(GLOBAL,TMPGLOB,CNT,FST,SERCHVAL,DATAONLY,CASESENS,NEWSTYLE) ;
"RTN","XTECGLO",135,0)
 N GLOBX,GLOBV
"RTN","XTECGLO",136,0)
 I '($D(@GLOBAL)#2) Q
"RTN","XTECGLO",137,0)
 D INFO^XTMLOG("ENTRY:","GLOBAL,TMPGLOB,CNT,FST,SERCHVAL,DATAONLY,CASESENS")
"RTN","XTECGLO",138,0)
 I $G(SERCHVAL)'="" D   I '((GLOBV[SERCHVAL)!('DATAONLY&(GLOBX[SERCHVAL))) Q
"RTN","XTECGLO",139,0)
 . S GLOBX=GLOBAL,GLOBV=@GLOBAL
"RTN","XTECGLO",140,0)
 . I 'CASESENS S GLOBX=$$UP^XLFSTR(GLOBX),GLOBV=$$UP^XLFSTR(GLOBV)
"RTN","XTECGLO",141,0)
 . Q
"RTN","XTECGLO",142,0)
 S CNT=CNT+1
"RTN","XTECGLO",143,0)
 I FST="" S FST=GLOBAL
"RTN","XTECGLO",144,0)
 S @TMPGLOB@(CNT)=GLOBAL
"RTN","XTECGLO",145,0)
 S CNT=CNT+1,@TMPGLOB@(CNT)=$S(NEWSTYLE:"JUNK",1:"")_@GLOBAL
"RTN","XTECGLO",146,0)
 Q
"RTN","XTECGLO",147,0)
 ;
"RTN","XTECGLO",148,0)
SETNAMES(FROM,TO) ; check validity of globals (OR ROUTINES) specified and return names for searching
"RTN","XTECGLO",149,0)
 N FLG S FLG=0
"RTN","XTECGLO",150,0)
 I FROM'="",FROM'?1(1"%",1A).AN S FLG="-1^INVALID 'FROM' NAME"
"RTN","XTECGLO",151,0)
 I TO'="",TO'?1A.AN S FLG="-1^"_$S(FLG=0:"INVALID 'TO' NAME",1:"INVALID 'FROM' AND 'TO' NAMES")
"RTN","XTECGLO",152,0)
 I TO'="",FLG=0,FROM]TO S FLG="-1^INVALID RANGE"
"RTN","XTECGLO",153,0)
 I FLG=0 D
"RTN","XTECGLO",154,0)
 . I TO="" S TO=FROM
"RTN","XTECGLO",155,0)
 . ; 120810 JLI following modified to handle longer names as suggested by Lloyd Milligan
"RTN","XTECGLO",156,0)
 . S FROM=$E(FROM,1,$L(FROM)-1)_$C($A($E(FROM,$L(FROM)))-1)_"~"
"RTN","XTECGLO",157,0)
 . S TO=TO_"~"
"RTN","XTECGLO",158,0)
 . Q
"RTN","XTECGLO",159,0)
 Q FLG
"RTN","XTECGLO",160,0)
 ;
"RTN","XTECGLO",161,0)
PARSGLOB(GLOBAL,PARTS) ; PARTS PASSED BY REFERENCE - RETURNS MAXCOMMA
"RTN","XTECGLO",162,0)
 ; GLOBAL - STRING CONTAINING GLOBAL REFERENCE TO BE PARSED
"RTN","XTECGLO",163,0)
 ; PARTS  - PASSED BY REFERENCE - CONTAINS PARSED DATA
"RTN","XTECGLO",164,0)
 ;          NODE 0 - GLOBAL NAME
"RTN","XTECGLO",165,0)
 ;          NODE 1.. - COMMA PIECE NUMBER
"RTN","XTECGLO",166,0)
 ;          NODE 1,1 - VALUE^TERMINATOR  (E.G., ,^TEXT or :^TEXT2)
"RTN","XTECGLO",167,0)
 ;          NODE 1,2 - VALUE^TERMINATOR
"RTN","XTECGLO",168,0)
 ;          NODE 2...
"RTN","XTECGLO",169,0)
 ;     FOR GLOBAL "^TMP($J,""A"",1,""B"":""C"""
"RTN","XTECGLO",170,0)
 ;        would return
"RTN","XTECGLO",171,0)
 ;          PARTS
"RTN","XTECGLO",172,0)
 ;
"RTN","XTECGLO",173,0)
 ;
"RTN","XTECGLO",174,0)
 N COMMAS,LAST,TERM,TOKEN,NUM1,MAXCOMMA,GLOBAL1
"RTN","XTECGLO",175,0)
 S COMMAS=0,LAST="",NUM1=0,MAXCOMMA=0
"RTN","XTECGLO",176,0)
 K PARTS
"RTN","XTECGLO",177,0)
 S GLOBAL1=GLOBAL
"RTN","XTECGLO",178,0)
 FOR  QUIT:GLOBAL=""  S GLOBAL=$$NEXTTOKN^XTMRPAR2(GLOBAL,.TOKEN,.TERM," ,:()!") D
"RTN","XTECGLO",179,0)
 . I TERM="(" S PARTS(COMMAS,1)=TOKEN_TERM,COMMAS=1,NUM1=0 Q
"RTN","XTECGLO",180,0)
 . I TERM="" S TERM=","
"RTN","XTECGLO",181,0)
 . I TERM=")" S MAXCOMMA=COMMAS,TERM=","
"RTN","XTECGLO",182,0)
 . I LAST="" S NUM1=NUM1+1,PARTS(COMMAS,NUM1)=TOKEN
"RTN","XTECGLO",183,0)
 . I LAST=":" S PARTS(COMMAS,NUM1,1)=TOKEN
"RTN","XTECGLO",184,0)
 . I (LAST="!")!(LAST=" ") S NUM1=NUM1+1,PARTS(COMMAS,NUM1)=TOKEN
"RTN","XTECGLO",185,0)
 . I TERM="," S COMMAS=COMMAS+1,NUM1=0
"RTN","XTECGLO",186,0)
 . S LAST=$S(((TERM=":")!(TERM="!")!(TERM=" ")):TERM,1:"")
"RTN","XTECGLO",187,0)
 D DEBUG^XTMLOG("GLOBAL1","GLOBAL1,PARTS",1)
"RTN","XTECGLO",188,0)
 Q MAXCOMMA
"RTN","XTECGLO",189,0)
 ;
"RTN","XTECGLO",190,0)
CHEKGLOB(GLOBAL,MAXCOMMA,NODES) ; RETURNS 1 IF VALID, OTHERWISE 0
"RTN","XTECGLO",191,0)
 ; GLOBAL   - THE FULL GLOBAL REFERENCE
"RTN","XTECGLO",192,0)
 ; MAXCOMMA - number of comma-pieces required, or zero if no limit
"RTN","XTECGLO",193,0)
 ;            e.g., ^DD(8992,,0) would require 3 comma pieces
"RTN","XTECGLO",194,0)
 ; START    - START array - passed by reference
"RTN","XTECGLO",195,0)
 ; FINAL    - FINAL array - passed by reference
"RTN","XTECGLO",196,0)
 ;
"RTN","XTECGLO",197,0)
 ; GET GLOBAL NODE STRING
"RTN","XTECGLO",198,0)
 N COMMAS,DONE,FINAL,J,NCOMMA,TERM,TOKEN,VALID
"RTN","XTECGLO",199,0)
 S GLOBAL=$P(GLOBAL,"(",2,99)
"RTN","XTECGLO",200,0)
 S GLOBAL=$E(GLOBAL,1,$L(GLOBAL)-1)
"RTN","XTECGLO",201,0)
 D DEBUG^XTMLOG("CHEKGLOB","GLOBAL,MAXCOMMA")
"RTN","XTECGLO",202,0)
 ;
"RTN","XTECGLO",203,0)
 N XARRAY
"RTN","XTECGLO",204,0)
 S DONE=0,VALID=1
"RTN","XTECGLO",205,0)
 S COMMAS=0 F  Q:GLOBAL=""  S COMMAS=COMMAS+1,GLOBAL=$$NEXTTOKN^XTMRPAR2(GLOBAL,.TOKEN,.TERM,",") S XARRAY(COMMAS)=TOKEN I MAXCOMMA>0,COMMAS>MAXCOMMA K XARRAY S DONE=1,VALID=0 Q
"RTN","XTECGLO",206,0)
 I MAXCOMMA>0,COMMAS<MAXCOMMA S DONE=1,VALID=0 K XARRAY
"RTN","XTECGLO",207,0)
 D DEBUG^XTMLOG("CHEKGLOB1","VALID,NODES,XARRAY",1)
"RTN","XTECGLO",208,0)
 ; if missing a defined node, it is invalid
"RTN","XTECGLO",209,0)
 S NCOMMA=0 F  S NCOMMA=$O(NODES(NCOMMA)) Q:NCOMMA'>0  I '$D(XARRAY(NCOMMA)) S VALID=0,DONE=1
"RTN","XTECGLO",210,0)
 ;
"RTN","XTECGLO",211,0)
 I $D(XARRAY) S VALID=1 F NCOMMA=1:1:COMMAS Q:'VALID  I $D(NODES(NCOMMA)) S VALID=0,DONE=1 F J=1:1 Q:'$D(NODES(NCOMMA,J))  D  Q:VALID
"RTN","XTECGLO",212,0)
 . I NODES(NCOMMA,J)="" S VALID=1 Q
"RTN","XTECGLO",213,0)
 . S FINAL=NODES(NCOMMA,J) I $D(NODES(NCOMMA,J,1)) S FINAL=NODES(NCOMMA,J,1)
"RTN","XTECGLO",214,0)
 . D DEBUG^XTMLOG("CHEKGLOB A","NCOMMA,J,XARRAY(NCOMMA),NODES(NCOMMA,J),NODES(NCOMMA,J,1)")
"RTN","XTECGLO",215,0)
 . I $$FOLLOWS(NODES(NCOMMA,J),XARRAY(NCOMMA)) Q
"RTN","XTECGLO",216,0)
 . I $$FOLLOWS(XARRAY(NCOMMA),FINAL) Q
"RTN","XTECGLO",217,0)
 . S VALID=1
"RTN","XTECGLO",218,0)
 . D DEBUG^XTMLOG("EXITING CHEKGLOB","VALID")
"RTN","XTECGLO",219,0)
 . Q
"RTN","XTECGLO",220,0)
 D DEBUG^XTMLOG("EXIT CHEKGLOB","VALID")
"RTN","XTECGLO",221,0)
 Q VALID
"RTN","XTECGLO",222,0)
 ;
"RTN","XTECGLO",223,0)
 ; GETLIMIT - returns as its value the leading part of the input global
"RTN","XTECGLO",224,0)
 ;               specification which is fixed.
"RTN","XTECGLO",225,0)
 ;            It returns the maximum number of comma pieces for the global
"RTN","XTECGLO",226,0)
 ;               in an argument passed by reference (MAXCOMMA) or a value
"RTN","XTECGLO",227,0)
 ;               of zero if there is no limit on comma pieces in the global
"RTN","XTECGLO",228,0)
 ;               (maximum comma pieces are indicated when the global
"RTN","XTECGLO",229,0)
 ;               specification is terminated by a closing parenthesis).
"RTN","XTECGLO",230,0)
 ;            It also returns data in an array argument passed
"RTN","XTECGLO",231,0)
 ;               by reference (OUTARRAY) which on return contains
"RTN","XTECGLO",232,0)
 ;               information on those nodes which follow the fixed part
"RTN","XTECGLO",233,0)
 ;               the global specification.
"RTN","XTECGLO",234,0)
 ;
"RTN","XTECGLO",235,0)
GETLIMIT(GLOBAL,MAXCOMMA,PARTS) ;
"RTN","XTECGLO",236,0)
 ; GLOBAL    - INPUT  - the global specification input by the user
"RTN","XTECGLO",237,0)
 ; MAXCOMMA  - OUTPUT - PASSED BY REFERENCE - the maximum number of commas, if paren terminated
"RTN","XTECGLO",238,0)
 ; PARTS     - OUTPUT - PASSED BY REFERENCE - an array containing
"RTN","XTECGLO",239,0)
 ;             information on the nodes following the fixed part of the
"RTN","XTECGLO",240,0)
 ;             global specification.
"RTN","XTECGLO",241,0)
 N BASE,DONE,I,J,TEST1,TEST2,X
"RTN","XTECGLO",242,0)
 S MAXCOMMA=$$PARSGLOB(GLOBAL,.PARTS)
"RTN","XTECGLO",243,0)
 D DEBUG^XTMLOG("IN GETLIMIT","PARTS",1)
"RTN","XTECGLO",244,0)
 S I=0 F  S I=$O(PARTS(I)) Q:I'>0  F J=1:1 Q:'$D(PARTS(I,J))  I $G(PARTS(I,J))'="" D
"RTN","XTECGLO",245,0)
 . D DEBUG^XTMLOG("IN LOOP","I,J,PARTS(I,J),PARTS(I,J,1)")
"RTN","XTECGLO",246,0)
 . S TEST1="^TMP("_PARTS(I,J)_")"
"RTN","XTECGLO",247,0)
 . S TEST1=$NA(@TEST1)
"RTN","XTECGLO",248,0)
 . S TEST1=$P(TEST1,"^TMP(",2)
"RTN","XTECGLO",249,0)
 . S PARTS(I,J)=$E(TEST1,1,$L(TEST1)-1)
"RTN","XTECGLO",250,0)
 . S TEST2=TEST1
"RTN","XTECGLO",251,0)
 . S TEST1=I_"  "_J
"RTN","XTECGLO",252,0)
 . I $D(PARTS(I,J,1)) D
"RTN","XTECGLO",253,0)
 . . S TEST2="^TMP("_PARTS(I,J,1)_")"
"RTN","XTECGLO",254,0)
 . . S TEST2=$NA(@TEST2)
"RTN","XTECGLO",255,0)
 . . S TEST2=$P(TEST2,"^TMP(",2)
"RTN","XTECGLO",256,0)
 . . S TEST2(1)=I_"  "_J
"RTN","XTECGLO",257,0)
 . . S PARTS(I,J,1)=$E(TEST2,1,$L(TEST2)-1)
"RTN","XTECGLO",258,0)
 . . Q
"RTN","XTECGLO",259,0)
 . D DEBUG^XTMLOG("","TEST1,TEST2,PARTS",1)
"RTN","XTECGLO",260,0)
 . Q
"RTN","XTECGLO",261,0)
 D DEBUG^XTMLOG("AFTER LOOP","PARTS",1)
"RTN","XTECGLO",262,0)
 Q PARTS(0,1)
"RTN","XTECGLO",263,0)
 ;
"RTN","XTECGLO",264,0)
 N BASE,DONE,I,J,TEST1,TEST2,X,PARTS
"RTN","XTECGLO",265,0)
 S MAXCOMMA=$$PARSGLOB(GLOBAL,.PARTS)
"RTN","XTECGLO",266,0)
 D DEBUG^XTMLOG("IN GETLIMIT","PARTS",1)
"RTN","XTECGLO",267,0)
 K OUTARRAY
"RTN","XTECGLO",268,0)
 S I=0 F  S I=$O(PARTS(I)) Q:I'>0  F J=1:1 Q:'$D(PARTS(I,J))  I $G(PARTS(I,J))'="" D
"RTN","XTECGLO",269,0)
 . D DEBUG^XTMLOG("IN LOOP","I,J,PARTS(I,J),PARTS(I,J,1)")
"RTN","XTECGLO",270,0)
 . S TEST1="^TMP("_PARTS(I,J)_")"
"RTN","XTECGLO",271,0)
 . S TEST1=$NA(@TEST1)
"RTN","XTECGLO",272,0)
 . S TEST1=$P(TEST1,"^TMP(",2)
"RTN","XTECGLO",273,0)
 . S OUTARRAY(I,J)=$E(TEST1,1,$L(TEST1)-1)
"RTN","XTECGLO",274,0)
 . S TEST2=TEST1
"RTN","XTECGLO",275,0)
 . S TEST1=I_"  "_J
"RTN","XTECGLO",276,0)
 . I $D(PARTS(I,J,1)) D
"RTN","XTECGLO",277,0)
 . . S TEST2="^TMP("_PARTS(I,J,1)_")"
"RTN","XTECGLO",278,0)
 . . S TEST2=$NA(@TEST2)
"RTN","XTECGLO",279,0)
 . . S TEST2=$P(TEST2,"^TMP(",2)
"RTN","XTECGLO",280,0)
 . . S TEST2(1)=I_"  "_J
"RTN","XTECGLO",281,0)
 . . S OUTARRAY(I,J,1)=$E(TEST2,1,$L(TEST2)-1)
"RTN","XTECGLO",282,0)
 . . Q
"RTN","XTECGLO",283,0)
 . D DEBUG^XTMLOG("","TEST1,TEST2,OUTARRAY",1)
"RTN","XTECGLO",284,0)
 . Q
"RTN","XTECGLO",285,0)
 D DEBUG^XTMLOG("AFTER LOOP","OUTARRAY",1)
"RTN","XTECGLO",286,0)
 D DEBUG^XTMLOG("EXIT GETLIMIT","OUTARRAY,BASE",1)
"RTN","XTECGLO",287,0)
 Q BASE
"RTN","XTECGLO",288,0)
 ;
"RTN","XTECGLO",289,0)
CHEKTERM(BASEGLO,CURRGLO,MAXCOMMA,ARRAY) ; returns TRUE if CURRGLO follows a specified fixed range
"RTN","XTECGLO",290,0)
 N BASE1,BTERM,BTOKEN,CTERM,CTOKEN,CURR1,I,TERM,VALUE,GLOBAL,VARRAY
"RTN","XTECGLO",291,0)
 N COMMAS,DONE,ENDRANGE,FRSTNODE,LASTVALU,TERMVAL,TOKEN,VALID,XARRAY
"RTN","XTECGLO",292,0)
 ;
"RTN","XTECGLO",293,0)
 D INFO^XTMLOG("ENTRY","BASEGLO,CURRGLO,MAXCOMMA,ARRAY",1)
"RTN","XTECGLO",294,0)
 ; if ONLY GLOBAL NAME SPECIFIED
"RTN","XTECGLO",295,0)
 S TERM=0
"RTN","XTECGLO",296,0)
 I $L(BASEGLO,"(")=1 S VALUE=$P(CURRGLO,"(") Q VALUE]BASEGLO
"RTN","XTECGLO",297,0)
 ; find last specified value or range prior to unspecified values
"RTN","XTECGLO",298,0)
 ; get sequence of nodes for current global value into XARRAY
"RTN","XTECGLO",299,0)
 S GLOBAL=$P(CURRGLO,"(",2,99),GLOBAL=$E(GLOBAL,1,$L(GLOBAL)-1)
"RTN","XTECGLO",300,0)
 S COMMAS=0 F  Q:GLOBAL=""  S COMMAS=COMMAS+1,GLOBAL=$$NEXTTOKN^XTMRPAR2(GLOBAL,.TOKEN,.TERMVAL,",") S XARRAY(COMMAS)=TOKEN
"RTN","XTECGLO",301,0)
 D DEBUG^XTMLOG("","XARRAY",1)
"RTN","XTECGLO",302,0)
 D DEBUG^XTMLOG("V1","ARRAY",1)
"RTN","XTECGLO",303,0)
 ; determine first undefined or null node for input
"RTN","XTECGLO",304,0)
 F I=1:1 Q:'$D(ARRAY(I))  Q:ARRAY(I,1)=""  Q:$D(ARRAY(I,1))>1  Q:$O(ARRAY(I,1))>0
"RTN","XTECGLO",305,0)
 ; get last node that is required to match something, prior to any null values
"RTN","XTECGLO",306,0)
 D DEBUG^XTMLOG("","I",1)
"RTN","XTECGLO",307,0)
 ; now check for whether the current global follows the last specified node or range
"RTN","XTECGLO",308,0)
 S TERM=0,FRSTNODE=I-1 I FRSTNODE>0  D  I TERM Q TERM
"RTN","XTECGLO",309,0)
 . S LASTVALU=$O(ARRAY(FRSTNODE,""),-1) D DEBUG^XTMLOG("CHECK FIXED","FRSTNODE,LASTVALU",1)
"RTN","XTECGLO",310,0)
 . I $D(ARRAY(FRSTNODE,LASTVALU))=1,$D(XARRAY(FRSTNODE)),$$FOLLOWS(XARRAY(FRSTNODE),ARRAY(FRSTNODE,LASTVALU)) D DEBUG^XTMLOG("FIXED","XARRAY(FRSTNODE),ARRAY(FRSTNODE,LASTVALU)") S TERM=1
"RTN","XTECGLO",311,0)
 . I $D(ARRAY(FRSTNODE,LASTVALU))>1 D DEBUG^XTMLOG("CHECK RANGE") S TERM=$$FOLLOWS(XARRAY(FRSTNODE),ARRAY(FRSTNODE,LASTVALU,1)) I TERM D DEBUG^XTMLOG("RANGE","XARRAY(FRSTNODE),ARRAY(FRSTNODE,LASTVALU,1)")
"RTN","XTECGLO",312,0)
 . D DEBUG^XTMLOG("FROM FIRSTNODE","TERM")
"RTN","XTECGLO",313,0)
 . Q
"RTN","XTECGLO",314,0)
 Q TERM
"RTN","XTECGLO",315,0)
 ;
"RTN","XTECGLO",316,0)
FOLLOWS(TEST,BASE) ; returns TRUE (1) if TEST follows BASE
"RTN","XTECGLO",317,0)
 D INFO^XTMLOG("ENTRY","TEST,BASE")
"RTN","XTECGLO",318,0)
 N TERM,TYPE S TERM=0,TYPE=0
"RTN","XTECGLO",319,0)
 ; BOTH NUMERIC
"RTN","XTECGLO",320,0)
 I +BASE=BASE,+TEST=TEST S TYPE=1 I TEST>BASE D DEBUG^XTMLOG("2 NUMERICS TRUE") S TERM=1
"RTN","XTECGLO",321,0)
 ; BASE NUMERIC, TEST ALPHA
"RTN","XTECGLO",322,0)
 I TERM=0,TYPE=0,+BASE=BASE,+TEST'=TEST S TYPE=2 D DEBUG^XTMLOG("1 NUMERIC,1ALPHA") S TERM=1
"RTN","XTECGLO",323,0)
 I TERM=0,TYPE=0,+TEST=TEST,+BASE'=BASE S TYPE=2
"RTN","XTECGLO",324,0)
 ; BOTH ALPHA
"RTN","XTECGLO",325,0)
 ; 120203 next two lines of code added to prevent infinite loop if TEST contains
"RTN","XTECGLO",326,0)
 ;        space or exclamation mark at same location as closing quote in BASE
"RTN","XTECGLO",327,0)
 I TERM=0,TYPE=0,$E(TEST)="""",$E(TEST,$L(TEST))="""" S TEST=$E(TEST,2,$L(TEST)-1)
"RTN","XTECGLO",328,0)
 I TERM=0,TYPE=0,$E(BASE)="""",$E(BASE,$L(BASE))="""" S BASE=$E(BASE,2,$L(BASE)-1)
"RTN","XTECGLO",329,0)
 I TERM=0,TYPE=0,TEST]BASE S TYPE=3 D DEBUG^XTMLOG("BOTH ALPHA") S TERM=1
"RTN","XTECGLO",330,0)
 Q TERM
"RTN","XTECGLO",331,0)
 ;
"RTN","XTECGLO",332,0)
CHKRANGE(GLOBAL,MAXCOMMA,ARRAY) ; RETURNS GLOBAL WITHIN DESIRED RANGE
"RTN","XTECGLO",333,0)
 ; GLOBAL - INPUT GLOBAL VALUE
"RTN","XTECGLO",334,0)
 ; ARRAY  - PASSED BY REFERENCE - ARRAY OF NODE VALUES OR RANGES
"RTN","XTECGLO",335,0)
 N GLOBNODE,GLOBREF,I,J,MAXNODE,RESULT,VALUE,GLOBALV,IMAX,JMAX
"RTN","XTECGLO",336,0)
 N GLOSTR,NCOMMA,TERM,TOKEN
"RTN","XTECGLO",337,0)
 D INFO^XTMLOG("ENTRY")
"RTN","XTECGLO",338,0)
 S RESULT=""
"RTN","XTECGLO",339,0)
 S MAXNODE=$O(ARRAY(""),-1)
"RTN","XTECGLO",340,0)
 D DEBUG^XTMLOG("ENTRY","MAXNODE,MAXCOMMA,GLOBAL,ARRAY",1)
"RTN","XTECGLO",341,0)
 S NCOMMA=$$COMMACNT(GLOBAL)
"RTN","XTECGLO",342,0)
 I MAXCOMMA>0 I NCOMMA>MAXCOMMA S GLOBAL=$$MOVEUP(GLOBAL,MAXCOMMA)
"RTN","XTECGLO",343,0)
 I GLOBAL="" D INFO^XTMLOG("EXIT NULL") Q ""
"RTN","XTECGLO",344,0)
 K VALUE
"RTN","XTECGLO",345,0)
 S GLOBREF=$P(GLOBAL,"(")_"(",GLOBAL=$P(GLOBAL,"(",2,99),GLOBAL=$E(GLOBAL,1,$L(GLOBAL)-1)
"RTN","XTECGLO",346,0)
 D DEBUG^XTMLOG("3","GLOBREF,GLOB1")
"RTN","XTECGLO",347,0)
 S GLOSTR=GLOBAL,GLOBAL="",NCOMMA=$$COMMACNT(GLOSTR) ;$L(GLOSTR,",")
"RTN","XTECGLO",348,0)
 D DEBUG^XTMLOG("41","GLOSTR,NCOMMA")
"RTN","XTECGLO",349,0)
 F I=1:1:NCOMMA S GLOSTR=$$NEXTTOKN^XTMRPAR2(GLOSTR,.TOKEN,.TERM,",") S VALUE(I)=TOKEN
"RTN","XTECGLO",350,0)
 D DEBUG^XTMLOG("4A","VALUE",1)
"RTN","XTECGLO",351,0)
 F I=1:1 S IMAX=I,GLOBNODE=$G(VALUE(I)) Q:GLOBNODE=""  S VALUE(I)="",JMAX=$O(ARRAY(I,""),-1) S:+JMAX=0 VALUE(I)=GLOBNODE F J=1:1:JMAX D  Q:VALUE(I)'=""
"RTN","XTECGLO",352,0)
 . I '$D(ARRAY(I,1)) S VALUE(I)=GLOBNODE Q
"RTN","XTECGLO",353,0)
 . ; no value specified, use anything
"RTN","XTECGLO",354,0)
 . I $G(ARRAY(I,1))="" S VALUE(I)=GLOBNODE D DEBUG^XTMLOG("5A","I,VALUE(I)") Q
"RTN","XTECGLO",355,0)
 . ; fixed or lower bound value for node
"RTN","XTECGLO",356,0)
 . I $$FOLOWEQ(ARRAY(I,J),GLOBNODE) S VALUE(I)=ARRAY(I,J) D DEBUG^XTMLOG("5B","I,J,VALUE(I),ARRAY(I,J),GLOBNODE") Q
"RTN","XTECGLO",357,0)
 . I $D(ARRAY(I,J,1)),$$FOLOWEQ(GLOBNODE,ARRAY(I,J))&$$FOLOWEQ(ARRAY(I,J,1),GLOBNODE) S VALUE(I)=GLOBNODE D DEBUG^XTMLOG("5C","I,J,VALUE(I)") Q
"RTN","XTECGLO",358,0)
 . Q
"RTN","XTECGLO",359,0)
 S GLOBAL=GLOBREF
"RTN","XTECGLO",360,0)
 D DEBUG^XTMLOG("6","VALUE,IMAX",1)
"RTN","XTECGLO",361,0)
 F I=1:1:IMAX Q:$G(VALUE(I))=""  S GLOBAL=GLOBAL_$S(I>1:",",1:"")_VALUE(I)
"RTN","XTECGLO",362,0)
 D DEBUG^XTMLOG("61","I,NCOMMA,IMAX,GLOBAL")
"RTN","XTECGLO",363,0)
 ; following replaced => with not < since GT.M does not allow >= 120116 JLI
"RTN","XTECGLO",364,0)
 ;I (NCOMMA>=I),($G(VALUE(I))="") S GLOBAL=$$MOVEUP(GLOBAL,$L(GLOBAL,","))
"RTN","XTECGLO",365,0)
 I '(NCOMMA<I),($G(VALUE(I))="") S GLOBAL=$$MOVEUP(GLOBAL,$L(GLOBAL,","))
"RTN","XTECGLO",366,0)
 I GLOBAL'="",$E(GLOBAL,$L(GLOBAL))'=")" S GLOBAL=GLOBAL_")"
"RTN","XTECGLO",367,0)
 D INFO^XTMLOG("EXIT","GLOBAL")
"RTN","XTECGLO",368,0)
 Q GLOBAL
"RTN","XTECGLO",369,0)
 ;
"RTN","XTECGLO",370,0)
FOLOWEQ(TEST,BASE) ;
"RTN","XTECGLO",371,0)
 N RESULT S RESULT=0
"RTN","XTECGLO",372,0)
 I $$FOLLOWS(TEST,BASE) S RESULT=11
"RTN","XTECGLO",373,0)
 I TEST=BASE S RESULT=1
"RTN","XTECGLO",374,0)
 Q RESULT
"RTN","XTECGLO",375,0)
 ;
"RTN","XTECGLO",376,0)
MOVEUP(GLOBAL,MAXCOMMA) ;
"RTN","XTECGLO",377,0)
 D INFO^XTMLOG("MOVEUP ENTRY","GLOBAL,MAXCOMMA")
"RTN","XTECGLO",378,0)
 N GLOB1,GLOSTR,I,NCOMMA,TERM,TOKEN
"RTN","XTECGLO",379,0)
 S NCOMMA=MAXCOMMA
"RTN","XTECGLO",380,0)
LOOP S GLOSTR=GLOBAL,GLOBAL=""
"RTN","XTECGLO",381,0)
 N LOOP1
"RTN","XTECGLO",382,0)
 D DEBUG^XTMLOG("LOOP ENTRY","GLOSTR")
"RTN","XTECGLO",383,0)
 F I=1:1:NCOMMA S GLOSTR=$$NEXTTOKN^XTMRPAR2(GLOSTR,.TOKEN,.TERM,",") S GLOBAL=GLOBAL_$S(I>1:",",1:"")_TOKEN
"RTN","XTECGLO",384,0)
 D DEBUG^XTMLOG("MOVEUP PASS","GLOBAL")
"RTN","XTECGLO",385,0)
 S:$E(GLOBAL,$L(GLOBAL))="(" GLOBAL=""
"RTN","XTECGLO",386,0)
 S:GLOBAL="" GLOB1=""
"RTN","XTECGLO",387,0)
 D DEBUG^XTMLOG("MOVEUP PASS1","GLOBAL")
"RTN","XTECGLO",388,0)
 I GLOBAL'="" S LOOP1=0 D  I $G(LOOP1)=1 G LOOP
"RTN","XTECGLO",389,0)
 . S GLOBAL=GLOBAL_$S($E(GLOBAL,$L(GLOBAL))'=")":")",1:"")
"RTN","XTECGLO",390,0)
 . S GLOB1=$O(@GLOBAL)
"RTN","XTECGLO",391,0)
 . I GLOB1="" S NCOMMA=NCOMMA-1 S:NCOMMA=0 GLOBAL="" I NCOMMA>0 S LOOP1=1 ;G LOOP
"RTN","XTECGLO",392,0)
 . Q
"RTN","XTECGLO",393,0)
 I GLOB1'="",GLOB1'=+GLOB1 S GLOB1=""""_GLOB1_""""
"RTN","XTECGLO",394,0)
 D DEBUG^XTMLOG("LOOPA","GLOB1,NCOMMA")
"RTN","XTECGLO",395,0)
 I GLOB1'="",NCOMMA>1 S GLOBAL=$P(GLOBAL,",",1,NCOMMA-1)_","_GLOB1_")"
"RTN","XTECGLO",396,0)
 I GLOB1'="",NCOMMA=1 S GLOBAL=$P(GLOBAL,"(")_"("_GLOB1_")"
"RTN","XTECGLO",397,0)
 D INFO^XTMLOG("EXIT MOVEUP","GLOBAL")
"RTN","XTECGLO",398,0)
 Q GLOBAL
"RTN","XTECGLO",399,0)
 ;
"RTN","XTECGLO",400,0)
COMMACNT(GLOBAL) ;returns comma length for GLOBAL
"RTN","XTECGLO",401,0)
 N COUNT,TOKEN,TERM
"RTN","XTECGLO",402,0)
 S COUNT=0
"RTN","XTECGLO",403,0)
 F  Q:GLOBAL=""  S GLOBAL=$$NEXTTOKN^XTMRPAR2(GLOBAL,.TOKEN,.TERM,","),COUNT=COUNT+1
"RTN","XTECGLO",404,0)
 Q COUNT
"RTN","XTECLIPS")
0^1^B3789827
"RTN","XTECLIPS",1,0)
XTECLIPS ;JLI/FO-OAK - Eclipse Interface Via VistA Link ;01/15/12  13:56
"RTN","XTECLIPS",2,0)
 ;;7.3;TOOLKIT;**101**;Apr 25, 1995;Build 32
"RTN","XTECLIPS",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified
"RTN","XTECLIPS",4,0)
 ; JLI 120115 added an extra argument to list to prevent occasional errors reported on GT.M
"RTN","XTECLIPS",5,0)
RPC(XTECRES,XTECFUNC,XTECLINE,XTECFROM,XTECTO,XTECOPT,XTECXTRA) ;
"RTN","XTECLIPS",6,0)
 S ^XTMP("XTECLIPS",0)=3120211
"RTN","XTECLIPS",7,0)
 S ^XTMP("XTECLIPS",$H,1,"XTECFUNC")=$G(XTECFUNC)
"RTN","XTECLIPS",8,0)
 I $D(XTECLINE)>0 M ^XTMP("XTECLIPS",$H,2,"XTECLINE")=XTECLINE
"RTN","XTECLIPS",9,0)
 I $D(XTECFROM)>0 M ^XTMP("XTECLIPS",$H,3,"XTECFROM")=XTECFROM
"RTN","XTECLIPS",10,0)
 I $D(XTECTO)>0 M ^XTMP("XTECLIPS",$H,4,"XTECTO")=XTECTO
"RTN","XTECLIPS",11,0)
 I $D(XTECOPT)>0 M ^XTMP("XTECLIPS",$H,5,"XTECOPT")=XTECOPT
"RTN","XTECLIPS",12,0)
 ; XTECRES = this is the return value from the RPC call, will contain a global reference
"RTN","XTECLIPS",13,0)
 ; XTECFUNC = this is the type of function that is being done.
"RTN","XTECLIPS",14,0)
 ;       = RD Routine directory passed back in ARRAY
"RTN","XTECLIPS",15,0)
 ;       = RL Routine Load into ARRAY
"RTN","XTECLIPS",16,0)
 ;       = RS Routine Save Save the routine from XTECLINE
"RTN","XTECLIPS",17,0)
 ;       = GD Global directory Passed Back in ARRAY
"RTN","XTECLIPS",18,0)
 ;       = GL Global List in ARRAY
"RTN","XTECLIPS",19,0)
 ; XTECLINE = This is the total number of line that are requested at a time
"RTN","XTECLIPS",20,0)
 ; XTECFROM = This is the starting point or the one to be listed
"RTN","XTECLIPS",21,0)
 ; XTECTO =  this is the ending point
"RTN","XTECLIPS",22,0)
 ; XTECXTRA = an extra argument to prevent occasional errors in GT.M 120115 JLI
"RTN","XTECLIPS",23,0)
 N TMPGLOB
"RTN","XTECLIPS",24,0)
 S TMPGLOB=$NA(^TMP("XTECLIPS",$J)) K @TMPGLOB
"RTN","XTECLIPS",25,0)
 S XTECRES=TMPGLOB
"RTN","XTECLIPS",26,0)
 S XTECFUNC=$G(XTECFUNC),XTECFROM=$G(XTECFROM),XTECTO=$G(XTECTO)
"RTN","XTECLIPS",27,0)
 ;
"RTN","XTECLIPS",28,0)
 I XTECFUNC="RD" D DIR^XTECROU(TMPGLOB,$G(XTECLINE),XTECFROM,XTECTO) Q
"RTN","XTECLIPS",29,0)
 I XTECFUNC="RL" D LOAD^XTECROU(TMPGLOB,XTECFROM) Q
"RTN","XTECLIPS",30,0)
 I XTECFUNC="RS" D SAVE^XTECROU(TMPGLOB,.XTECLINE,XTECFROM,XTECTO) Q
"RTN","XTECLIPS",31,0)
 I XTECFUNC="RI" D INFO^XTECROU(TMPGLOB,XTECFROM,XTECTO) Q
"RTN","XTECLIPS",32,0)
 I XTECFUNC="GD" D LIST^XTECGLO(TMPGLOB,$G(XTECLINE),XTECFROM,XTECTO) Q
"RTN","XTECLIPS",33,0)
 I XTECFUNC="GL" D LNODE^XTECGLO(TMPGLOB,$G(XTECLINE),XTECFROM,$G(XTECTO),$G(XTECOPT)) Q
"RTN","XTECLIPS",34,0)
 ; 101105 return whether production system or not.
"RTN","XTECLIPS",35,0)
 I XTECFUNC="PROD" S @TMPGLOB@(0)=$$PROD^XUPROD Q
"RTN","XTECLIPS",36,0)
 ;
"RTN","XTECLIPS",37,0)
 S @TMPGLOB@(0)="-1^INVALID FUNCTION"
"RTN","XTECLIPS",38,0)
 Q
"RTN","XTECROU")
0^3^B51806057
"RTN","XTECROU",1,0)
XTECROU ;FO-OAK/JLI - routine processing for eclipse ;6/21/2013
"RTN","XTECROU",2,0)
 ;;7.3;TOOLKIT;**101**;Apr 25, 1995;Build 32
"RTN","XTECROU",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified
"RTN","XTECROU",4,0)
 Q
"RTN","XTECROU",5,0)
DIR(XTECGLOB,XTECLINE,XTECFROM,XTECTO) ; This routine will provide a list of routines
"RTN","XTECROU",6,0)
 ; ARRAY = is the return array where the list will be passed
"RTN","XTECROU",7,0)
 ; XTECFROM(Optional) = is a starting point
"RTN","XTECROU",8,0)
 ; XTECTO (Optional) = is an ending point
"RTN","XTECROU",9,0)
 N CNT,ROU,FST,FLG
"RTN","XTECROU",10,0)
 ; remove * if user entered name*
"RTN","XTECROU",11,0)
 S:XTECFROM["*" XTECFROM=$P(XTECFROM,"*") S:XTECTO["*" XTECTO=$P(XTECTO,"*")
"RTN","XTECROU",12,0)
 S @XTECGLOB@(0)="0^NO ROUTINES FOUND IN SEARCH "_$S(XTECTO="":"FOR",1:"BETWEEN")_" "_XTECFROM_$S(XTECTO'="":"AND "_XTECTO,1:"")
"RTN","XTECROU",13,0)
 S XTECLINE=$G(XTECLINE,1000)
"RTN","XTECROU",14,0)
 S FLG=$$SETNAMES^XTECGLO(.XTECFROM,.XTECTO) I FLG<0 S @XTECGLOB@(0)=FLG Q
"RTN","XTECROU",15,0)
 S ROU=XTECFROM,FLG=0,CNT=0,FST=""
"RTN","XTECROU",16,0)
 ;F  S ROU=$O(^$ROUTINE(ROU)) Q:ROU=""  D  Q:FLG
"RTN","XTECROU",17,0)
 F  S ROU=$O(^DIC(9.8,"B",ROU)) Q:ROU=""  D  Q:FLG
"RTN","XTECROU",18,0)
 . I ROU]XTECTO S FLG=1 Q
"RTN","XTECROU",19,0)
 . I CNT=XTECLINE S FLG=1 Q
"RTN","XTECROU",20,0)
 . I FST="" S FST=ROU
"RTN","XTECROU",21,0)
 . S CNT=CNT+1,@XTECGLOB@(CNT)=ROU
"RTN","XTECROU",22,0)
 . Q
"RTN","XTECROU",23,0)
 I CNT S @XTECGLOB@(0)=CNT_"^"_FST_"^"_@XTECGLOB@(CNT)
"RTN","XTECROU",24,0)
 Q
"RTN","XTECROU",25,0)
 ;
"RTN","XTECROU",26,0)
INFO(XTECGLOB,ROU,OPTS) ; Return the routine information
"RTN","XTECROU",27,0)
 N SIZ1,SIZ2,TMP,X,XTECGLO1,TMP,Y
"RTN","XTECROU",28,0)
 S X=$$SETNAMES^XTECGLO(ROU,"") I X<0 S @XTECGLOB@(0)=X Q
"RTN","XTECROU",29,0)
 I '$$ROU(ROU) S @XTECGLOB@(0)="-1^Routine Not found" Q
"RTN","XTECROU",30,0)
 S @XTECGLOB@(0)="1^"_ROU
"RTN","XTECROU",31,0)
 S XTECGLO1=$NA(^TMP("XTECLIPSE1",$J)) K @XTECGLO1
"RTN","XTECROU",32,0)
 S X=ROU,TMP="",SIZ1=$S
"RTN","XTECROU",33,0)
 D LOAD(XTECGLO1,X)
"RTN","XTECROU",34,0)
 M TMP=@XTECGLO1
"RTN","XTECROU",35,0)
 K @XTECGLO1
"RTN","XTECROU",36,0)
 S SIZ2=$S,@XTECGLOB@(1)=(SIZ1-SIZ2)
"RTN","XTECROU",37,0)
 S X=ROU X ^%ZOSF("RSUM") S @XTECGLOB@(2)=Y
"RTN","XTECROU",38,0)
 D XINDEX(ROU,XTECGLO1)
"RTN","XTECROU",39,0)
 M @XTECGLOB=@XTECGLO1
"RTN","XTECROU",40,0)
 K @XTECGLO1
"RTN","XTECROU",41,0)
 Q
"RTN","XTECROU",42,0)
 ;
"RTN","XTECROU",43,0)
LOAD(XTECGLOB,ROU) ; load the routine
"RTN","XTECROU",44,0)
 ; ARRAY = is the return array where the routine will be passed
"RTN","XTECROU",45,0)
 ;   in the structure:
"RTN","XTECROU",46,0)
 ; ROU = is the routine that is requested
"RTN","XTECROU",47,0)
 N TMP,I,J
"RTN","XTECROU",48,0)
 S I=$$LOADROU(ROU,"TMP") I I'>0 S @XTECGLOB@(0)=I Q
"RTN","XTECROU",49,0)
 ;
"RTN","XTECROU",50,0)
 S I=0
"RTN","XTECROU",51,0)
 F  S I=$O(TMP(I)) Q:I<1  D
"RTN","XTECROU",52,0)
 . Q:TMP(I,0)=""
"RTN","XTECROU",53,0)
 .;N J F J=1:1:$L(TMP(I,0)) I $E(TMP(I,0),J)=" " S TMP(I,0)=$E(TMP(I,0),1,J-1)_$C(9)_$E(TMP(I,0),J+1,$L(TMP(I,0))) Q
"RTN","XTECROU",54,0)
 . S @XTECGLOB@(I)=TMP(I,0)
"RTN","XTECROU",55,0)
 S @XTECGLOB@(0)="1^"_ROU
"RTN","XTECROU",56,0)
 Q
"RTN","XTECROU",57,0)
 ;
"RTN","XTECROU",58,0)
ROU(X) ;encapsule the call to ^%ZOSF("TEST")
"RTN","XTECROU",59,0)
 X ^%ZOSF("TEST")
"RTN","XTECROU",60,0)
 Q $T
"RTN","XTECROU",61,0)
 ;
"RTN","XTECROU",62,0)
SAVE(XTECGLOB,ARRAY,ROU,OPTS) ; Save a routine from the array to the name ROU
"RTN","XTECROU",63,0)
 ; ARRAY = The array of routine to save
"RTN","XTECROU",64,0)
 ; ROU = the Namespace to save it to
"RTN","XTECROU",65,0)
 ; OPTS = updateroutinefile^unittestname^updatefirstline
"RTN","XTECROU",66,0)
 ;       update routine file if 1
"RTN","XTECROU",67,0)
 ;       unittestname is routine name
"RTN","XTECROU",68,0)
 ;       updatefirstline if 1 (or null for original client code)
"RTN","XTECROU",69,0)
 N TMP,I,DIE,DIF,X,XCN,UNITROU
"RTN","XTECROU",70,0)
 I ROU="" S @XTECGLOB@(0)="-1^No routine name"
"RTN","XTECROU",71,0)
 S I=$$SETNAMES^XTECGLO(ROU,"") I I<0 S @XTECGLOB@(0)=I Q
"RTN","XTECROU",72,0)
 I '$D(ARRAY(1)) S @XTECGLOB@(0)="-1^No routine to process" Q
"RTN","XTECROU",73,0)
 S I=0
"RTN","XTECROU",74,0)
 F  S I=$O(ARRAY(I)) Q:I<1  D
"RTN","XTECROU",75,0)
 . I ARRAY(I)="" Q
"RTN","XTECROU",76,0)
 . I ARRAY(I)[$C(9) S ARRAY(I)=$P(ARRAY(I),$C(9))_" "_$P(ARRAY(I),$C(9),2,99)
"RTN","XTECROU",77,0)
 . F  Q:$E(ARRAY(I),$L(ARRAY(I)))'=" "  S ARRAY(I)=$E(ARRAY(I),1,$L(ARRAY(I))-1)
"RTN","XTECROU",78,0)
 . I I=1,($P($G(OPTS),U,3)="")!(+$P($G(OPTS),U,3)) S ARRAY(I)=$$FIRSTLIN(ARRAY(I),ROU)
"RTN","XTECROU",79,0)
 . S ^TMP($J,I,0)=ARRAY(I)
"RTN","XTECROU",80,0)
 . Q
"RTN","XTECROU",81,0)
 S (DIF,DIE)="^TMP($J,",XCN=0,X=ROU N ROUNAME S ROUNAME=ROU
"RTN","XTECROU",82,0)
 X ^%ZOSF("SAVE")
"RTN","XTECROU",83,0)
 K ARRAY
"RTN","XTECROU",84,0)
 ; following line added at suggestion of Lloyd Milligan to add
"RTN","XTECROU",85,0)
 ; routine to ROUTINE file if not already present 120115
"RTN","XTECROU",86,0)
 I +$G(OPTS) D FILE(ROU)
"RTN","XTECROU",87,0)
 ; end of 120115 addition
"RTN","XTECROU",88,0)
 ;
"RTN","XTECROU",89,0)
 I $D(^%Z("FILE")),+$G(OPTS),^%ZOSF("OS")'["GT.M" D
"RTN","XTECROU",90,0)
 . N XX,XX1,%X,%POP
"RTN","XTECROU",91,0)
 . S XX="S %NX=1 X ^%Z(""F11"") I %A>0 X ^%ZOSF(""UCI"") S ^DIC(9.8,%A,23,%C,0)=%DT_""^""_$I_""^""_Y_""^""_$S($D(DUZ)#2:DUZ,1:"""")"
"RTN","XTECROU",92,0)
 . X "S %X=ROUNAME ZL @ROUNAME X ^%Z(""F2""),^%Z(""F3""),XX"
"RTN","XTECROU",93,0)
 . Q
"RTN","XTECROU",94,0)
 ; JLI 100509 next line added to provide routine and comment size at top console output
"RTN","XTECROU",95,0)
 S ARRAY=$$GETSIZE(ROU) S @XTECGLOB@(1)="   "_(+ARRAY)_" TOTAL BYTES  "_$P(ARRAY,U,2)_" COMMENT BYTES"
"RTN","XTECROU",96,0)
 S UNITROU=$P($G(OPTS),U,2) I UNITROU["does not exist" S UNITROU=""
"RTN","XTECROU",97,0)
 D CHKROU(XTECGLOB,ROUNAME,UNITROU)
"RTN","XTECROU",98,0)
 K ^TMP($J)
"RTN","XTECROU",99,0)
 Q
"RTN","XTECROU",100,0)
 ;
"RTN","XTECROU",101,0)
CHKROU(XTECGLOB,XTECNAME,XTECUNIT) ;
"RTN","XTECROU",102,0)
 N XTECRSLT,I,J
"RTN","XTECROU",103,0)
 S XTECRSLT=$NA(^TMP("ROUTMP",$J))
"RTN","XTECROU",104,0)
 D XINDEX(XTECNAME,XTECRSLT)
"RTN","XTECROU",105,0)
 M @XTECGLOB=@XTECRSLT
"RTN","XTECROU",106,0)
 S XTROUSIZ=$$GETSIZE(XTECNAME)
"RTN","XTECROU",107,0)
 S @XTECGLOB@(0)="1^"_XTECNAME
"RTN","XTECROU",108,0)
 K @XTECRSLT
"RTN","XTECROU",109,0)
 D CHEKTAGS^XTMRPAR1(XTECNAME,XTECRSLT)
"RTN","XTECROU",110,0)
 D ADDLINE(XTECGLOB,XTECRSLT,"Variables which are neither NEWed or arguments")
"RTN","XTECROU",111,0)
 I $G(XTECUNIT)'="" D
"RTN","XTECROU",112,0)
 . D UNITTEST(XTECUNIT,XTECRSLT)
"RTN","XTECROU",113,0)
 . D ADDLINE(XTECGLOB,XTECRSLT,"Results of Unit Tests")
"RTN","XTECROU",114,0)
 . Q
"RTN","XTECROU",115,0)
 Q
"RTN","XTECROU",116,0)
 ;
"RTN","XTECROU",117,0)
ADDLINE(XTECGLOB,XTECRSLT,HEADER) ;
"RTN","XTECROU",118,0)
 N I,J
"RTN","XTECROU",119,0)
 S J=$$LASTNODE(XTECGLOB)
"RTN","XTECROU",120,0)
 S J=J+1,@XTECGLOB@(J)="",J=J+1,@XTECGLOB@(J)="",J=J+1,@XTECGLOB@(J)=HEADER,J=J+1,@XTECGLOB@(J)=""
"RTN","XTECROU",121,0)
 S I="" F  S I=$O(@XTECRSLT@(I)) Q:I=""  S J=J+1,@XTECGLOB@(J)=@XTECRSLT@(I)
"RTN","XTECROU",122,0)
 K @XTECRSLT
"RTN","XTECROU",123,0)
 Q
"RTN","XTECROU",124,0)
 ;
"RTN","XTECROU",125,0)
LASTNODE(GLOB) ; Extrinsic Function - returns value of current last node in global reference GLOB
"RTN","XTECROU",126,0)
 N I,J
"RTN","XTECROU",127,0)
 S I="",J="" F  S I=$O(@GLOB@(I)) Q:I=""  S J=I
"RTN","XTECROU",128,0)
 Q J
"RTN","XTECROU",129,0)
 ;
"RTN","XTECROU",130,0)
FIRSTLIN(INPUT,ROU) ;
"RTN","XTECROU",131,0)
 ; update date/time on first line and if name on first line does not start with %,
"RTN","XTECROU",132,0)
 ; make sure name is on first line
"RTN","XTECROU",133,0)
 ;
"RTN","XTECROU",134,0)
 ; 090918 - As pointed out by John McCormack, in some cases the name shouldn't match that on the first line
"RTN","XTECROU",135,0)
 ;          So, removed forcing the names to match.  This allowed removal of all code dependent upon what
"RTN","XTECROU",136,0)
 ;          linestart character was used, and only the time needed to be set
"RTN","XTECROU",137,0)
 ;
"RTN","XTECROU",138,0)
 ; 090918 - semicolons on first line may not have space in front of them place time simply as third ";" piece
"RTN","XTECROU",139,0)
 N CURTIME S CURTIME=$$NOW^XLFDT(),CURTIME=$E(CURTIME,4,5)_"/"_$E(CURTIME,6,7)_"/"_$E(CURTIME,2,3)_"  "_$E(CURTIME,9,10)_":"_$E(CURTIME,11,12)
"RTN","XTECROU",140,0)
 S $P(INPUT,";",3)=CURTIME
"RTN","XTECROU",141,0)
 Q INPUT
"RTN","XTECROU",142,0)
 ;
"RTN","XTECROU",143,0)
UNITTEST(XTECUNIT,XTECRSLT) ;
"RTN","XTECROU",144,0)
 N XTECDOC,XTECDEV,XTECIO,I,XTECDEVN,XTMUIO
"RTN","XTECROU",145,0)
 S XTECDOC="XTEC"_$J_"A.DAT"
"RTN","XTECROU",146,0)
 D SETDOC(XTECDOC)
"RTN","XTECROU",147,0)
 S XTECIO=IO
"RTN","XTECROU",148,0)
 S XTMUIO=IO,XTECDEV="",XTECDEVN="" F  S XTECDEVN=$O(^TMP("XUDEVICE",$J,XTECDEVN)) Q:XTECDEVN=""  I $G(^(XTECDEVN,"IO"))=IO S XTECDEV=^(0) Q
"RTN","XTECROU",149,0)
 I XTECDEV="" S XTECDEV="XTMUNIT DEVICE" D SAVDEV^%ZISUTL(XTECDEV)
"RTN","XTECROU",150,0)
 M ^TMP("UNITTEST1",$J,"DEV1")=^TMP("XUDEVICE",$J)
"RTN","XTECROU",151,0)
 D EN^XTMUNIT(XTECUNIT)
"RTN","XTECROU",152,0)
 K ^TMP("UNITTEST1",$J)
"RTN","XTECROU",153,0)
 M ^TMP("UNITTEST1",$J,"IO")=IO
"RTN","XTECROU",154,0)
 M ^TMP("UNITTEST1",$J,"DEV2")=^TMP("XUDEVICE",$J)
"RTN","XTECROU",155,0)
 I IO'=XTECIO D USE^%ZISUTL(XTECDEV)
"RTN","XTECROU",156,0)
 D GETDOC(XTECDOC,XTECRSLT)
"RTN","XTECROU",157,0)
 F I=0:0 S I=$O(@XTECRSLT@(I)) Q:I'>0  I $E(^(I),1,4)="|TOP" K ^(I) Q
"RTN","XTECROU",158,0)
 Q
"RTN","XTECROU",159,0)
 ;
"RTN","XTECROU",160,0)
XINDEX(XTECNAME,XTECGLOB) ;
"RTN","XTECROU",161,0)
 N XTECDOC,IOP,INNDDA,INP,NRO,NDA,X,I,INDDA,J
"RTN","XTECROU",162,0)
 S XTECDOC="XTEC"_$J_".DAT"
"RTN","XTECROU",163,0)
 K ^UTILITY($J) S ^UTILITY($J,XTECNAME)=""
"RTN","XTECROU",164,0)
 S INDDA=-1
"RTN","XTECROU",165,0)
 F I=1:1:9 S INP(I)=0
"RTN","XTECROU",166,0)
 S INP(10)=9.4,INP(11)="",INP(12)="",INP("MAX")=20000,INP("CMAX")=15000
"RTN","XTECROU",167,0)
 S NRO=1
"RTN","XTECROU",168,0)
 D SETDOC(XTECDOC) ; setup a spool file using XTECDOC
"RTN","XTECROU",169,0)
 D ALIVE^XINDEX
"RTN","XTECROU",170,0)
 D GETDOC(XTECDOC,XTECGLOB)
"RTN","XTECROU",171,0)
 ; trim it down to just the error info
"RTN","XTECROU",172,0)
 F I=0:0 S I=$O(@XTECGLOB@(I)) Q:I'>0  Q:$E(^(I),1,4)="Comp"  K ^(I)
"RTN","XTECROU",173,0)
 I I>0 F  S I=$O(@XTECGLOB@(I)) Q:I'>0  I $E(^(I),1,7)="--- END" K ^(I) Q
"RTN","XTECROU",174,0)
 I I>0 F  S I=$O(@XTECGLOB@(I)) Q:I'>0  K ^(I)
"RTN","XTECROU",175,0)
 Q
"RTN","XTECROU",176,0)
 ;
"RTN","XTECROU",177,0)
LOADROU(ROU,LOC) ;EX. FUNCTION - LOAD A ROUTINE NAMED ROU INTO LOC ARRAY
"RTN","XTECROU",178,0)
 ; ROU ---- ROUTINE NAME
"RTN","XTECROU",179,0)
 ; LOC ---- NAME OF ARRAY TO CONTAIN LOADED ROUTINE
"RTN","XTECROU",180,0)
 ;          (E.G., "TMP" would return the routine in TMP(1,0),TMP(2,0), etc.)
"RTN","XTECROU",181,0)
 ;
"RTN","XTECROU",182,0)
 ; RETURN VALUE -1^DESCRIPTION OF ERROR IF LOAD FAILED
"RTN","XTECROU",183,0)
 ;              1  IF LOAD SUCCEEDED
"RTN","XTECROU",184,0)
 ;
"RTN","XTECROU",185,0)
 N CNT,LN,I,DIF,X,XCNP
"RTN","XTECROU",186,0)
 K @LOC
"RTN","XTECROU",187,0)
 S I=$$SETNAMES^XTECGLO(ROU,"") I I<0 Q "-1^Invalid Routine Name"
"RTN","XTECROU",188,0)
 ; $$ROU(ROU) used a check of the ROUTINE file for file name
"RTN","XTECROU",189,0)
 ; but routines with names longer than the standard always
"RTN","XTECROU",190,0)
 ; show up as not found will trap the error instead if not present
"RTN","XTECROU",191,0)
 ; I '$$ROU(ROU) Q "-1^Routine Not found" ; JLI 120806
"RTN","XTECROU",192,0)
 N $ETRAP S $ETRAP="D ERROR^XTECROU" ; JLI 120806
"RTN","XTECROU",193,0)
 S DIF=LOC_"(",XCNP=0,X=ROU
"RTN","XTECROU",194,0)
 X ^%ZOSF("LOAD")
"RTN","XTECROU",195,0)
 I '$D(@LOC@(1,0)) Q "-1^Error Processing load request"
"RTN","XTECROU",196,0)
 Q 1
"RTN","XTECROU",197,0)
 ;
"RTN","XTECROU",198,0)
ERROR ; catch error on trying to load file if it doesn't exist ; JLI 120806
"RTN","XTECROU",199,0)
 S $ZE="",$EC=""
"RTN","XTECROU",200,0)
 Q
"RTN","XTECROU",201,0)
 ;
"RTN","XTECROU",202,0)
GETSIZE(XTECNAME) ; determine total and comment size of routine
"RTN","XTECROU",203,0)
 N NUM,COM,TOT,TMP
"RTN","XTECROU",204,0)
 S NUM=$$LOADROU(XTECNAME,"TMP") I NUM'>0 Q "0^0"
"RTN","XTECROU",205,0)
 S COM=0,TOT=0
"RTN","XTECROU",206,0)
 S NUM=0 F  S NUM=$O(TMP(NUM)) Q:NUM'>0  S LIN=TMP(NUM,0),LN=$L(LIN),TOT=TOT+LN+2 D
"RTN","XTECROU",207,0)
 . S LIN=$P(LIN," ",2,999)
"RTN","XTECROU",208,0)
 . F  Q:LIN=""  Q:" ."'[$E(LIN)  S LIN=$E(LIN,2,999)
"RTN","XTECROU",209,0)
 . I $E(LIN)=";",$E(LIN,2)'=";" S COM=COM+$L(LIN)
"RTN","XTECROU",210,0)
 . Q
"RTN","XTECROU",211,0)
 Q TOT_U_COM
"RTN","XTECROU",212,0)
 ;
"RTN","XTECROU",213,0)
SETDOC(XTECDOC) ;
"RTN","XTECROU",214,0)
 N IOP,%ZIS
"RTN","XTECROU",215,0)
 S IOP="HFS",%ZIS("HFSNAME")=$$CHKNM^%ZISF(XTECDOC),%ZIS("HFSMODE")="W" D ^%ZIS ;_$"SPOOL;P-OTH80;"_XTECDOC D ^%ZIS
"RTN","XTECROU",216,0)
 U IO S $Y=0
"RTN","XTECROU",217,0)
 Q
"RTN","XTECROU",218,0)
 ;
"RTN","XTECROU",219,0)
GETDOC(XTECDOC,XTECGLOB) ;
"RTN","XTECROU",220,0)
 N X,XNAME
"RTN","XTECROU",221,0)
 U IO D ^%ZISC
"RTN","XTECROU",222,0)
 S X=$$FTG^%ZISH("",XTECDOC,$NA(@XTECGLOB@(1)),3)
"RTN","XTECROU",223,0)
 S XNAME(XTECDOC)=""
"RTN","XTECROU",224,0)
 S X=$$DEL^%ZISH("",$NA(XNAME))
"RTN","XTECROU",225,0)
 Q
"RTN","XTECROU",226,0)
 ; the following tag was added at the suggestion of Lloyd Milligan,
"RTN","XTECROU",227,0)
 ; SeaIslandSystems, to add files on GT.M to the ROUTINE file (#9.8)
"RTN","XTECROU",228,0)
FILE(X) ; file routine name X to ROUTINE FILE if not already present
"RTN","XTECROU",229,0)
 Q:'$L($G(X))  N FDA
"RTN","XTECROU",230,0)
 S FDA(9.8,"?+1,",.01)=X
"RTN","XTECROU",231,0)
 S FDA(9.8,"?+1,",1)="R"
"RTN","XTECROU",232,0)
 D UPDATE^DIE(,"FDA")
"RTN","XTECROU",233,0)
 Q
"RTN","XTMRPAR1")
0^4^B62027368
"RTN","XTMRPAR1",1,0)
XTMRPAR1 ;jli/oifo-oak - list tags, find variables that aren't arguments or newed ;10/28/10  16:18
"RTN","XTMRPAR1",2,0)
 ;;7.3;TOOLKIT;**101**;Apr 25, 1995;Build 32
"RTN","XTMRPAR1",3,0)
 D EN^XTMUNIT("ZZUTXTM1") ; RUN UNIT TESTS
"RTN","XTMRPAR1",4,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified
"RTN","XTMRPAR1",5,0)
 Q
"RTN","XTMRPAR1",6,0)
 ; CHEKTAGS(ROUNAME)
"RTN","XTMRPAR1",7,0)
 ; list variables in routine ROUNAME which are not arguments or newed by code following a tag
"RTN","XTMRPAR1",8,0)
 ; this analyzes only code between a tag and a final quit or go following the tag.
"RTN","XTMRPAR1",9,0)
 ;
"RTN","XTMRPAR1",10,0)
 ; GLOBAL is optional, and if present should be a closed global reference in which the
"RTN","XTMRPAR1",11,0)
 ; text of the results will be returned. added 04/29/04
"RTN","XTMRPAR1",12,0)
CHEKTAGS(ROUNAME,GLOBAL) ;
"RTN","XTMRPAR1",13,0)
 N XALL,XTAGS,CNT,I,WORD,TCNT,GLOBREF,L
"RTN","XTMRPAR1",14,0)
 S GLOBREF=$NA(^TMP("XTMRPAR1",$J)) K @GLOBREF
"RTN","XTMRPAR1",15,0)
 S XALL=$NA(^TMP("XTMRXALL",$J)) K @XALL
"RTN","XTMRPAR1",16,0)
 S XTAGS=$NA(^TMP("XTMRXTAGS",$J)) K @XTAGS
"RTN","XTMRPAR1",17,0)
 D EN(ROUNAME,XALL)
"RTN","XTMRPAR1",18,0)
 D GETTAGS(XALL,XTAGS)
"RTN","XTMRPAR1",19,0)
 D XTAGS(XALL,XTAGS)
"RTN","XTMRPAR1",20,0)
 S (TCNT,L)=0
"RTN","XTMRPAR1",21,0)
 F I=1:1 Q:'$D(@XTAGS@(I))  I $D(@XTAGS@(I,"WRDS")) S L=L+1,@GLOBREF@(L)=@XTAGS@(I,"NAME")_":  " S CNT=0,WORD="" F  S WORD=$O(@XTAGS@(I,"WRDS",WORD)) Q:WORD=""  S CNT=CNT+1,TCNT=TCNT+1 S @GLOBREF@(L)=@GLOBREF@(L)_$S(CNT>1:",",1:"")_WORD
"RTN","XTMRPAR1",22,0)
 I TCNT=0 S @GLOBREF@(1)="no tags with variables to list"
"RTN","XTMRPAR1",23,0)
 I $G(GLOBAL)="" F I=0:0 S I=$O(@GLOBREF@(I)) Q:I=""  W !,@GLOBREF@(I)
"RTN","XTMRPAR1",24,0)
 E  M @GLOBAL=@GLOBREF
"RTN","XTMRPAR1",25,0)
 K @GLOBREF,@XALL,@XTAGS
"RTN","XTMRPAR1",26,0)
 Q
"RTN","XTMRPAR1",27,0)
 ;
"RTN","XTMRPAR1",28,0)
LISTTAGS(ROUNAME,LOC) ; generates a list of tags in a routine, argument list if any, and if indicated SR or OPT
"RTN","XTMRPAR1",29,0)
 N I,NAME
"RTN","XTMRPAR1",30,0)
 S LOC=$G(LOC,"TAGS")
"RTN","XTMRPAR1",31,0)
 I $D(ROUNAME)=1 W !!,ROUNAME,":" D EN(ROUNAME,LOC),LISTTAG1(ROUNAME,LOC) I 1
"RTN","XTMRPAR1",32,0)
 E  S I="" F  S I=$O(ROUNAME(I)) Q:I=""  S NAME=$S(ROUNAME(I)="":I,1:ROUNAME(I)) W !!,NAME,":" D EN(NAME,LOC),LISTTAG1(NAME,LOC)
"RTN","XTMRPAR1",33,0)
 Q
"RTN","XTMRPAR1",34,0)
 ;
"RTN","XTMRPAR1",35,0)
LISTTAG1(ROUNAME,LOC) ;
"RTN","XTMRPAR1",36,0)
 N I,J,JC,K,X
"RTN","XTMRPAR1",37,0)
 F I=0:0 S I=$O(@LOC@(I)) Q:I'>0  I $D(@LOC@(I,0,"TAG")) D
"RTN","XTMRPAR1",38,0)
 . W !,@LOC@(I,0,"TAG") S JC=0
"RTN","XTMRPAR1",39,0)
 . F J=0:0 S J=$O(@LOC@(I,0,"TAG","ARG",J)) W:(J'>0)&(JC>0) ")" Q:J'>0  D
"RTN","XTMRPAR1",40,0)
 . . S JC=JC+1 W $S(JC=1:"(",1:","),@LOC@(I,0,"TAG","ARG",J)
"RTN","XTMRPAR1",41,0)
 . . Q
"RTN","XTMRPAR1",42,0)
 . F K=0:0 S K=$O(@LOC@(I,K)) Q:K'>0  S X=$G(@LOC@(I,K,"COMMENT")) I X'="" W:X["SR" "     SR" W:X["OPT" "    OPT" Q
"RTN","XTMRPAR1",43,0)
 . Q
"RTN","XTMRPAR1",44,0)
 Q
"RTN","XTMRPAR1",45,0)
 ;
"RTN","XTMRPAR1",46,0)
SHOWTAG(TAG,ROUNAME) ; lists parsed values for code for a specified tag.  May be run as D SHOWTAG("TAG","ROUTINE") or D SHOWTAG("TAG^ROUTINE")
"RTN","XTMRPAR1",47,0)
 N XALL,XTAGS,I,START,END,XEND,XX
"RTN","XTMRPAR1",48,0)
 S ROUNAME=$G(ROUNAME) I ROUNAME="" S ROUNAME=$P(TAG,U,2) I ROUNAME="" W !,"Need routine name.  D SHOWTAG^XTMRTEST(tag,rouname)" Q
"RTN","XTMRPAR1",49,0)
 S TAG=$P(TAG,U)
"RTN","XTMRPAR1",50,0)
 D EN(ROUNAME,"XALL")
"RTN","XTMRPAR1",51,0)
 D GETTAGS("XALL","XTAGS")
"RTN","XTMRPAR1",52,0)
 F I=1:1 Q:'$D(XTAGS(I))  I XTAGS(I,"NAME")=TAG S START=XTAGS(I),END=$G(XTAGS(I,"Q")) Q
"RTN","XTMRPAR1",53,0)
 S XX="XALL("_START_")",XEND=$S(END>0:"XALL("_(END+1),1:"XALL(")
"RTN","XTMRPAR1",54,0)
 F  S XX=$Q(@XX) Q:(END>0)&(XX[XEND)  Q:(END="")&(XX'[XEND)  W !,"LINE "_$E(XX,6,999)_" = "_@XX
"RTN","XTMRPAR1",55,0)
 Q
"RTN","XTMRPAR1",56,0)
 ;
"RTN","XTMRPAR1",57,0)
 ; EN(ROUNAME,LOC)
"RTN","XTMRPAR1",58,0)
 ; generates parsed structure for routine ROUNAME under the closed argument specified by LOC
"RTN","XTMRPAR1",59,0)
 ;  (which may be local or global)
"RTN","XTMRPAR1",60,0)
EN(ROUNAME,LOC) ;
"RTN","XTMRPAR1",61,0)
 N GLOB,CNT,IVAL
"RTN","XTMRPAR1",62,0)
 S GLOB=$NA(^TMP($J,0))
"RTN","XTMRPAR1",63,0)
 D LOAD(ROUNAME,GLOB)
"RTN","XTMRPAR1",64,0)
 S CNT=0,LOC=$G(LOC,"PARSLINE") K @LOC
"RTN","XTMRPAR1",65,0)
 F IVAL=0:0 S IVAL=$O(@GLOB@(IVAL)) Q:IVAL'>0  S CNT=CNT+1 D PARSLINE(^(IVAL,0),CNT,LOC)
"RTN","XTMRPAR1",66,0)
 Q
"RTN","XTMRPAR1",67,0)
 ;
"RTN","XTMRPAR1",68,0)
 ; XTAGS(LOC,TAGLOC)
"RTN","XTMRPAR1",69,0)
 ; code that checks for variables that are not NEWed or arguments,
"RTN","XTMRPAR1",70,0)
 ; LOC is the closed root under which the routine was parsed,
"RTN","XTMRPAR1",71,0)
 ; TAGLOC is the closed root under which the tags were identified by GETTAGS
"RTN","XTMRPAR1",72,0)
 ; Variables which are identified are returned under the location specified by TAGLOC
"RTN","XTMRPAR1",73,0)
 ;    in @TAGLOC@(tagnum,"WRDS",variableid)=""
"RTN","XTMRPAR1",74,0)
XTAGS(LOC,TAGLOC) ;
"RTN","XTMRPAR1",75,0)
 N I,J,K,L,START,END,CMDTYPE,TERM,TYPE,VALUE,WORD,ARGVAL,EXCLUDES
"RTN","XTMRPAR1",76,0)
 ; exclude basic kernel variables
"RTN","XTMRPAR1",77,0)
 S EXCLUDES("DUZ")="",EXCLUDES("DT")="",EXCLUDES("U")="",EXCLUDES("IO")=""
"RTN","XTMRPAR1",78,0)
 F I=0:0 S I=$O(@TAGLOC@(I)) Q:I'>0  D
"RTN","XTMRPAR1",79,0)
 . N ARGS,NEWVAL,WORDS,EXCEPT
"RTN","XTMRPAR1",80,0)
 . S START=@TAGLOC@(I),END=$G(@TAGLOC@(I,"Q"))
"RTN","XTMRPAR1",81,0)
 . F J=START:1:END D
"RTN","XTMRPAR1",82,0)
 . . D EXCEPT(START,END,LOC,"EXCEPT")
"RTN","XTMRPAR1",83,0)
 . . I $D(@LOC@(J,0,"TAG")) F K=0:0 S K=$O(@LOC@(J,0,"TAG","ARG",K)) Q:K'>0  S ARGVAL=@LOC@(J,0,"TAG","ARG",K) I ARGVAL'="" S ARGS(ARGVAL)=""
"RTN","XTMRPAR1",84,0)
 . . F K=0:0 S K=$O(@LOC@(J,K)) Q:K'>0  D
"RTN","XTMRPAR1",85,0)
 . . . S CMDTYPE=$G(@LOC@(J,K,"CMD"))
"RTN","XTMRPAR1",86,0)
 . . . I CMDTYPE="NEW" D  Q
"RTN","XTMRPAR1",87,0)
 . . . . F L=0:0 S L=$O(@LOC@(J,K,"CMD","ARG",L)) Q:L'>0  S ARGVAL=@LOC@(J,K,"CMD","ARG",L) I ARGVAL'="" S NEWVAL(ARGVAL)=""
"RTN","XTMRPAR1",88,0)
 . . . I (CMDTYPE="GO")!(CMDTYPE="DO") D  Q
"RTN","XTMRPAR1",89,0)
 . . . . F L=0:0 S L=$O(@LOC@(J,K,"CMD","ARG",L)) Q:L'>0  S VALUE=@LOC@(J,K,"CMD","ARG",L) D
"RTN","XTMRPAR1",90,0)
 . . . . . ; handle indirection
"RTN","XTMRPAR1",91,0)
 . . . . . I $E(VALUE)="@" S VALUE=$E(VALUE,2,999) D  Q
"RTN","XTMRPAR1",92,0)
 . . . . . . F  Q:VALUE=""  S VALUE=$$GETWORD(VALUE,.WORD,.TERM,.TYPE) I TYPE="WORD" S WORDS(WORD)=""
"RTN","XTMRPAR1",93,0)
 . . . . . . Q
"RTN","XTMRPAR1",94,0)
 . . . . . ; look for arguments inside parentheses
"RTN","XTMRPAR1",95,0)
 . . . . . S VALUE=$P(VALUE,"(",2) D  Q
"RTN","XTMRPAR1",96,0)
 . . . . . . F  Q:VALUE=""  S VALUE=$$GETWORD(VALUE,.WORD,.TERM,.TYPE) I TYPE="WORD" S WORDS(WORD)=""
"RTN","XTMRPAR1",97,0)
 . . . . . . Q
"RTN","XTMRPAR1",98,0)
 . . . . . Q
"RTN","XTMRPAR1",99,0)
 . . . . Q
"RTN","XTMRPAR1",100,0)
 . . . F L=0:0 S L=$O(@LOC@(J,K,"CMD","ARG",L)) Q:L'>0  S VALUE=@LOC@(J,K,"CMD","ARG",L) I VALUE'["$T(",VALUE'["$TEXT(" D  ; modified 4/30/06 to handle $TEXT
"RTN","XTMRPAR1",101,0)
 . . . . F  Q:VALUE=""  S VALUE=$$GETWORD(VALUE,.WORD,.TERM,.TYPE) I TYPE="WORD" S WORDS(WORD)=""
"RTN","XTMRPAR1",102,0)
 . . . . Q
"RTN","XTMRPAR1",103,0)
 . . . Q
"RTN","XTMRPAR1",104,0)
 . . S VALUE="" F  S VALUE=$O(NEWVAL(VALUE)) Q:VALUE=""  K WORDS(VALUE)
"RTN","XTMRPAR1",105,0)
 . . S VALUE="" F  S VALUE=$O(ARGS(VALUE)) Q:VALUE=""  K WORDS(VALUE)
"RTN","XTMRPAR1",106,0)
 . . S VALUE="" F  S VALUE=$O(EXCLUDES(VALUE)) Q:VALUE=""  K WORDS(VALUE)
"RTN","XTMRPAR1",107,0)
 . . S VALUE="" F  S VALUE=$O(EXCEPT(VALUE)) Q:VALUE=""  K WORDS(VALUE)
"RTN","XTMRPAR1",108,0)
 . . M @TAGLOC@(I,"WRDS")=WORDS
"RTN","XTMRPAR1",109,0)
 . . Q
"RTN","XTMRPAR1",110,0)
 . Q
"RTN","XTMRPAR1",111,0)
 Q
"RTN","XTMRPAR1",112,0)
 ;
"RTN","XTMRPAR1",113,0)
GETWORD(LINE,WORD,TERM,TYPE) ;
"RTN","XTMRPAR1",114,0)
 N X,START,DONE,CHAR,TOKEN
"RTN","XTMRPAR1",115,0)
 S WORD="",TYPE="NONE"
"RTN","XTMRPAR1",116,0)
 S TERM=$E(LINE),LINE=$E(LINE,2,999) I $$ISWORD1(TERM) S WORD=WORD_TERM D  Q LINE
"RTN","XTMRPAR1",117,0)
 . S TYPE="WORD"
"RTN","XTMRPAR1",118,0)
 . F  S:LINE="" TERM="" Q:LINE=""  S TERM=$E(LINE),LINE=$E(LINE,2,999) S X=$$ISWORD(TERM) S:X WORD=WORD_TERM I 'X Q
"RTN","XTMRPAR1",119,0)
 . Q
"RTN","XTMRPAR1",120,0)
 ; 101022 HANDLE PATTERN MATCHES
"RTN","XTMRPAR1",121,0)
 I TERM="?" S DONE=0 F  S:LINE="" TERM="" Q:LINE=""  D  I DONE Q
"RTN","XTMRPAR1",122,0)
 . S CHAR=$E(LINE),LINE=$E(LINE,2,$L(LINE))
"RTN","XTMRPAR1",123,0)
 . I CHAR="""" S WORD=WORD_"""",LINE=$$GETQUOTE(LINE,.WORD,.CHAR)
"RTN","XTMRPAR1",124,0)
 . I CHAR="(" S WORD=WORD_"(",LINE=$$GETPAREN(LINE,.WORD,.CHAR)
"RTN","XTMRPAR1",125,0)
 . I ".0123456789ACELNPU""()"'[CHAR S TERM=CHAR,DONE=1
"RTN","XTMRPAR1",126,0)
 . Q
"RTN","XTMRPAR1",127,0)
 I TERM="""" S WORD=TERM,LINE=$$GETQUOTE(LINE,.WORD,.TERM),TYPE="STRING" Q LINE
"RTN","XTMRPAR1",128,0)
 ;
"RTN","XTMRPAR1",129,0)
 I ((TERM=".")&$$ISNUM($E(LINE)))!$$ISNUM(TERM) S WORD=TERM,TYPE="NUMBER" D  Q LINE
"RTN","XTMRPAR1",130,0)
 . F  S:LINE="" TERM="" Q:LINE=""  S TERM=$E(LINE),LINE=$E(LINE,2,999) S X=$$ISNUM1(TERM) S:X WORD=WORD_TERM I 'X Q
"RTN","XTMRPAR1",131,0)
 . Q
"RTN","XTMRPAR1",132,0)
 I TERM="$" S WORD=TERM,TYPE="FUNCTION" S:$E(LINE)="$" WORD="$$",LINE=$E(LINE,2,999) D  Q LINE
"RTN","XTMRPAR1",133,0)
 . S START=1 F  S:LINE="" TERM="" Q:LINE=""  S TERM=$E(LINE),LINE=$E(LINE,2,999) S X=(START&$$ISWORD1(TERM))!$$ISWORD(TERM)!(TERM="^"),START=0 S:X WORD=WORD_TERM S:TERM="^" START=1 I 'X Q
"RTN","XTMRPAR1",134,0)
 . Q
"RTN","XTMRPAR1",135,0)
 I TERM="^",$$ISWORD1($E(LINE)) S WORD=TERM_$E(LINE),LINE=$E(LINE,2,999),TYPE="GLOBAL" D  Q LINE
"RTN","XTMRPAR1",136,0)
 . F  S:LINE="" TERM="" Q:LINE=""  S TERM=$E(LINE),LINE=$E(LINE,2,999) S X=$$ISWORD(TERM) S:X WORD=WORD_TERM I 'X Q
"RTN","XTMRPAR1",137,0)
 . Q
"RTN","XTMRPAR1",138,0)
 ; if a question mark terminates a string, set it to start the next process so pattern matches are handled correctly
"RTN","XTMRPAR1",139,0)
 I TERM="?" S LINE="?"_LINE
"RTN","XTMRPAR1",140,0)
 Q LINE
"RTN","XTMRPAR1",141,0)
 ;
"RTN","XTMRPAR1",142,0)
ISWORD1(CHAR) ; first letter of variable, etc must be alpha or %
"RTN","XTMRPAR1",143,0)
 I "%ABCDEFGHIJKLMNOPQRSTUVWXYZ"[$$UP^XLFSTR(CHAR) Q 1
"RTN","XTMRPAR1",144,0)
 Q 0
"RTN","XTMRPAR1",145,0)
 ;
"RTN","XTMRPAR1",146,0)
ISWORD(CHAR) ; other chars of variable, etc must be alpha or numeric
"RTN","XTMRPAR1",147,0)
 I "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"[$$UP^XLFSTR(CHAR) Q 1
"RTN","XTMRPAR1",148,0)
 Q 0
"RTN","XTMRPAR1",149,0)
 ;
"RTN","XTMRPAR1",150,0)
ISNUM(CHAR) ;  need to add in proper handling of decimal point.
"RTN","XTMRPAR1",151,0)
 I "0123456789"[CHAR Q 1
"RTN","XTMRPAR1",152,0)
 Q 0
"RTN","XTMRPAR1",153,0)
 ;
"RTN","XTMRPAR1",154,0)
ISNUM1(CHAR) ;
"RTN","XTMRPAR1",155,0)
 I (CHAR=".")!$$ISNUM(CHAR) Q 1
"RTN","XTMRPAR1",156,0)
 Q 0
"RTN","XTMRPAR1",157,0)
 ;
"RTN","XTMRPAR1",158,0)
PARSLINE(LINE,LINENUM,LOC) ;
"RTN","XTMRPAR1",159,0)
 N ARGNUM,INDNTCNT S ARGNUM=0,INDNTCNT=0
"RTN","XTMRPAR1",160,0)
 I $E(LINE,1)'=" " S LINE=$$SETTAG(LINE,LINENUM,LOC)
"RTN","XTMRPAR1",161,0)
 F  Q:($E(LINE,1)'=" ")&($E(LINE,1)'=".")  S:$E(LINE,1)=" " LINE=$E(LINE,2,999) I $E(LINE,1)="." S LINE=$E(LINE,2,999),INDNTCNT=INDNTCNT+1,@LOC@(LINENUM,0,"INDENT")=INDNTCNT
"RTN","XTMRPAR1",162,0)
 F  Q:LINE=""  S LINE=$$GETCMD(LINE,LINENUM,.ARGNUM,LOC)
"RTN","XTMRPAR1",163,0)
 Q
"RTN","XTMRPAR1",164,0)
 ;
"RTN","XTMRPAR1",165,0)
GETPAREN(LINE,VALUE,TERM) ;
"RTN","XTMRPAR1",166,0)
 Q $$GETPAREN^XTMRPAR2(LINE,.VALUE,.TERM)
"RTN","XTMRPAR1",167,0)
 ;
"RTN","XTMRPAR1",168,0)
GETARGS(LINE,LOCSTOR,SUBSCRPT) ;
"RTN","XTMRPAR1",169,0)
 Q $$GETARGS^XTMRPAR2(LINE,LOCSTOR,$G(SUBSCRPT))
"RTN","XTMRPAR1",170,0)
 ;
"RTN","XTMRPAR1",171,0)
ARGLIST(LINE,ARGVALUE,TERM) ;
"RTN","XTMRPAR1",172,0)
 Q $$ARGLIST^XTMRPAR2(LINE,.ARGVALUE,.TERM)
"RTN","XTMRPAR1",173,0)
 ;
"RTN","XTMRPAR1",174,0)
GETCMD(LINE,LINENUM,ARGNUM,LOCSTOR) ;
"RTN","XTMRPAR1",175,0)
 Q $$GETCMD^XTMRPAR2(LINE,LINENUM,.ARGNUM,LOCSTOR)
"RTN","XTMRPAR1",176,0)
 ;
"RTN","XTMRPAR1",177,0)
GETTAGS(LOC,TAGLOC) ;
"RTN","XTMRPAR1",178,0)
 D GETTAGS^XTMRPAR2(LOC,TAGLOC)
"RTN","XTMRPAR1",179,0)
 Q
"RTN","XTMRPAR1",180,0)
 ;
"RTN","XTMRPAR1",181,0)
LOAD(ROU,GLOB) ;
"RTN","XTMRPAR1",182,0)
 D LOAD^XTMRPAR2(ROU,GLOB)
"RTN","XTMRPAR1",183,0)
 Q
"RTN","XTMRPAR1",184,0)
 ;
"RTN","XTMRPAR1",185,0)
SETTAG(LINE,LINENUM,STORLOC) ;
"RTN","XTMRPAR1",186,0)
 Q $$SETTAG^XTMRPAR2(LINE,LINENUM,STORLOC)
"RTN","XTMRPAR1",187,0)
 ;
"RTN","XTMRPAR1",188,0)
EXCEPT(STRTLINE,ENDLINE,LOC,TAGLOC) ;
"RTN","XTMRPAR1",189,0)
 N I,J,K,LINE,WORD,TERM,XXX
"RTN","XTMRPAR1",190,0)
 F I=STRTLINE:1:ENDLINE F J=1:1 Q:'$D(@LOC@(I,J))  S LINE=$G(@LOC@(I,J,"COMMENT")) I LINE["ZEXCEPT:" D
"RTN","XTMRPAR1",191,0)
 . S LINE=$P(LINE,"ZEXCEPT:",2) F  Q:LINE=""  Q:$E(LINE)'=" "  S LINE=$E(LINE,2,999)
"RTN","XTMRPAR1",192,0)
 . S LINE=$$GETARGS(LINE,"XXX") F K=0:0 S K=$O(XXX("ARG",K)) Q:K'>0  S @TAGLOC@(XXX("ARG",K))=""
"RTN","XTMRPAR1",193,0)
 . Q
"RTN","XTMRPAR1",194,0)
 Q
"RTN","XTMRPAR1",195,0)
 ;
"RTN","XTMRPAR1",196,0)
MARKERR(TEXT) ;
"RTN","XTMRPAR1",197,0)
 D MARKERR^XTMRPAR2(TEXT)
"RTN","XTMRPAR1",198,0)
 Q
"RTN","XTMRPAR1",199,0)
 ;
"RTN","XTMRPAR1",200,0)
NEXTTOKN(LINE,TOKEN,TERM,TERMCHRS) ;
"RTN","XTMRPAR1",201,0)
 Q $$NEXTTOKN^XTMRPAR2(LINE,.TOKEN,.TERM,$G(TERMCHRS))
"RTN","XTMRPAR1",202,0)
 ;
"RTN","XTMRPAR1",203,0)
GETQUOTE(LINE,TOKEN,TERM) ;
"RTN","XTMRPAR1",204,0)
 Q $$GETQUOTE^XTMRPAR2(LINE,.TOKEN,.TERM)
"RTN","XTMRPAR1",205,0)
 ;
"RTN","XTMRPAR1",206,0)
 ;
"RTN","XTMRPAR2")
0^5^B36584102
"RTN","XTMRPAR2",1,0)
XTMRPAR2 ;FO-OAK/JLI - list tags, find variables that aren't arguments or newed - continued ;10/28/10  16:28
"RTN","XTMRPAR2",2,0)
 ;;7.3;TOOLKIT;**101**;Apr 25, 1995;Build 32
"RTN","XTMRPAR2",3,0)
 ;;Per VHA Directive 2004-038, this routine should not be modified
"RTN","XTMRPAR2",4,0)
 ; 101021 fixed a problem in ARGLIST where parentheses and quotes were not completed to the closing member
"RTN","XTMRPAR2",5,0)
 Q
"RTN","XTMRPAR2",6,0)
 ;
"RTN","XTMRPAR2",7,0)
GETPAREN(LINE,VALUE,TERM) ;
"RTN","XTMRPAR2",8,0)
 N ARGCNT,ARGVAL,PARENCNT,TOKEN
"RTN","XTMRPAR2",9,0)
 S PARENCNT=1,ARGCNT=0,ARGVAL=TERM,TERM=""
"RTN","XTMRPAR2",10,0)
 F  S ARGVAL=ARGVAL_TERM Q:(PARENCNT=0)&((TERM=",")!(TERM=")"))  Q:LINE=""  D
"RTN","XTMRPAR2",11,0)
 . S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM) S ARGVAL=ARGVAL_TOKEN S:TERM="(" PARENCNT=PARENCNT+1 S:TERM=")" PARENCNT=PARENCNT-1
"RTN","XTMRPAR2",12,0)
 . Q
"RTN","XTMRPAR2",13,0)
 S VALUE=ARGVAL
"RTN","XTMRPAR2",14,0)
 Q LINE
"RTN","XTMRPAR2",15,0)
 ;
"RTN","XTMRPAR2",16,0)
GETARGS(LINE,LOCSTOR,SUBSCRPT) ;
"RTN","XTMRPAR2",17,0)
 N TOKEN,TERM,ARGCNT S TERM="1",ARGCNT=0
"RTN","XTMRPAR2",18,0)
 S SUBSCRPT=$G(SUBSCRPT) S:SUBSCRPT="" SUBSCRPT="ARG"
"RTN","XTMRPAR2",19,0)
 F  Q:(TERM=" ")!(TERM="")  S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM) D
"RTN","XTMRPAR2",20,0)
 . S ARGCNT=ARGCNT+1,LINE=$$ARGLIST(LINE,.TOKEN,.TERM)
"RTN","XTMRPAR2",21,0)
 . S @LOCSTOR@(SUBSCRPT,ARGCNT)=TOKEN I TERM=":" S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM) S @LOCSTOR@(SUBSCRPT,ARGCNT,"COND")=TOKEN I TERM
"RTN","XTMRPAR2",22,0)
 . Q
"RTN","XTMRPAR2",23,0)
 Q LINE
"RTN","XTMRPAR2",24,0)
 ;
"RTN","XTMRPAR2",25,0)
ARGLIST(LINE,ARGVALUE,TERM) ;
"RTN","XTMRPAR2",26,0)
 N TOKEN
"RTN","XTMRPAR2",27,0)
 S ARGVALUE=$G(ARGVALUE)
"RTN","XTMRPAR2",28,0)
 I (TERM=" ")!(TERM=",")!(TERM="") Q LINE
"RTN","XTMRPAR2",29,0)
 ;
"RTN","XTMRPAR2",30,0)
 I TERM="(" D
"RTN","XTMRPAR2",31,0)
 . S LINE=$$GETPAREN(LINE,.TOKEN,.TERM)
"RTN","XTMRPAR2",32,0)
 . S ARGVALUE=ARGVALUE_TOKEN
"RTN","XTMRPAR2",33,0)
 . ; 101021 commented out following, replaced with new code to handle text following ( and " characters correctly
"RTN","XTMRPAR2",34,0)
 . ;F  Q:LINE=""  S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM) S ARGVALUE=ARGVALUE_TOKEN Q:(TERM=",")!(TERM=" ")!(TERM="")!(TERM="$")!(TERM=":")  S ARGVALUE=ARGVALUE_TERM
"RTN","XTMRPAR2",35,0)
 . F  Q:LINE=""  S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM)  S ARGVALUE=ARGVALUE_TOKEN D:"("""[TERM  Q:(TERM=",")!(TERM=" ")!(TERM="")!(TERM="$")!(TERM=":")  S ARGVALUE=ARGVALUE_TERM
"RTN","XTMRPAR2",36,0)
 . . N THISTERM
"RTN","XTMRPAR2",37,0)
 . . S THISTERM=TERM
"RTN","XTMRPAR2",38,0)
 . . S ARGVALUE=ARGVALUE_TERM
"RTN","XTMRPAR2",39,0)
 . . I THISTERM="""" S LINE=$$GETQUOTE(LINE,.TOKEN,.TERM)
"RTN","XTMRPAR2",40,0)
 . . I THISTERM="(" S TERM="",LINE=$$GETPAREN(LINE,.TOKEN,.TERM) I TERM=")" S TOKEN=$E(TOKEN,1,$L(TOKEN)-1)
"RTN","XTMRPAR2",41,0)
 . . S ARGVALUE=ARGVALUE_TOKEN
"RTN","XTMRPAR2",42,0)
 . . Q
"RTN","XTMRPAR2",43,0)
 . ; end of 101021 insertion
"RTN","XTMRPAR2",44,0)
 . Q
"RTN","XTMRPAR2",45,0)
 I TERM="$" S ARGVALUE=ARGVALUE_TERM D
"RTN","XTMRPAR2",46,0)
 . F  Q:LINE=""  S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM) S ARGVALUE=ARGVALUE_TOKEN Q:(TERM=",")!(TERM=" ")!(TERM="")  S ARGVALUE=ARGVALUE_TERM
"RTN","XTMRPAR2",47,0)
 . Q
"RTN","XTMRPAR2",48,0)
 Q LINE
"RTN","XTMRPAR2",49,0)
 ;
"RTN","XTMRPAR2",50,0)
GETCMD(LINE,LINENUM,ARGNUM,LOCSTOR) ;
"RTN","XTMRPAR2",51,0)
 N CMD,TOKEN,TERM,CONDNUM,I,LIST1,LIST2
"RTN","XTMRPAR2",52,0)
 F  Q:$E(LINE,1)'=" "  S LINE=$E(LINE,2,$L(LINE))
"RTN","XTMRPAR2",53,0)
 I $E(LINE,1)=";" S ARGNUM=ARGNUM+1,@LOCSTOR@(LINENUM,ARGNUM,"COMMENT")=LINE,LINE="" Q LINE
"RTN","XTMRPAR2",54,0)
 S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM),CMD=""
"RTN","XTMRPAR2",55,0)
 S LIST1="A^B^C^D^E^F^G^H^I^J^K^L^M^N^O^P^Q^R^S^T^U^V^W^X^Y^Z"
"RTN","XTMRPAR2",56,0)
 S LIST2="A^BREAK^C^DO^ELSE^FOR^GO^HALT^IF^JOB^KILL^LOCK^MERGE^NEW^OPEN^P^QUIT^READ^SET^T^USE^V^WRITE^X^Y^Z"
"RTN","XTMRPAR2",57,0)
 F I=1:1:$L(LIST1,U) I TOKEN=$P(LIST1,U,I) S CMD=$P(LIST2,U,I)
"RTN","XTMRPAR2",58,0)
 I CMD="" I U_LIST2_U[U_TOKEN_U S CMD=TOKEN
"RTN","XTMRPAR2",59,0)
 I CMD="" S CMD="UNKNOWN - "_TOKEN
"RTN","XTMRPAR2",60,0)
 S ARGNUM=ARGNUM+1
"RTN","XTMRPAR2",61,0)
 S @LOCSTOR@(LINENUM,ARGNUM,"CMD")=CMD
"RTN","XTMRPAR2",62,0)
 I TERM=":" S CONDNUM=1 S LINE=$$GETARGS(LINE,$NA(@LOCSTOR@(LINENUM,ARGNUM,"CMD")),"COND") S TERM="" I LINE'="" S TERM=" "
"RTN","XTMRPAR2",63,0)
 I TERM=" " S LINE=$$GETARGS(LINE,$NA(@LOCSTOR@(LINENUM,ARGNUM,"CMD")))
"RTN","XTMRPAR2",64,0)
 I TERM=";" S @LOCSTOR@(LINENUM,ARGNUM,"COMMENT")=TERM_LINE S LINE=""
"RTN","XTMRPAR2",65,0)
 Q LINE
"RTN","XTMRPAR2",66,0)
 ;
"RTN","XTMRPAR2",67,0)
GETTAGS(LOC,TAGLOC) ;
"RTN","XTMRPAR2",68,0)
 N I,NTAGS,J,X S NTAGS=0
"RTN","XTMRPAR2",69,0)
 F I=0:0 S I=$O(@LOC@(I)) Q:I'>0  I $D(@LOC@(I,0,"TAG")) D
"RTN","XTMRPAR2",70,0)
 . I NTAGS>0,$G(@TAGLOC@(NTAGS,"Q"))>0,I'>@TAGLOC@(NTAGS,"Q") Q  ; skip non-entry tags
"RTN","XTMRPAR2",71,0)
 . S NTAGS=NTAGS+1,@TAGLOC@(NTAGS)=I,@TAGLOC@(NTAGS,"NAME")=@LOC@(I,0,"TAG")
"RTN","XTMRPAR2",72,0)
 . F J=I:0 S J=$O(@LOC@(J)) Q:J'>0  S X=$G(@LOC@(J,1,"CMD")) I ((X="GO")!(X="QUIT")!(X="G")!(X="Q")),'$D(@LOC@(J,1,"CMD","COND")),'$D(@LOC@(J,2,"CMD")),'$D(@LOC@(J,0,"INDENT")) S @TAGLOC@(NTAGS,"Q")=J Q
"RTN","XTMRPAR2",73,0)
 Q
"RTN","XTMRPAR2",74,0)
 ;
"RTN","XTMRPAR2",75,0)
LOAD(ROU,GLOB) ;
"RTN","XTMRPAR2",76,0)
 N X,XCNP,DIF
"RTN","XTMRPAR2",77,0)
 K @GLOB
"RTN","XTMRPAR2",78,0)
 S X=ROU,XCNP=0,DIF=$E(GLOB,1,$L(GLOB)-1)_"," X ^%ZOSF("LOAD")
"RTN","XTMRPAR2",79,0)
 F X=0:0 S X=$O(@GLOB@(X)) Q:X'>0  S DIF=X
"RTN","XTMRPAR2",80,0)
 S @GLOB@(DIF+1,0)=" Q" ; make sure a quit is at the bottom
"RTN","XTMRPAR2",81,0)
 Q
"RTN","XTMRPAR2",82,0)
 ;
"RTN","XTMRPAR2",83,0)
SETTAG(LINE,LINENUM,STORLOC) ;
"RTN","XTMRPAR2",84,0)
 ; added corrections for infinite loop if parens are unmatched on TAG 090720
"RTN","XTMRPAR2",85,0)
 N TERM,TOKEN
"RTN","XTMRPAR2",86,0)
 S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM)
"RTN","XTMRPAR2",87,0)
 S @STORLOC@(LINENUM,0,"TAG")=TOKEN I TERM=" " Q LINE
"RTN","XTMRPAR2",88,0)
 I TERM'="(" D MARKERR("Bad char following TAG at line "_LINENUM) Q LINE
"RTN","XTMRPAR2",89,0)
 I LINE="" D MARKERR("No args following open paren at line "_LINENUM) Q LINE ; 090720
"RTN","XTMRPAR2",90,0)
 N ARGCNT,ARGVAL,PARENCNT S PARENCNT=0,ARGCNT=0,ARGVAL=""
"RTN","XTMRPAR2",91,0)
 ;F  S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM) S ARGCNT=ARGCNT+1 D  S @STORLOC@(LINENUM,0,"TAG","ARG",ARGCNT)=ARGVAL,ARGVAL="" Q:TERM=")" ; JLI replaced by next line 090720
"RTN","XTMRPAR2",92,0)
 F  S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM) S ARGCNT=ARGCNT+1 D  Q:TERM=""  S @STORLOC@(LINENUM,0,"TAG","ARG",ARGCNT)=ARGVAL,ARGVAL="" Q:TERM=")"  ; JLI 090720
"RTN","XTMRPAR2",93,0)
 . I TERM="" D MARKERR("Unmatched Paren following TAG at line "_LINENUM) S ARGCNT=ARGCNT-1 Q  ; JLI 090720
"RTN","XTMRPAR2",94,0)
 . S ARGVAL=ARGVAL_TOKEN
"RTN","XTMRPAR2",95,0)
 . F  Q:(PARENCNT=0)&((TERM=",")!(TERM=")"))  S:TERM="(" PARENCNT=PARENCNT+1 S:TERM=")" PARENCNT=PARENCNT-1 S ARGVAL=ARGVAL_TERM Q:LINE=""  S LINE=$$NEXTTOKN(LINE,.TOKEN,.TERM) S ARGVAL=ARGVAL_TOKEN
"RTN","XTMRPAR2",96,0)
 Q LINE
"RTN","XTMRPAR2",97,0)
 ;
"RTN","XTMRPAR2",98,0)
MARKERR(TEXT) ;
"RTN","XTMRPAR2",99,0)
 W !,TEXT
"RTN","XTMRPAR2",100,0)
 Q
"RTN","XTMRPAR2",101,0)
 ;
"RTN","XTMRPAR2",102,0)
NEXTTOKN(LINE,TOKEN,TERM,TERMCHRS) ;
"RTN","XTMRPAR2",103,0)
 ; modified 4/10/08 to add TERMCHRS as an OPTIONAL input variable,
"RTN","XTMRPAR2",104,0)
 ;   if present it specifies the list of possible terminating characters
"RTN","XTMRPAR2",105,0)
 N DONE,CHAR,PARENS,READY
"RTN","XTMRPAR2",106,0)
 S:$G(TERMCHRS)="" TERMCHRS=" ,:()"
"RTN","XTMRPAR2",107,0)
 S TOKEN="",TERM="",PARENS=0
"RTN","XTMRPAR2",108,0)
 F  Q:LINE=""  S READY=1,CHAR=$E(LINE,1),LINE=$E(LINE,2,999) D  I PARENS=0,READY,TERMCHRS[CHAR S TERM=CHAR Q
"RTN","XTMRPAR2",109,0)
 . I '((CHAR=")")&(PARENS>0)) Q:TERMCHRS[CHAR
"RTN","XTMRPAR2",110,0)
 . ;I CHAR="(" S PARENS=PARENS+1
"RTN","XTMRPAR2",111,0)
 . ;I CHAR=")" S PARENS=PARENS-1,READY=0
"RTN","XTMRPAR2",112,0)
 . S TOKEN=TOKEN_CHAR
"RTN","XTMRPAR2",113,0)
 . I CHAR="""" S LINE=$$GETQUOTE(LINE,.TOKEN,.CHAR) I TERMCHRS'[CHAR S TOKEN=TOKEN_CHAR
"RTN","XTMRPAR2",114,0)
 . Q
"RTN","XTMRPAR2",115,0)
 Q LINE
"RTN","XTMRPAR2",116,0)
 ;
"RTN","XTMRPAR2",117,0)
GETQUOTE(LINE,TOKEN,TERM) ;
"RTN","XTMRPAR2",118,0)
 N CHAR,DONE
"RTN","XTMRPAR2",119,0)
 F  Q:LINE=""  S CHAR=$E(LINE,1),LINE=$E(LINE,2,999),TOKEN=TOKEN_CHAR I CHAR="""" D  I DONE Q
"RTN","XTMRPAR2",120,0)
 . ; following 2 lines retracted after problems
"RTN","XTMRPAR2",121,0)
 . ;I $E(LINE,1)="""" S TOKEN=TOKEN_CHAR,LINE=$E(LINE,2,$L(LINE)) Q
"RTN","XTMRPAR2",122,0)
 . ;S TERM=$E(LINE,1),LINE=$E(2,$L(LINE)),DONE=1
"RTN","XTMRPAR2",123,0)
 . S TERM=$E(LINE,1),LINE=$E(LINE,2,999),DONE=1
"RTN","XTMRPAR2",124,0)
 . I TERM="""" S TOKEN=TOKEN_TERM,DONE=0
"RTN","XTMRPAR2",125,0)
 . Q
"RTN","XTMRPAR2",126,0)
 Q LINE
"RTN","XTMRPAR2",127,0)
 ;
"RTN","XTMRPAR2",128,0)
 ;
"VER")
8.0^22.0
**END**
**END**
