- 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
