source: FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XINDX4.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1XINDX4 ;ISC/REL,GRK - PROCESS DO, GO TO, WRITE & FOR COMMANDS ;10/30/2003 15:07
2 ;;7.3;TOOLKIT;**20,61,68**;Apr 25, 1995
3DG1 I ARG="" S:'IND("DO1") IND("DO")=IND("DO")+1,IND("DO1")=1 Q
4DG S (LBL,PGM,OFF,PRM)="",S=1,L="+^:," S:$E(ARG,1,2)="@^" S=3
5 D LOOP S LBL=$E(ARG,1,I-1)
6 I CH="+" S (J,S)=I+1,ERR=30 D ^XINDX1:$E(ARG)'="@" S:$E(ARG,I)="^" S=I+1 D LOOP S OFF=$E(ARG,J,I-1) I OFF'?.N S GRB=GRB_$C(9)_OFF
7 I CH="^" S S=I+1 D LOOP S PGM=$E(ARG,S,I-1)
8 I CH=":" S S=I+1,L="," D LOOP S S=$E(ARG,S,I-1) I S'="" S GRB=GRB_$C(9)_S
9 S ARG=$E(ARG,I+1,999)
10 I $E(LBL)="@" S GRB=GRB_$C(9)_$E(LBL,2,999),LBL="@("
11 I $E(PGM)="@" S GRB=GRB_$C(9)_$E(PGM,2,999),PGM="@("
12 I LBL[")" S PRM=$$INSIDE(LBL,"(",")"),LBL=$P(LBL,"(")
13 I PGM[")" S PRM=$$INSIDE(PGM,"(",")"),PGM=$P(PGM,"(")
14 I PRM]"" S GRB=GRB_$C(9)_$$PRUNE($$CNG(PRM,",,",","),",") ;strip null parameters
15 S:OFF'="" LBL=LBL_"+"_OFF
16 S S="",LOC="I" I PGM'="" S S=PGM_" ",LOC="X"
17 S:LBL_PGM["&" LOC="X"
18 S:LBL'="" S=S_LBL I S'="" D ST
19 G:ARG'="" DG K LBL,PGM,OFF,PRM Q
20LOOP F I=S:1 S CH=$E(ARG,I) D QUOTE:CH=Q,PAREN:CH="(",ERRCP:CH=")" Q:L[CH
21 Q
22PAREN S PC=1
23 F I=I+1:1 S CH=$E(ARG,I) Q:PC=0!(CH="") I "()"""[CH D QUOTE:CH=Q S PC=PC+$S("("[CH:1,")"[CH:-1,1:0)
24 S ERR=5 D:PC ^XINDX1 Q
25QUOTE F I=I+1:1 S CH=$E(ARG,I) Q:CH=""!(CH=Q)
26 I CH="" S ERR=6 G ^XINDX1
27 Q
28ST S R=$F(S,"(") S:R>1 S=$E(S,1,R-1) S:"IX"[LOC IND("COM")=IND("COM")_","_S
29 S:'$D(V(LOC,S)) V(LOC,S)="" S:LOC="L"&(V(LOC,S)'["*") V(LOC,S)=V(LOC,S)_"*" Q
30 Q
31FR Q:$E(ARG,1)="@" S S=2,L="=" D LOOP I CH="" S ERR=8 G ^XINDX1
32 S GK="*",STR=$E(ARG,1,I-1),ARG=$E(ARG,I+1,999) D ARGG^XINDX2
33 Q
34WR N S0,WR S STR=ARG,WR="#!,",S0="" ;Need to handle /controlmnemonic
35 D ^XINDX9 S ARG=""
36 F D INC^XINDX2 Q:S="" D S S0=S
37 . I S="?" D:","[S1 E^XINDX1(49) Q
38 . I S="!",WR'[$E(S0),S1="!" D E^XINDX1(49) Q
39 . D ARG^XINDX2
40 . Q
41 Q
42ERRCP S ERR=5 D ^XINDX1 Q
43SET S ARG=$E(ARG,1,I-1)_","_$E(ARG,I+1,999) Q
44XE S GRB=GRB_$C(9)_ARG,ARG="" Q
45REP S L=",:",S=1 D LOOP I CH=":" S ARG=$E(ARG,I+1,999),L="," D LOOP
46 S ARG=$E(ARG,I+1,999) Q:ARG="" G REP
47 ;
48ZC I "ILRS"'[$E(CM,2)!($E(CM,2)="") S ARG="" Q ;Zcommands
49 S COM=$E(CM,1,2) Q:CM="ZI" G:CM="ZR" ZR
50U1 S L=",",S=1 D LOOP S S=$E(ARG,1,I-1),ARG=$E(ARG,I+1,999)
51 S:$E(S,1)="@" S=$E(S,2,999),GRB=GRB_$C(9)_S Q:ARG="" G U1
52ZR Q:ARG="" S L=":,",S=1 D LOOP S S=$E(ARG,1,I-1),ARG=$E(ARG,I+1,999)
53 I $E(S,1)="@" S GRB=GRB_$C(9)_S G ZR
54 S:S["+" GRB=GRB_$C(9)_$P(S,"+",2,999) G ZR
55LO S GRB=GRB_$C(9)_ARG,ARG=""
56 Q
57Q ;QUIT
58 ;D SEP(LIN," ",.S) I $E(S(1),1)=";" S S=0 ;Check for comments
59 ;I IND("PP") S ERR=$S($E(ARG)=";":49,ARG?1A&(S>1):9,1:0) D:ERR ^XINDX1 Q
60 ;Q:($L(ARG)>1&(S<2))!(S=0) ;
61 I $E(ARG)=";" S ARG="",ERR=9 G ^XINDX1 ;Quit followed by a comment
62 ;I ARG?1A&(S>1) S LIN=ARG_" "_LIN,ARG="",ERR=9 G ^XINDX1
63 ;S ERR=9 G:ERR ^XINDX1
64 Q
65PT(X) ;Tag for parameter passing
66 S ^UTILITY($J,1,RTN,"P",LAB)=X Q
67PC ;Parameter passing call
68 N LOC S LOC="P" D ST
69 Q
70INSIDE(X,X1,X2) ;Return the data inside the param x1,x2
71 S J=$L(X,X2)-1,J=$S(J<1:1,1:J)
72 Q $P($P(X,X2,1,J),X1,2,99)
73SEP(ST,SP,RV) ;String,Separters,Return array)
74 N %,N
75 F N=1:1 S %=$E(ST,N) D SQT:%=Q Q:SP[%
76 S RV=N-1,RV(1)=$E(ST,1,N) Q
77SQT F N=N+1:1 Q:Q[$E(ST,N)
78 Q
79CNG(S1,S2,S3) ;String,replace,with
80 ;
81 F Q:S1'[S2 S S1=$P(S1,S2)_S3_$P(S1,S2,2,999)
82 Q S1
83PRUNE(S1,S2) ;String,prune char from front and back
84 F Q:$E(S1)'=S2 S S1=$E(S1,2,999)
85 F Q:$E(S1,$L(S1))'=S2 S S1=$E(S1,1,$L(S1)-1)
86 Q S1
Note: See TracBrowser for help on using the repository browser.