source: IHS-VA_UTILITIES-XB/trunk/XBGL.m@ 1251

Last change on this file since 1251 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.

File size: 2.4 KB
Line 
1XBGL ;IHS/ITSC/DMJ - GLOBAL LISTER [ 03/17/2005 10:46 AM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3START ;START HERE
4 K XB,DIR W ! S $Y=1
5 S DIR(0)="FAO^1:80",DIR("A")="Global: ^" D ^DIR K DIR
6 I Y=""!(Y="^") W ! K DIR Q
7 I Y[",,"!(Y["(,") W *7,!!,"Use '*' for wildcard.",! G START
8 I $E(Y,1)'="^" S Y="^"_Y
9 I $L(Y,"(")=2,$P(Y,"(",2)']"" S Y=$P(Y,"(",1)
10 S (XB("Y"),XB("IN"))=Y
11 S XB("RB")=$P(XB("IN"),"(",1)
12I1 ;SET UP INPUT FOR COMPARISON
13 I XB("IN")["(" D
14 .S (XB("LP"),XB("RP"))=0 F I=1:1:$L(XB("IN")) S:$E(XB("IN"),I)="(" XB("LP")=XB("LP")+1 S:$E(XB("IN"),I)=")" XB("RP")=XB("RP")+1
15 .S XB("X")="",XB("Z")=""
16 .S XB("IS")=$P(XB("IN"),"(",2,999)
17 .I $E(XB("IS"),$L(XB("IS")))=")",XB("LP")=XB("RP") S XB("IS")=$E(XB("IS"),1,$L(XB("IS"))-1)
18 .F I=1:1:$L(XB("IS"),",") D
19 ..S XB("I"_I)=$P(XB("IS"),",",I) Q:XB("I"_I)=""
20 ..S X="ER2",@^%ZOSF("TRAP") I 'XB("I"_I),XB("I"_I)'=0,XB("I"_I)'="*",$E(XB("I"_I),1)'=$C(34) D
21 ...I $E(XB("I"_I),$L(XB("I"_I)))=":" S XB("I"_I)=$E(XB("I"_I),1,$L(XB("I"_I))-1),XB("F3")=1
22 ...S XB("I"_I)=@XB("I"_I)
23 ...I $G(XB("F3")) S XB("I"_I)=XB("I"_I)_":",XB("F3")=0
24 ..S $P(XB("X"),",",I)=XB("I"_I),$P(XB("Z"),",",I)=XB("I"_I)
25 ..I XB("I"_I)="*" S $P(XB("X"),",",I)="0"
26 ..I $E(XB("I"_I),$L(XB("I"_I)))=":" S $P(XB("Z"),",",I)="*",$P(XB("X"),",",I)=$E(XB("I"_I),1,$L(XB("I"_I))-1),XB("I"_I)="*"
27 .S XB("IN")=XB("RB")_"("_XB("Z")_$S($E(Y,$L(Y))=")"&(XB("RP")=XB("LP")):")",1:""),XB("I")=$L(XB("Z"),",")
28 .S XB("Y")=XB("RB")_"("_XB("X")_")"
29FIRST ;INITIAL ENTRY
30 S X="ER1",@^%ZOSF("TRAP")
31 I XB("IN")[")",XB("IN")'["*" S XB("F1")=1
32 I $D(@XB("Y"))#2 D DISP I $G(XB("OUT")) G START
33LOOP ;LOOP HERE
34 S X="ER2",@^%ZOSF("TRAP")
35 F S XB("Y")=$Q(@(XB("Y"))) D MATCH Q:$G(XB("F1")) D DISP I $G(XB("OUT")) G START
36 G START
37ER1 ;FIRST ERROR CONDITION
38 G LOOP
39ER2 ;SECOND ERROR CONDITION
40 W *7,!!,"??",! G START
41MATCH ;DECIPHER INPUT
42 I XB("Y")="" S XB("F1")=1 Q
43 I $P(XB("IN"),"(",2)']"" Q
44 S XB("F2")=0
45 S XB("SB")=$P(XB("Y"),"(",2),XB("SB")=$E(XB("SB"),1,$L(XB("SB"))-1),XB("S")=$L(XB("SB"),",")
46 I $E(XB("IN"),$L(XB("IN")))=")",XB("S")'=XB("I") S XB("F2")=1 Q
47 S XB("*")=0 F I=1:1:XB("I") D
48 .I XB("I"_I)="*" S XB("*")=XB("*")+1 Q
49 .S XB("S"_I)=$P(XB("SB"),",",I)
50 .I XB("I"_I)'=XB("S"_I) D
51 ..S XB("F2")=1
52 ..I 'XB("*") S XB("F1")=1
53 ..I XB("IN")'["*" S XB("F1")=1
54 Q
55DISP ;OUTPUT
56 Q:$G(XB("F2"))
57 S XB("=")=@(XB("Y"))
58 W !,XB("Y")," = ",XB("=")
59 I $Y>20 D
60 .S DIR(0)="E" D ^DIR K DIR
61 .I 'Y S XB("OUT")=1 Q
62 .W @IOF
63 Q
Note: See TracBrowser for help on using the repository browser.