ACGSDCIS.m

ACGSDCIS ;IHS/OIRM/DSD/THL,AEF - CONTROL CIS FIELDS AND EXPORT VARIABLES ; [ 03/27/2000   2:22 PM ]

 ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000

 ;;CONTROL CIS FIELDS AND EXPORT VARIABLES

 ;;modified for y2k;mlp;01/31/2000

EN I $D(^ACGS(ACGRDA,"DT"))&$D(^("DT1"))&$D(^("DT2"))&$D(^("DT3")) S ACGDT=^("DT"),ACGDT1=^("DT1"),ACGDT2=^("DT2"),ACGDT3=^("DT3"),ACGIHS=^("IHS") D 1

EXIT K ACGSIGN,ACGX

 Q

1 S ACGY="",X="7520"

 D Y

2 S X=$E($P(ACGDT,U,2),1,9)_"   "

 S:$L(X)<15 X=X_$J(" ",15-$L(X))

 D Y

3 S X=$E($P(ACGDT,U,2),10,12)

 S:$L(X)<4 X=X_$J("0",4-$L(X))

 D Y

4 S X=$E($P(ACGDT,U,3),1,12)

 S:$L(X)<15 X=X_$J(" ",15-$L(X))

 D Y

5 S X="00"_$E($P(ACGDT,U,4),1,3)

 S:$L(X)<5 X=X_$J(" ",5-$L(X))

 D Y

6 S X=$E($P(ACGDT1,U,3),2,5)

 S:X'?4N X="    "

 D Y

7 S X="A"

 D Y

8 S X="961"

 D Y

9 S X=$P(ACGDT,U),X=$S('X:" ",$D(^ACGTPA(X,0)):$E($P(^(0),U)),1:" ")

 D 9^ACGSDCI2,Y

10 S X=$P(ACGDT1,U,5),ACGSIGN=$S($E(X)="-":"-",1:""),ACGX=""

 S:ACGSIGN="-" X=$P(X,"-",2)

 Q:X<500

 D DOLLAR

 S:(9-$L(X)) $P(ACGX,"0",(9-$L(X)))=""

 S X=ACGX_X

 D Y

11 S X=$S(ACGSIGN'="-":"A",1:"B")

 D Y

12 S X=$P(ACGDT1,U,6),X=$S('X:"    ",$D(^ACGPPC(X,0)):$P(^(0),U),1:"    ")

 D Y

13 S X=$E($P(ACGDT2,U,18),1,4),X=$S(X]"":X,1:"    ")

 D Y

14 S X=$E($P(ACGDT,U,16)),X=$S(X=1:"Y",X=2:"N",1:" ")

 D Y

15 S X=$E($P(ACGDT,U,5),1,30)

 S:$L(X)<30 X=X_$J(" ",30-$L(X))

 D Y

16 S X="         "

 D Y

17 S X=$E($P(ACGDT1,U,7),1,7)

 S:$L(X)'=7 X="       "

 S X=X_"  "

 D Y

18 S X=$E($P(ACGDT2,U,16)),X=$S(X=1:"Y",1:"N")

 D Y

19 S X=$E($P(ACGDT2,U,17)),X=$S("ABC"[$P(ACGDT3,U,7):" ",X]"":X,1:" ")

 D Y

20 S X="0"

 D Y

21 S X="00"

 D Y

22 S X="US"

 D Y

23 S X=$E($P(ACGDT2,U,10)),X=$S(X=1:"A",X=2:"B",1:"C")

 D Y

24 S X=$P(ACGDT,U,15),X=$S('X:" ",$D(^ACGTOC(X,0)):$P(^(0),U),1:" ")

 D 24^ACGSDCI2

 D Y

25 S X=$E($P(ACGDT3,U,7)),X=$S(X]"":X,1:" ")

 D Y

26 S X=$P(ACGDT,U,17),X=$S('X:" ",$D(^ACGSP(X,0)):$P(^(0),U),1:" "),X=$E(X,2),X=$S(X="K":"L",X="J":"K",X="I":"J",1:X)

 D Y

27 S X=$P(ACGDT,U,18),X=$S('X:" ",$D(^ACGFAO(X,0)):$P(^(0),U),1:" ")

 D 27^ACGSDCI2

 D Y

28 S X=$E($P(ACGDT,U,21),1,2),X=$S(X<2:"A",1:"B")

 D Y

29 S X=$E($P(ACGDT,U,12)),X=$S(X]"":X,1:" ")

 D Y

30 S X=$P(ACGDT,U,13),X=$S('X:" ",$D(^AUTTTOB(X,0)):$P(^(0),U),1:" ")

 D 30^ACGSDCI2

 D Y

31 S X=$E($P(ACGDT1,U,9)),X=$S(X=1:"Y",1:"N")

 D Y

32 S X=$P(ACGDT,U,19),X=$S('X:" ",$D(^ACGEOC(X,0)):$P(^(0),U),1:" ")

 D 32^ACGSDCI2

 D Y

33 S X=$E($P(ACGDT3,U,1)),X=$S(X=1:"A",1:"B")

 D Y

34 S X=$E($P(ACGDT1,U,10)),X=$S(X]"":X,1:" ")

 D Y

35 S X=$E($P(ACGDT1,U,4),2,5)

 S:X="" X="    "

 D Y

36 S X=$E($P(ACGDT,U,11),2,10)

 S:$L(X)<9 X=X_$J(" ",9-$L(X))

 D Y

37 S X=$E($P(ACGDT2,U,19),1,30)

 S:$L(X)<30 X=X_$J(" ",30-$L(X))

 D Y

38 S X=$E($P(ACGDT2,U,20),2,10)

 S:$L(X)<9 X=X_$J(" ",9-$L(X))

 D Y

39 S X=" "

 D Y

40 S X=" "

 D Y

41 S X="        "

 D Y

42 S X=$E($P(ACGDT3,U,8)),X=$S(X'=1:"N",$E(ACGY,129)="D"&(X=1):"N",1:"N")

 D Y

43 S X=$E($P(ACGDT3,U,9)),X=$S($E(ACGY,200)="N":" ",X=1:"Y",1:"N")

 D Y

44 S X=$E($P(ACGDT3,U,10)),X=$S($E(ACGY,200)="N":" ",X=1:"Y",1:"N")

 D Y

45 S X=$P(ACGDT3,U,11),X=$S('X:" ",$D(^AUTTSOB(X,0)):$P(^(0),U),1:" ")

 D Y

46 S X="          "

 D Y

50 S X=$E($P(ACGDT,U,6),1,35)

 S:$L(X)<35 X=X_$J(" ",35-$L(X))

 D Y

51 S X=$E($P(ACGDT,U,7),1,18)

 S:$L(X)<18 X=X_$J(" ",18-$L(X))

 D Y

52 S X=$P(ACGDT,U,8),X=$S('X:"",$D(^DIC(5,X,0)):$P(^(0),U,2),1:"")

 D Y

53 S X=$E($P(ACGDT,U,9),1,5)

 S:$L(X)<5 X=X_$J(" ",5-$L(X))

 D Y

54 S X=$E($P(ACGDT1,U),1,150)

 S:$L(X)<150 X=X_$J(" ",150-$L(X))

 D Y

55 ;S X=$E($P(ACGDT1,U,13),2,7)

 ;S:X'?6N X="      "

 ;S:$L(X)<6 X=X_$J(" ",6-$L(X))

 S X=$E($P(ACGDT1,U,13),1,7) ;y2k;mlp

 S:X'?7N X="       " ;y2k;mlp

 S:$L(X)<7 X=X_$J(" ",7-$L(X)) ;y2k;mlp

 D Y

56 ;S X=$E($P(ACGDT1,U,3),2,7)

 ;S:X'?6N X="      "

 S X=$E($P(ACGDT1,U,3),1,7) ;y2k;mlp

 S:X'?7N X="       " ;y2k;mlp

 D Y

57 S X=$P(ACGDT2,U,12),ACGSIGN=$S($E(X)="-":"-",1:""),ACGX=""

 S:ACGSIGN="-" X=$P(X,"-",2)

 D DOLLAR

 S:(9-$L(X)) $P(ACGX,"0",(9-$L(X)))=""

 S X=ACGX_X

 D Y

58 S X=$P(ACGDT2,U,13),ACGSIGN=$S($E(X)="-":"-",1:""),ACGX=""

 S:ACGSIGN="-" X=$P(X,"-",2)

 D DOLLAR

 S:(9-$L(X)) $P(ACGX,"0",(9-$L(X)))=""

 S X=ACGX_X

 D Y

59 S X=$P(ACGDT2,U,14),ACGSIGN=$S($E(X)="-":"-",1:""),ACGX=""

 S:ACGSIGN="-" X=$P(X,"-",2)

 D DOLLAR

 S:(9-$L(X)) $P(ACGX,"0",(9-$L(X)))=""

 S X=ACGX_X

 D Y

60 S X=$E($P(ACGDT1,U,8)),X=$S(X=1:"Y",1:"N")

 D Y

61 S X=$E($P(ACGDT3,U,12),1,10),ACGSIGN=$S($E(X)="-":"-",1:""),ACGX=""

 S:ACGSIGN="-" X=$P(X,"-",2)

 D DOLLAR

 S:(9-$L(X)) $P(ACGX,"0",(9-$L(X)))=""

 S X=ACGX_X

 D Y

 K ACGX

62 S X=$E($P(ACGDT3,U,13),1,10),ACGSIGN=$S($E(X)="-":"-",1:""),ACGX=""

 S:ACGSIGN="-" X=$P(X,"-",2)

 D DOLLAR

 S:(9-$L(X)) $P(ACGX,"0",(9-$L(X)))=""

 S X=ACGX_X

 D Y

63 S X="                              "

 D Y

64 S X="          "

 D Y

65 S X="DHRI"

 D Y

66 S X="                                                                                "

 D Y

 Q

Y S ACGY=ACGY_X

 Q

DOLLAR ;FORMAT DOLLARS FOR DCIS

 S X=$FN(X,"P,",2),X=$P(X,"."),Z=$L(X,","),Y=$P(X,",",Z),X=$P(X,",",1,Z-1)

 S X=$TR(X," ",""),X=$TR(X,",","")

 S:Y>500 X=X+1

 Q

ACGSDCIS  ;IHS/OIRM/DSD/THL,AEF - CONTROL CIS FIELDS AND EXPORT VARIABLES ; [ 03/27/2000   2:22 PM ]

 +1       ;;2.0t1;CONTRACT INFORMATION SYSTEM;;FEB 16, 2000

 +2       ;;CONTROL CIS FIELDS AND EXPORT VARIABLES

 +3       ;;modified for y2k;mlp;01/31/2000

EN         IF $DATA(^ACGS(ACGRDA,"DT"))&$DATA(^("DT1"))&$DATA(^("DT2"))&$DATA(^("DT3"))

               SET ACGDT=^("DT")

               SET ACGDT1=^("DT1")

               SET ACGDT2=^("DT2")

               SET ACGDT3=^("DT3")

               SET ACGIHS=^("IHS")

               DO 1

EXIT       KILL ACGSIGN,ACGX

 +1        QUIT 

1          SET ACGY=""

           SET X="7520"

 +1        DO Y

2          SET X=$EXTRACT($PIECE(ACGDT,U,2),1,9)_"   "

 +1        IF $LENGTH(X)<15

               SET X=X_$JUSTIFY(" ",15-$LENGTH(X))

 +2        DO Y

3          SET X=$EXTRACT($PIECE(ACGDT,U,2),10,12)

 +1        IF $LENGTH(X)<4

               SET X=X_$JUSTIFY("0",4-$LENGTH(X))

 +2        DO Y

4          SET X=$EXTRACT($PIECE(ACGDT,U,3),1,12)

 +1        IF $LENGTH(X)<15

               SET X=X_$JUSTIFY(" ",15-$LENGTH(X))

 +2        DO Y

5          SET X="00"_$EXTRACT($PIECE(ACGDT,U,4),1,3)

 +1        IF $LENGTH(X)<5

               SET X=X_$JUSTIFY(" ",5-$LENGTH(X))

 +2        DO Y

6          SET X=$EXTRACT($PIECE(ACGDT1,U,3),2,5)

 +1        IF X'?4N

               SET X="    "

 +2        DO Y

7          SET X="A"

 +1        DO Y

8          SET X="961"

 +1        DO Y

9          SET X=$PIECE(ACGDT,U)

           SET X=$SELECT('X:" ",$DATA(^ACGTPA(X,0)):$EXTRACT($PIECE(^(0),U)),1:" ")

 +1        DO 9^ACGSDCI2

           DO Y

10         SET X=$PIECE(ACGDT1,U,5)

           SET ACGSIGN=$SELECT($EXTRACT(X)="-":"-",1:"")

           SET ACGX=""

 +1        IF ACGSIGN="-"

               SET X=$PIECE(X,"-",2)

 +2        IF X<500

               QUIT 

 +3        DO DOLLAR

 +4        IF (9-$LENGTH(X))

               SET $PIECE(ACGX,"0",(9-$LENGTH(X)))=""

 +5        SET X=ACGX_X

 +6        DO Y

11         SET X=$SELECT(ACGSIGN'="-":"A",1:"B")

 +1        DO Y

12         SET X=$PIECE(ACGDT1,U,6)

           SET X=$SELECT('X:"    ",$DATA(^ACGPPC(X,0)):$PIECE(^(0),U),1:"    ")

 +1        DO Y

13         SET X=$EXTRACT($PIECE(ACGDT2,U,18),1,4)

           SET X=$SELECT(X]"":X,1:"    ")

 +1        DO Y

14         SET X=$EXTRACT($PIECE(ACGDT,U,16))

           SET X=$SELECT(X=1:"Y",X=2:"N",1:" ")

 +1        DO Y

15         SET X=$EXTRACT($PIECE(ACGDT,U,5),1,30)

 +1        IF $LENGTH(X)<30

               SET X=X_$JUSTIFY(" ",30-$LENGTH(X))

 +2        DO Y

16         SET X="         "

 +1        DO Y

17         SET X=$EXTRACT($PIECE(ACGDT1,U,7),1,7)

 +1        IF $LENGTH(X)'=7

               SET X="       "

 +2        SET X=X_"  "

 +3        DO Y

18         SET X=$EXTRACT($PIECE(ACGDT2,U,16))

           SET X=$SELECT(X=1:"Y",1:"N")

 +1        DO Y

19         SET X=$EXTRACT($PIECE(ACGDT2,U,17))

           SET X=$SELECT("ABC"[$PIECE(ACGDT3,U,7):" ",X]"":X,1:" ")

 +1        DO Y

20         SET X="0"

 +1        DO Y

21         SET X="00"

 +1        DO Y

22         SET X="US"

 +1        DO Y

23         SET X=$EXTRACT($PIECE(ACGDT2,U,10))

           SET X=$SELECT(X=1:"A",X=2:"B",1:"C")

 +1        DO Y

24         SET X=$PIECE(ACGDT,U,15)

           SET X=$SELECT('X:" ",$DATA(^ACGTOC(X,0)):$PIECE(^(0),U),1:" ")

 +1        DO 24^ACGSDCI2

 +2        DO Y

25         SET X=$EXTRACT($PIECE(ACGDT3,U,7))

           SET X=$SELECT(X]"":X,1:" ")

 +1        DO Y

26         SET X=$PIECE(ACGDT,U,17)

           SET X=$SELECT('X:" ",$DATA(^ACGSP(X,0)):$PIECE(^(0),U),1:" ")

           SET X=$EXTRACT(X,2)

           SET X=$SELECT(X="K":"L",X="J":"K",X="I":"J",1:X)

 +1        DO Y

27         SET X=$PIECE(ACGDT,U,18)

           SET X=$SELECT('X:" ",$DATA(^ACGFAO(X,0)):$PIECE(^(0),U),1:" ")

 +1        DO 27^ACGSDCI2

 +2        DO Y

28         SET X=$EXTRACT($PIECE(ACGDT,U,21),1,2)

           SET X=$SELECT(X<2:"A",1:"B")

 +1        DO Y

29         SET X=$EXTRACT($PIECE(ACGDT,U,12))

           SET X=$SELECT(X]"":X,1:" ")

 +1        DO Y

30         SET X=$PIECE(ACGDT,U,13)

           SET X=$SELECT('X:" ",$DATA(^AUTTTOB(X,0)):$PIECE(^(0),U),1:" ")

 +1        DO 30^ACGSDCI2

 +2        DO Y

31         SET X=$EXTRACT($PIECE(ACGDT1,U,9))

           SET X=$SELECT(X=1:"Y",1:"N")

 +1        DO Y

32         SET X=$PIECE(ACGDT,U,19)

           SET X=$SELECT('X:" ",$DATA(^ACGEOC(X,0)):$PIECE(^(0),U),1:" ")

 +1        DO 32^ACGSDCI2

 +2        DO Y

33         SET X=$EXTRACT($PIECE(ACGDT3,U,1))

           SET X=$SELECT(X=1:"A",1:"B")

 +1        DO Y

34         SET X=$EXTRACT($PIECE(ACGDT1,U,10))

           SET X=$SELECT(X]"":X,1:" ")

 +1        DO Y

35         SET X=$EXTRACT($PIECE(ACGDT1,U,4),2,5)

 +1        IF X=""

               SET X="    "

 +2        DO Y

36         SET X=$EXTRACT($PIECE(ACGDT,U,11),2,10)

 +1        IF $LENGTH(X)<9

               SET X=X_$JUSTIFY(" ",9-$LENGTH(X))

 +2        DO Y

37         SET X=$EXTRACT($PIECE(ACGDT2,U,19),1,30)

 +1        IF $LENGTH(X)<30

               SET X=X_$JUSTIFY(" ",30-$LENGTH(X))

 +2        DO Y

38         SET X=$EXTRACT($PIECE(ACGDT2,U,20),2,10)

 +1        IF $LENGTH(X)<9

               SET X=X_$JUSTIFY(" ",9-$LENGTH(X))

 +2        DO Y

39         SET X=" "

 +1        DO Y

40         SET X=" "

 +1        DO Y

41         SET X="        "

 +1        DO Y

42         SET X=$EXTRACT($PIECE(ACGDT3,U,8))

           SET X=$SELECT(X'=1:"N",$EXTRACT(ACGY,129)="D"&(X=1):"N",1:"N")

 +1        DO Y

43         SET X=$EXTRACT($PIECE(ACGDT3,U,9))

           SET X=$SELECT($EXTRACT(ACGY,200)="N":" ",X=1:"Y",1:"N")

 +1        DO Y

44         SET X=$EXTRACT($PIECE(ACGDT3,U,10))

           SET X=$SELECT($EXTRACT(ACGY,200)="N":" ",X=1:"Y",1:"N")

 +1        DO Y

45         SET X=$PIECE(ACGDT3,U,11)

           SET X=$SELECT('X:" ",$DATA(^AUTTSOB(X,0)):$PIECE(^(0),U),1:" ")

 +1        DO Y

46         SET X="          "

 +1        DO Y

50         SET X=$EXTRACT($PIECE(ACGDT,U,6),1,35)

 +1        IF $LENGTH(X)<35

               SET X=X_$JUSTIFY(" ",35-$LENGTH(X))

 +2        DO Y

51         SET X=$EXTRACT($PIECE(ACGDT,U,7),1,18)

 +1        IF $LENGTH(X)<18

               SET X=X_$JUSTIFY(" ",18-$LENGTH(X))

 +2        DO Y

52         SET X=$PIECE(ACGDT,U,8)

           SET X=$SELECT('X:"",$DATA(^DIC(5,X,0)):$PIECE(^(0),U,2),1:"")

 +1        DO Y

53         SET X=$EXTRACT($PIECE(ACGDT,U,9),1,5)

 +1        IF $LENGTH(X)<5

               SET X=X_$JUSTIFY(" ",5-$LENGTH(X))

 +2        DO Y

54         SET X=$EXTRACT($PIECE(ACGDT1,U),1,150)

 +1        IF $LENGTH(X)<150

               SET X=X_$JUSTIFY(" ",150-$LENGTH(X))

 +2        DO Y

55        ;S X=$E($P(ACGDT1,U,13),2,7)

 +1       ;S:X'?6N X="      "

 +2       ;S:$L(X)<6 X=X_$J(" ",6-$L(X))

 +3       ;y2k;mlp

           SET X=$EXTRACT($PIECE(ACGDT1,U,13),1,7)

 +4       ;y2k;mlp

           IF X'?7N

               SET X="       "

 +5       ;y2k;mlp

           IF $LENGTH(X)<7

               SET X=X_$JUSTIFY(" ",7-$LENGTH(X))

 +6        DO Y

56        ;S X=$E($P(ACGDT1,U,3),2,7)

 +1       ;S:X'?6N X="      "

 +2       ;y2k;mlp

           SET X=$EXTRACT($PIECE(ACGDT1,U,3),1,7)

 +3       ;y2k;mlp

           IF X'?7N

               SET X="       "

 +4        DO Y

57         SET X=$PIECE(ACGDT2,U,12)

           SET ACGSIGN=$SELECT($EXTRACT(X)="-":"-",1:"")

           SET ACGX=""

 +1        IF ACGSIGN="-"

               SET X=$PIECE(X,"-",2)

 +2        DO DOLLAR

 +3        IF (9-$LENGTH(X))

               SET $PIECE(ACGX,"0",(9-$LENGTH(X)))=""

 +4        SET X=ACGX_X

 +5        DO Y

58         SET X=$PIECE(ACGDT2,U,13)

           SET ACGSIGN=$SELECT($EXTRACT(X)="-":"-",1:"")

           SET ACGX=""

 +1        IF ACGSIGN="-"

               SET X=$PIECE(X,"-",2)

 +2        DO DOLLAR

 +3        IF (9-$LENGTH(X))

               SET $PIECE(ACGX,"0",(9-$LENGTH(X)))=""

 +4        SET X=ACGX_X

 +5        DO Y

59         SET X=$PIECE(ACGDT2,U,14)

           SET ACGSIGN=$SELECT($EXTRACT(X)="-":"-",1:"")

           SET ACGX=""

 +1        IF ACGSIGN="-"

               SET X=$PIECE(X,"-",2)

 +2        DO DOLLAR

 +3        IF (9-$LENGTH(X))

               SET $PIECE(ACGX,"0",(9-$LENGTH(X)))=""

 +4        SET X=ACGX_X

 +5        DO Y

60         SET X=$EXTRACT($PIECE(ACGDT1,U,8))

           SET X=$SELECT(X=1:"Y",1:"N")

 +1        DO Y

61         SET X=$EXTRACT($PIECE(ACGDT3,U,12),1,10)

           SET ACGSIGN=$SELECT($EXTRACT(X)="-":"-",1:"")

           SET ACGX=""

 +1        IF ACGSIGN="-"

               SET X=$PIECE(X,"-",2)

 +2        DO DOLLAR

 +3        IF (9-$LENGTH(X))

               SET $PIECE(ACGX,"0",(9-$LENGTH(X)))=""

 +4        SET X=ACGX_X

 +5        DO Y

 +6        KILL ACGX

62         SET X=$EXTRACT($PIECE(ACGDT3,U,13),1,10)

           SET ACGSIGN=$SELECT($EXTRACT(X)="-":"-",1:"")

           SET ACGX=""

 +1        IF ACGSIGN="-"

               SET X=$PIECE(X,"-",2)

 +2        DO DOLLAR

 +3        IF (9-$LENGTH(X))

               SET $PIECE(ACGX,"0",(9-$LENGTH(X)))=""

 +4        SET X=ACGX_X

 +5        DO Y

63         SET X="                              "

 +1        DO Y

64         SET X="          "

 +1        DO Y

65         SET X="DHRI"

 +1        DO Y

66         SET X="                                                                                "

 +1        DO Y

 +2        QUIT 

Y          SET ACGY=ACGY_X

 +1        QUIT 

DOLLAR    ;FORMAT DOLLARS FOR DCIS

 +1        SET X=$FNUMBER(X,"P,",2)

           SET X=$PIECE(X,".")

           SET Z=$LENGTH(X,",")

           SET Y=$PIECE(X,",",Z)

           SET X=$PIECE(X,",",1,Z-1)

 +2        SET X=$TRANSLATE(X," ","")

           SET X=$TRANSLATE(X,",","")

 +3        IF Y>500

               SET X=X+1

 +4        QUIT