ACGSIMP1 ;IHS/OIRM/DSD/THL,AEF - CON'T OF ACGSIMP1 SETS LOCAL VARIABLES [ 03/27/2000 2:22 PM ]
;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
D 2,5,8,9,10,11,13,23,28,34,37,53 Q
1 S ACG1=$E(ACGX),ACG1=$S(ACG1="":"",$D(^ACGTPA("B",ACG1)):$O(^ACGTPA("B",ACG1,0)),1:"")
2 S ACG=$E(ACGX,2,16) D S S ACGX2=ACG Q ;S:'ACG ACG=$E(ACGX,17,19)_$E(ACG,4,99) S ACG2=ACG,ACGCO=$E(ACG,1,3)_"00000"
3 S ACG=$E(ACGX,17,28) D S S ACG3=ACG
4 S ACG=$E(ACGX,29,31) D S S ACG4=ACG
5 S ACG=$E(ACGX,32,71) D S S ACGX5=$E(ACG,1,30),ACG5DA="" Q
6 S ACG=$E(ACGX,72,101) D S S ACG6=ACG
7 S ACG=$E(ACGX,102,124) D S S ACG7=ACG,ACG7DA=""
8 S ACG=$E(ACGX,125,143) D S S (ACGX8,ACGSTATE)=ACG Q ;D STATE S ACG8NAM=ACGSTNAM,ACG8=ACGSTDA,ACG8CD=ACGSTCD
9 S ACG=$E(ACGX,144,148) D S S ACGX9=ACG Q
10 S ACG=$E(ACGX,149,151) D S S ACGX10=ACG Q
11 S ACG=$E(ACGX,152,163) D S S ACGX11=ACG Q ;,ACG11SUF=$E(ACG11,11,12),ACG11=$E(ACG11,1,10)
12 S ACG12=$E(ACGX,164),ACG12=$S(ACG12'=" ":ACG12,1:"")
13 S ACG13=$E(ACGX,165,166),ACGX13=$S(ACG13="":"",$D(^AUTTTOB("B",ACG13)):$O(^AUTTTOB("B",ACG13,0)),1:"")
14 S ACG=$E(ACGX,167,168) D S S ACG14=ACG
15 S ACGX15=$E(ACGX,169,170) Q ;,ACG15=$S(ACG15="":"",$D(^ACGTOC("B",ACG15)):$O(^(ACG15,0)),1:"")
16 S ACG16=$E(ACGX,171),ACG16=$S(ACG16'=" ":ACG16,1:"")
17 S ACGX17=$E(ACGX,172,173) Q ;,ACG17=$S(ACG17="":"",$D(^ACGSP("B",ACG17)):$O(^(ACG17,0)),1:"")
18 S ACGX18=$E(ACGX,174,175) S:'ACGX18 ACGX18="" Q ;,ACG18=$S(ACG18="":"",$D(^ACGFAO("B",ACG18)):$O(^(ACG18,0)),1:"")
19 S ACGX19=$E(ACGX,176,177) Q ;,ACG19=$S(ACG19="":"",$D(^ACGEOC("B",ACG19)):$O(^(ACG19,0)),1:"")
20 S ACGX20=$E(ACGX,178) Q ;,ACG20=$S(ACG20="":"",$D(^ACGMOC("B",ACG20)):$O(^(ACG20,0)),1:"")
21 S ACG21=+$E(ACGX,179,180)
22 S ACG=$E(ACGX,181,277) D S S ACG22=ACG
23 S ACG23=$E(ACGX,278,283),ACG23=$S($L(ACG23)=6&+ACG23:2_ACG23,1:""),ACGX23=ACG23 Q
24 S ACG24=$E(ACGX,284,289),ACG24=$S($L(ACG24)=6&+ACG24:2_ACG24,1:"")
25 S ACG25=$E(ACGX,290,295),ACG25=$S($L(ACG25)=6&+ACG25:2_ACG25,1:"")
26 S ACG26=+$E(ACGX,296,304)
27 S ACG27=$E(ACGX,305,308),ACG27=$S(ACG27="":"",$D(^ACGPPC("B",ACG27)):$O(^(ACG27,0)),1:"")
28 S ACG=$E(ACGX,309,333) D S S ACGX28=ACG Q ;,ACG28DA="",ACG28ST=$E(ACG28,1,2),ACG28PL=$E(ACG28,3,7),ACG28=$E(ACG28,8,25) S ACGSTATE=ACG28ST D STATE S ACG28STN=ACGSTNAM,ACG28STC=ACGSTCD,ACG28STD=ACGSTDA Q
29 S ACG29=$E(ACGX,334),ACG29=$S(ACG29:ACG29,1:"")
30 S ACG30=$E(ACGX,335),ACG30=$S(ACG30'=" ":ACG30,1:"")
31 S ACG31=$E(ACGX,336),ACG31=$S(ACG31'=" ":ACG31,1:"")
32 S ACG32=$E(ACGX,337),ACG32=$S(ACG32'=" ":ACG32,1:"")
33 S ACG=$E(ACGX,338,345) D S S ACG33=ACG
34 S ACG34=$E(ACGX,346,351),ACG34=$S($L(ACG34)=6&+ACG34:2_ACG34,1:""),ACGX34=ACG34 Q
35 S ACG=$E(ACGX,352,371) D S S ACG35=ACG
36 S ACG36=+$E(ACGX,372,380)
37 S ACG=$E(ACGX,381,388) S ACGX37=ACG,ACGXX37=$S($E(ACG,2)?1AN:$E(ACG,2,8),1:"") Q ;D S S ACG37=ACG Q ;$S($L(ACG)=8:$E(ACG,2,8),1:""),ACGFY=$S($L(ACG)=8:$E(ACG),1:""),ACG37DA=$S(ACG37="":"",1:$O(^AUTTCAN("B",ACG37,0))) Q
38 S ACG38=+$E(ACGX,389,397)
39 S ACG=$E(ACGX,398,405) D S S ACG39=$S($L(ACG)=8:$E(ACG,2,8),1:""),ACG39DA=$S(ACG39="":"",1:$O(^AUTTCAN("B",ACG39,0)))
40 S ACG40=+$E(ACGX,406,414)
41 S ACG=$E(ACGX,415,422) D S S ACG41=$S($L(ACG)=8:$E(ACG,2,8),1:""),ACG41DA=$S(ACG41="":"",1:$O(^AUTTCAN("B",ACG41,0)))
42 S ACG42=+$E(ACGX,423,431)
43 S ACG43=+$E(ACGX,432,440)
44 S ACG44=+$E(ACGX,441,449)
45 S ACG45=$E(ACGX,450),ACG45=$S(ACG45:ACG45,1:"")
46 S ACG46=+$E(ACGX,451,459)
47 S ACG47=+$E(ACGX,460,468)
48 S ACG48=+$E(ACGX,469,477)
49 S ACG49=+$E(ACGX,478,486)
50 S ACG50=+$E(ACGX,487,496)
51 S ACG51=$E(ACGX,497),ACG51=$S(ACG51:ACG51,1:"")
52 S ACG52=$E(ACGX,498),ACG52=$S(ACG52:ACG52,1:"")
53 S ACG=$E(ACGX,499,502) D S S ACG53=ACG,ACGX53=ACG53 Q
54 S ACG=$E(ACGX,503,532) D S S ACG54=ACG
55 S ACG=$E(ACGX,533,541) D S S ACG55=ACG
56 S ACG56=$E(ACGX,542),ACG56=$S(ACG56:ACG56,1:"")
57 S ACG57=$E(ACGX,543),ACG57=$S(ACG57:ACG57,1:"")
58 S ACG58=$E(ACGX,544),ACG58=$S(ACG58:ACG58,1:"")
59 S ACG59=+$E(ACGX,545,553)
60 S ACG60=$E(ACGX,554),ACG60=$S(ACG60:ACG60,1:"")
61 S ACG=$E(ACGX,555,558) D S S ACG61=ACG
62 S ACG62=$E(ACGX,559),ACG62=$S(ACG62'=" ":ACG62,1:"")
63 S ACG63=$E(ACGX,560),ACG63=$S(ACG63'=" ":ACG63,1:"")
64 S ACG64=$E(ACGX,561),ACG64=$S(ACG64:ACG64,1:"")
65 S ACG65=$E(ACGX,562),ACG65=$S(ACG65:ACG65,1:"")
66 S ACG66=$E(ACGX,563),ACG66=$S(ACG66="":"",$D(^AUTTSOB("B",ACG66)):$O(^(ACG66,0)),1:"")
Q
S F ACGI=$L(ACG):-1:1 I $E(ACG,ACGI)'=" " S ACG=$E(ACG,1,ACGI) Q
I ACGI=1,$E(ACG)=" " S ACG=""
Q
STATE S (ACGSTNAM,ACGSTCD)="",ACGSTDA=0
I $L(ACGSTATE)>2 S ACGSTDA=$O(^DIC(5,"B",ACGSTATE,0)) I ACGSTDA,$D(^DIC(5,ACGSTDA,0)) S ACGSTNAM=ACGSTATE,ACGSTCD=$P(^(0),U,3) Q
I $L(ACGSTATE)=2 S ACGSTDA=0 F S ACGSTDA=$O(^DIC(5,ACGSTDA)) Q:'ACGSTDA I ACGSTATE=$P(^DIC(5,ACGSTDA,0),U,3) S ACGSTNAM=$P(^(0),U),ACGSTCD=ACGSTATE Q
Q
ACGSIMP1 ;IHS/OIRM/DSD/THL,AEF - CON'T OF ACGSIMP1 SETS LOCAL VARIABLES [ 03/27/2000 2:22 PM ]
+1 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000
+2 DO 2
DO 5
DO 8
DO 9
DO 10
DO 11
DO 13
DO 23
DO 28
DO 34
DO 37
DO 53
QUIT
1 SET ACG1=$EXTRACT(ACGX)
SET ACG1=$SELECT(ACG1="":"",$DATA(^ACGTPA("B",ACG1)):$ORDER(^ACGTPA("B",ACG1,0)),1:"")
2 ;S:'ACG ACG=$E(ACGX,17,19)_$E(ACG,4,99) S ACG2=ACG,ACGCO=$E(ACG,1,3)_"00000"
SET ACG=$EXTRACT(ACGX,2,16)
DO S
SET ACGX2=ACG
QUIT
3 SET ACG=$EXTRACT(ACGX,17,28)
DO S
SET ACG3=ACG
4 SET ACG=$EXTRACT(ACGX,29,31)
DO S
SET ACG4=ACG
5 SET ACG=$EXTRACT(ACGX,32,71)
DO S
SET ACGX5=$EXTRACT(ACG,1,30)
SET ACG5DA=""
QUIT
6 SET ACG=$EXTRACT(ACGX,72,101)
DO S
SET ACG6=ACG
7 SET ACG=$EXTRACT(ACGX,102,124)
DO S
SET ACG7=ACG
SET ACG7DA=""
8 ;D STATE S ACG8NAM=ACGSTNAM,ACG8=ACGSTDA,ACG8CD=ACGSTCD
SET ACG=$EXTRACT(ACGX,125,143)
DO S
SET (ACGX8,ACGSTATE)=ACG
QUIT
9 SET ACG=$EXTRACT(ACGX,144,148)
DO S
SET ACGX9=ACG
QUIT
10 SET ACG=$EXTRACT(ACGX,149,151)
DO S
SET ACGX10=ACG
QUIT
11 ;,ACG11SUF=$E(ACG11,11,12),ACG11=$E(ACG11,1,10)
SET ACG=$EXTRACT(ACGX,152,163)
DO S
SET ACGX11=ACG
QUIT
12 SET ACG12=$EXTRACT(ACGX,164)
SET ACG12=$SELECT(ACG12'=" ":ACG12,1:"")
13 SET ACG13=$EXTRACT(ACGX,165,166)
SET ACGX13=$SELECT(ACG13="":"",$DATA(^AUTTTOB("B",ACG13)):$ORDER(^AUTTTOB("B",ACG13,0)),1:"")
14 SET ACG=$EXTRACT(ACGX,167,168)
DO S
SET ACG14=ACG
15 ;,ACG15=$S(ACG15="":"",$D(^ACGTOC("B",ACG15)):$O(^(ACG15,0)),1:"")
SET ACGX15=$EXTRACT(ACGX,169,170)
QUIT
16 SET ACG16=$EXTRACT(ACGX,171)
SET ACG16=$SELECT(ACG16'=" ":ACG16,1:"")
17 ;,ACG17=$S(ACG17="":"",$D(^ACGSP("B",ACG17)):$O(^(ACG17,0)),1:"")
SET ACGX17=$EXTRACT(ACGX,172,173)
QUIT
18 ;,ACG18=$S(ACG18="":"",$D(^ACGFAO("B",ACG18)):$O(^(ACG18,0)),1:"")
SET ACGX18=$EXTRACT(ACGX,174,175)
IF 'ACGX18
SET ACGX18=""
QUIT
19 ;,ACG19=$S(ACG19="":"",$D(^ACGEOC("B",ACG19)):$O(^(ACG19,0)),1:"")
SET ACGX19=$EXTRACT(ACGX,176,177)
QUIT
20 ;,ACG20=$S(ACG20="":"",$D(^ACGMOC("B",ACG20)):$O(^(ACG20,0)),1:"")
SET ACGX20=$EXTRACT(ACGX,178)
QUIT
21 SET ACG21=+$EXTRACT(ACGX,179,180)
22 SET ACG=$EXTRACT(ACGX,181,277)
DO S
SET ACG22=ACG
23 SET ACG23=$EXTRACT(ACGX,278,283)
SET ACG23=$SELECT($LENGTH(ACG23)=6&+ACG23:2_ACG23,1:"")
SET ACGX23=ACG23
QUIT
24 SET ACG24=$EXTRACT(ACGX,284,289)
SET ACG24=$SELECT($LENGTH(ACG24)=6&+ACG24:2_ACG24,1:"")
25 SET ACG25=$EXTRACT(ACGX,290,295)
SET ACG25=$SELECT($LENGTH(ACG25)=6&+ACG25:2_ACG25,1:"")
26 SET ACG26=+$EXTRACT(ACGX,296,304)
27 SET ACG27=$EXTRACT(ACGX,305,308)
SET ACG27=$SELECT(ACG27="":"",$DATA(^ACGPPC("B",ACG27)):$ORDER(^(ACG27,0)),1:"")
28 ;,ACG28DA="",ACG28ST=$E(ACG28,1,2),ACG28PL=$E(ACG28,3,7),ACG28=$E(ACG28,8,25) S ACGSTATE=ACG28ST D STATE S ACG28STN=ACGSTNAM,ACG28STC=ACGSTCD,ACG28STD=ACGSTDA Q
SET ACG=$EXTRACT(ACGX,309,333)
DO S
SET ACGX28=ACG
QUIT
29 SET ACG29=$EXTRACT(ACGX,334)
SET ACG29=$SELECT(ACG29:ACG29,1:"")
30 SET ACG30=$EXTRACT(ACGX,335)
SET ACG30=$SELECT(ACG30'=" ":ACG30,1:"")
31 SET ACG31=$EXTRACT(ACGX,336)
SET ACG31=$SELECT(ACG31'=" ":ACG31,1:"")
32 SET ACG32=$EXTRACT(ACGX,337)
SET ACG32=$SELECT(ACG32'=" ":ACG32,1:"")
33 SET ACG=$EXTRACT(ACGX,338,345)
DO S
SET ACG33=ACG
34 SET ACG34=$EXTRACT(ACGX,346,351)
SET ACG34=$SELECT($LENGTH(ACG34)=6&+ACG34:2_ACG34,1:"")
SET ACGX34=ACG34
QUIT
35 SET ACG=$EXTRACT(ACGX,352,371)
DO S
SET ACG35=ACG
36 SET ACG36=+$EXTRACT(ACGX,372,380)
37 ;D SIMP1_source.html#xS">SIMP1_source.html#xSIMP1_source.html#xS">S">SIMP1_source.html#xS">S SIMP1_source.html#xS">SIMP1_source.html#xSIMP1_source.html#xS">S">SIMP1_source.html#xS">S ACG37=ACG Q ;$SIMP1_source.html#xS">SIMP1_source.html#xSIMP1_source.html#xS">S">SIMP1_source.html#xS">S($L(ACG)=8:$E(ACG,2,8),1:""),ACGFY=$SIMP1_source.html#xS">SIMP1_source.html#xSIMP1_source.html#xS">S">SIMP1_source.html#xS">S($L(ACG)=8:$E(ACG),1:""),ACG37DA=$SIMP1_source.html#xS">SIMP1_source.html#xSIMP1_source.html#xS">S">SIMP1_source.html#xS">S(ACG37="":"",1:$O(^AUTTCAN("B",ACG37,0))) Q
SET ACG=$EXTRACT(ACGX,381,388)
SET ACGX37=ACG
SET ACGXX37=$SELECT($EXTRACT(ACG,2)?1AN:$EXTRACT(ACG,2,8),1:"")
QUIT
38 SET ACG38=+$EXTRACT(ACGX,389,397)
39 SET ACG=$EXTRACT(ACGX,398,405)
DO S
SET ACG39=$SELECT($LENGTH(ACG)=8:$EXTRACT(ACG,2,8),1:"")
SET ACG39DA=$SELECT(ACG39="":"",1:$ORDER(^AUTTCAN("B",ACG39,0)))
40 SET ACG40=+$EXTRACT(ACGX,406,414)
41 SET ACG=$EXTRACT(ACGX,415,422)
DO S
SET ACG41=$SELECT($LENGTH(ACG)=8:$EXTRACT(ACG,2,8),1:"")
SET ACG41DA=$SELECT(ACG41="":"",1:$ORDER(^AUTTCAN("B",ACG41,0)))
42 SET ACG42=+$EXTRACT(ACGX,423,431)
43 SET ACG43=+$EXTRACT(ACGX,432,440)
44 SET ACG44=+$EXTRACT(ACGX,441,449)
45 SET ACG45=$EXTRACT(ACGX,450)
SET ACG45=$SELECT(ACG45:ACG45,1:"")
46 SET ACG46=+$EXTRACT(ACGX,451,459)
47 SET ACG47=+$EXTRACT(ACGX,460,468)
48 SET ACG48=+$EXTRACT(ACGX,469,477)
49 SET ACG49=+$EXTRACT(ACGX,478,486)
50 SET ACG50=+$EXTRACT(ACGX,487,496)
51 SET ACG51=$EXTRACT(ACGX,497)
SET ACG51=$SELECT(ACG51:ACG51,1:"")
52 SET ACG52=$EXTRACT(ACGX,498)
SET ACG52=$SELECT(ACG52:ACG52,1:"")
53 SET ACG=$EXTRACT(ACGX,499,502)
DO S
SET ACG53=ACG
SET ACGX53=ACG53
QUIT
54 SET ACG=$EXTRACT(ACGX,503,532)
DO S
SET ACG54=ACG
55 SET ACG=$EXTRACT(ACGX,533,541)
DO S
SET ACG55=ACG
56 SET ACG56=$EXTRACT(ACGX,542)
SET ACG56=$SELECT(ACG56:ACG56,1:"")
57 SET ACG57=$EXTRACT(ACGX,543)
SET ACG57=$SELECT(ACG57:ACG57,1:"")
58 SET ACG58=$EXTRACT(ACGX,544)
SET ACG58=$SELECT(ACG58:ACG58,1:"")
59 SET ACG59=+$EXTRACT(ACGX,545,553)
60 SET ACG60=$EXTRACT(ACGX,554)
SET ACG60=$SELECT(ACG60:ACG60,1:"")
61 SET ACG=$EXTRACT(ACGX,555,558)
DO S
SET ACG61=ACG
62 SET ACG62=$EXTRACT(ACGX,559)
SET ACG62=$SELECT(ACG62'=" ":ACG62,1:"")
63 SET ACG63=$EXTRACT(ACGX,560)
SET ACG63=$SELECT(ACG63'=" ":ACG63,1:"")
64 SET ACG64=$EXTRACT(ACGX,561)
SET ACG64=$SELECT(ACG64:ACG64,1:"")
65 SET ACG65=$EXTRACT(ACGX,562)
SET ACG65=$SELECT(ACG65:ACG65,1:"")
66 SET ACG66=$EXTRACT(ACGX,563)
SET ACG66=$SELECT(ACG66="":"",$DATA(^AUTTSOB("B",ACG66)):$ORDER(^(ACG66,0)),1:"")
+1 QUIT
S FOR ACGI=$LENGTH(ACG):-1:1
IF $EXTRACT(ACG,ACGI)'=" "
SET ACG=$EXTRACT(ACG,1,ACGI)
QUIT
+1 IF ACGI=1
IF $EXTRACT(ACG)=" "
SET ACG=""
+2 QUIT
STATE SET (ACGSTNAM,ACGSTCD)=""
SET ACGSTDA=0
+1 IF $LENGTH(ACGSTATE)>2
SET ACGSTDA=$ORDER(^DIC(5,"B",ACGSTATE,0))
IF ACGSTDA
IF $DATA(^DIC(5,ACGSTDA,0))
SET ACGSTNAM=ACGSTATE
SET ACGSTCD=$PIECE(^(0),U,3)
QUIT
+2 IF $LENGTH(ACGSTATE)=2
SET ACGSTDA=0
FOR
SET ACGSTDA=$ORDER(^DIC(5,ACGSTDA))
IF 'ACGSTDA
QUIT
IF ACGSTATE=$PIECE(^DIC(5,ACGSTDA,0),U,3)
SET ACGSTNAM=$PIECE(^(0),U)
SET ACGSTCD=ACGSTATE
QUIT
+3 QUIT
