ACRFEDG.m

ACRFEDG ;IHS/OIRM/DSD/THL,AEF - ESTABLISH DISTRIBUTION GROUP; [ 11/01/2001   9:44 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001

 ;;ROUTINE TO ESTABLISH FUND DISTRIBUTION GROUP

EN N ACRI

 F  D EN1 Q:$D(ACRQUIT)!$D(ACROUT)

EXIT K ACRQUIT,ACRX,ACRY,ACRDGDA,ACRDG,ACRDGMDA,ACRDGM,ACRPRCT,ACRFEDG

 Q

EN1 W @IOF

 S ACRX="MANAGE FUND DISTRIBUTION GROUPS"

 W !!?80-$L(ACRX)\2,ACRX

 W !?80-$L(ACRX)\2

 F ACRI=1:1:$L(ACRX) W "="

 S DIR(0)="SO^1:ADD/EDIT;2:DELETE^K:X'?1N!(X<1)!(X>2) X"

 S DIR("A")="  Option"

 D DIR^ACRFDIC

 Q:$D(ACRQUIT)!$D(ACROUT)

 I X=1 D ADD Q

 D DELETE

 K ACRQUIT

 Q

ADD F  D ADD1 Q:$D(ACRQUIT)!$D(ACROUT)

 K ACRQUIT

 Q

ADD1 D GET^ACRFEDG1

 Q:$D(ACRQUIT)!$D(ACROUT)

 F  D DISPLAY,SIB:ACRJ=1,A1:ACRJ>1 I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q

 Q

SIB W !!,"Add MEMBERS for the ",@ACRON,ACRDG,@ACROF," Fund Distribution Group by:"

 S DIR(0)="SO^1:Office/Div/Branch/Dept;2:Area;3:Service Unit;4:Facility^K:X'?1N!(X<1)!(X>5) X"

 S DIR("A")="Member Type"

 D DIR^ACRFDIC

 Q:$D(ACRQUIT)!$D(ACROUT)

 S ACRX=$S(X=1:"OFFICE",X=2:"AREA",X=3:"SU",X=4:"FAC")

 F  D S1 Q:+Y<1

 Q

S1 S ACRY=$P($T(@ACRX),";;",2,99)

 S DIC(0)="AEMQZ"

 S (ACRGLB,DIC)=$P(ACRY,";;")

 S DIC=U_DIC

 S DIC("A")=$P(ACRY,";;",2)

 W !

 D DIC^ACRFDIC

 Q:+Y<1

 S ACRDFN=+Y,ACRY=Y(0,0)

 D NEWM

 Q

SIB1 D GETM^ACRFEDG1

 Q:+Y<1

 I $D(^ACRDG(ACRDGDA,"GP","B")) D  I 1

 .S (ACRX,ACRY)=0

 .F  S ACRX=$O(^ACRDG(ACRDGDA,"GP",ACRX)) Q:'ACRX  S:$D(^ACRDG(ACRDGDA,"GP",ACRX,"DT")) ACRY=ACRY+$P(^("DT"),U,3)

 E  S ACRY=0

 S DA=ACRDGMDA

 S DIE="^ACRDG("_ACRDGDA_",""GP"","

 S DIE("NO^")="NO"

 S DR=".02T;.03T;.04T;S ACRY=ACRY-$P(^ACRDG(ACRDGDA,""GP"",DA,""DT""),U,3);10T;I $P(^ACRDG(ACRDGDA,""GP"",DA,""DT""),U,3)+ACRY>100 K X S $P(^(""DT""),U,3)=100-ACRY W *7,*7,!!,""TOTAL PERCENT CANNOT BE GREATER THAN 100."" S Y=10"

 D DIE^ACRFDIC

 Q

NEWM S:'$D(@("^ACRDG("_ACRDGDA_",""GP"",0)")) @("^ACRDG("_ACRDGDA_",""GP"",0)")="^9002198.01^^"

 S DA(1)=ACRDGDA

 S X=ACRY

 S DIC="^ACRDG("_ACRDGDA_",""GP"","

 S DIC(0)="AELMQZ"

 S DIC("DR")=".02T;.03T;.04T;1////"_ACRGLB_";2////"_ACRDFN_";10T"

 D FILE^ACRFDIC

 Q

DISPLAY ;EP;TO DISPLAY DISTRIBUTION

 D HEAD

 S (ACRJ,ACRX)=0

 F  S ACRX=$O(^ACRDG(ACRDGDA,"GP",ACRX)) Q:'ACRX  D D1 Q:$D(ACRPSE)

 I ACRJ=0,'$D(ACRFEDG) D  Q

 .W !,"NO FUND DISTRIBUTION GROUP MEMBERS"

 .W !,"GROUP MEMBERS MUST BE ESTABLISHED"

 .W !,"VIA SYSTEM SETUP.  CONSULT YOUR SYSTEMS"

 .W !,"MANAGER FOR ASSISTANCE."

 .S ACRQUIT=""

 .H 3

 I ACRJ=0,$D(ACRFEDG) D SIB Q

 I ACRJ>0 D

 .S (ACRX,ACRPRCT)=0

 .F  S ACRX=$O(^ACRDG(ACRDGDA,"GP",ACRX)) Q:'ACRX  D D2

 I ACRJ>1 D

 .W !?19,"TOTAL PERCENT:"

 .W ?35,$J(ACRPRCT,3)

 Q

D1 S ACRJ=ACRJ+1

 S ACRY=$E($P(^ACRDG(ACRDGDA,"GP",ACRX,0),U),1,25)

 S ACRP=$P(^ACRDG(ACRDGDA,"GP",ACRX,"DT"),U,3)

 W:ACRJ#2=1 !

 W:ACRJ#2=0 ?40,"| "

 W ACRX

 W ?$X+8-$L(ACRX),ACRY

 W ?$X+28-$L(ACRY),ACRP

 D:ACRJ#20=0 PAUSE

 Q

D2 S:$D(^ACRDG(ACRDGDA,"GP",ACRX,"DT")) ACRPRCT=ACRPRCT+$P(^("DT"),U,3)

 Q

A1 S DIR(0)="SO^1:ADD;2:EDIT;3:DELETE^K:X'?1N!(X<1)!(X>3) X"

 S DIR("A")="  Option"

 D DIR^ACRFDIC

 Q:$D(ACRQUIT)!$D(ACROUT)

 I X=1 D SIB I $D(ACRQUIT)!$D(ACROUT) S X=1 K ACRQUIT Q

 I X=2 F  D SIB1 I $D(ACRQUIT)!$D(ACROUT) S X=1 K ACRQUIT Q

 D:X=3 DELETEM

 K ACRQUIT

 Q

DELETE D GET^ACRFEDG1

 Q:+Y<1

 S DA=ACRDGDA

 S DIK="^ACRDG("

 D DIK^ACRFDIC

 Q

DELETEM D GETM^ACRFEDG1

 Q:+Y<1

 S DA(1)=ACRDGDA

 S DA=ACRDGMDA

 S DIK="^ACRDG("_ACRDGDA_",""GP"","

 D DIK^ACRFDIC

 Q

PAUSE K ACRPSE

 S DIR(0)="YO"

 S DIR("A")="         List more MEMBERS"

 S DIR("B")="NO"

 W !

 D DIR^ACRFDIC

 S:Y'=1 ACRPSE=""

 Q

AREA ;;AUTTAREA(;;AREA OFFICE.........: ;;

SU ;;AUTTSU(;;SERVICE UNIT........: ;;

FAC ;;AUTTLOC(;;FACILITY............: ;;

OFFICE ;;AUTTPRG(;;OFFICE/DIV/BR/DEPT..: ;;

HEAD W @IOF

 W !!,@ACRON,ACRDG,@ACROF," Fund Distribution Group"

 W !!?35,"STD"

 W ?77,"STD"

 W !,"ID NO."

 W ?8,"MEMBER"

 W ?36,"%"

 W ?42,"ID NO."

 W ?50,"MEMBER"

 W ?78,"%"

 W !,"------"

 W ?8,"-------------------------"

 W ?35,"---"

 W ?40,"| ------"

 W ?50,"-------------------------"

 W ?77,"---"

 Q

ACREDG ;EP;

 S ACRFEDG="" D EN

 Q

ACRFEDG   ;IHS/OIRM/DSD/THL,AEF - ESTABLISH DISTRIBUTION GROUP; [ 11/01/2001   9:44 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001

 +2       ;;ROUTINE TO ESTABLISH FUND DISTRIBUTION GROUP

EN         NEW ACRI

 +1        FOR 

               DO EN1

               IF $DATA(ACRQUIT)!$DATA(ACROUT)

                   QUIT 

EXIT       KILL ACRQUIT,ACRX,ACRY,ACRDGDA,ACRDG,ACRDGMDA,ACRDGM,ACRPRCT,ACRFEDG

 +1        QUIT 

EN1        WRITE @IOF

 +1        SET ACRX="MANAGE FUND DISTRIBUTION GROUPS"

 +2        WRITE !!?80-$LENGTH(ACRX)\2,ACRX

 +3        WRITE !?80-$LENGTH(ACRX)\2

 +4        FOR ACRI=1:1:$LENGTH(ACRX)

               WRITE "="

 +5        SET DIR(0)="SO^1:ADD/EDIT;2:DELETE^K:X'?1N!(X<1)!(X>2) X"

 +6        SET DIR("A")="  Option"

 +7        DO DIR^ACRFDIC

 +8        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +9        IF X=1

               DO ADD

               QUIT 

 +10       DO DELETE

 +11       KILL ACRQUIT

 +12       QUIT 

ADD        FOR 

               DO ADD1

               IF $DATA(ACRQUIT)!$DATA(ACROUT)

                   QUIT 

 +1        KILL ACRQUIT

 +2        QUIT 

ADD1       DO GET^ACRFEDG1

 +1        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +2        FOR 

               DO DISPLAY

               IF ACRJ=1

                   DO SIB

               IF ACRJ>1

                   DO A1

               IF $DATA(ACRQUIT)!$DATA(ACROUT)

                   KILL ACRQUIT

                   QUIT 

 +3        QUIT 

SIB        WRITE !!,"Add MEMBERS for the ",@ACRON,ACRDG,@ACROF," Fund Distribution Group by:"

 +1        SET DIR(0)="SO^1:Office/Div/Branch/Dept;2:Area;3:Service Unit;4:Facility^K:X'?1N!(X<1)!(X>5) X"

 +2        SET DIR("A")="Member Type"

 +3        DO DIR^ACRFDIC

 +4        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +5        SET ACRX=$SELECT(X=1:"OFFICE",X=2:"AREA",X=3:"SU",X=4:"FAC")

 +6        FOR 

               DO S1

               IF +Y<1

                   QUIT 

 +7        QUIT 

S1         SET ACRY=$PIECE($TEXT(@ACRX),";;",2,99)

 +1        SET DIC(0)="AEMQZ"

 +2        SET (ACRGLB,DIC)=$PIECE(ACRY,";;")

 +3        SET DIC=U_DIC

 +4        SET DIC("A")=$PIECE(ACRY,";;",2)

 +5        WRITE !

 +6        DO DIC^ACRFDIC

 +7        IF +Y<1

               QUIT 

 +8        SET ACRDFN=+Y

           SET ACRY=Y(0,0)

 +9        DO NEWM

 +10       QUIT 

SIB1       DO GETM^ACRFEDG1

 +1        IF +Y<1

               QUIT 

 +2        IF $DATA(^ACRDG(ACRDGDA,"GP","B"))

               Begin DoDot:1

 +3                SET (ACRX,ACRY)=0

 +4                FOR 

                       SET ACRX=$ORDER(^ACRDG(ACRDGDA,"GP",ACRX))

                       IF 'ACRX

                           QUIT 

                       IF $DATA(^ACRDG(ACRDGDA,"GP",ACRX,"DT"))

                           SET ACRY=ACRY+$PIECE(^("DT"),U,3)

               End DoDot:1

               IF 1

 +5       IF '$TEST

               SET ACRY=0

 +6        SET DA=ACRDGMDA

 +7        SET DIE="^ACRDG("_ACRDGDA_",""GP"","

 +8        SET DIE("NO^")="NO"

 +9        SET DR=".02T;.03T;.04T;S ACRY=ACRY-$P(^ACRDG(ACRDGDA,""GP"",DA,""DT""),U,3);10T;I $P(^ACRDG(ACRDGDA,""GP"",DA,""DT""),U,3)+ACRY>100 K X S $P(^(""DT""),U,3)=100-ACRY W *7,*7,!!,""TOTAL PERCENT CANNOT BE GREATER THAN 100."" S Y=10"

 +10       DO DIE^ACRFDIC

 +11       QUIT 

NEWM       IF '$DATA(@("^ACRDG("_ACRDGDA_",""GP"",0)"))

               SET @("^ACRDG("_ACRDGDA_",""GP"",0)")="^9002198.01^^"

 +1        SET DA(1)=ACRDGDA

 +2        SET X=ACRY

 +3        SET DIC="^ACRDG("_ACRDGDA_",""GP"","

 +4        SET DIC(0)="AELMQZ"

 +5        SET DIC("DR")=".02T;.03T;.04T;1////"_ACRGLB_";2////"_ACRDFN_";10T"

 +6        DO FILE^ACRFDIC

 +7        QUIT 

DISPLAY   ;EP;TO DISPLAY DISTRIBUTION

 +1        DO HEAD

 +2        SET (ACRJ,ACRX)=0

 +3        FOR 

               SET ACRX=$ORDER(^ACRDG(ACRDGDA,"GP",ACRX))

               IF 'ACRX

                   QUIT 

               DO D1

               IF $DATA(ACRPSE)

                   QUIT 

 +4        IF ACRJ=0

               IF '$DATA(ACRFEDG)

                   Begin DoDot:1

 +5                    WRITE !,"NO FUND DISTRIBUTION GROUP MEMBERS"

 +6                    WRITE !,"GROUP MEMBERS MUST BE ESTABLISHED"

 +7                    WRITE !,"VIA SYSTEM SETUP.  CONSULT YOUR SYSTEMS"

 +8                    WRITE !,"MANAGER FOR ASSISTANCE."

 +9                    SET ACRQUIT=""

 +10                   HANG 3

                   End DoDot:1

                   QUIT 

 +11       IF ACRJ=0

               IF $DATA(ACRFEDG)

                   DO SIB

                   QUIT 

 +12       IF ACRJ>0

               Begin DoDot:1

 +13               SET (ACRX,ACRPRCT)=0

 +14               FOR 

                       SET ACRX=$ORDER(^ACRDG(ACRDGDA,"GP",ACRX))

                       IF 'ACRX

                           QUIT 

                       DO D2

               End DoDot:1

 +15       IF ACRJ>1

               Begin DoDot:1

 +16               WRITE !?19,"TOTAL PERCENT:"

 +17               WRITE ?35,$JUSTIFY(ACRPRCT,3)

               End DoDot:1

 +18       QUIT 

D1         SET ACRJ=ACRJ+1

 +1        SET ACRY=$EXTRACT($PIECE(^ACRDG(ACRDGDA,"GP",ACRX,0),U),1,25)

 +2        SET ACRP=$PIECE(^ACRDG(ACRDGDA,"GP",ACRX,"DT"),U,3)

 +3        IF ACRJ#2=1

               WRITE !

 +4        IF ACRJ#2=0

               WRITE ?40,"| "

 +5        WRITE ACRX

 +6        WRITE ?$X+8-$LENGTH(ACRX),ACRY

 +7        WRITE ?$X+28-$LENGTH(ACRY),ACRP

 +8        IF ACRJ#20=0

               DO PAUSE

 +9        QUIT 

D2         IF $DATA(^ACRDG(ACRDGDA,"GP",ACRX,"DT"))

               SET ACRPRCT=ACRPRCT+$PIECE(^("DT"),U,3)

 +1        QUIT 

A1         SET DIR(0)="SO^1:ADD;2:EDIT;3:DELETE^K:X'?1N!(X<1)!(X>3) X"

 +1        SET DIR("A")="  Option"

 +2        DO DIR^ACRFDIC

 +3        IF $DATA(ACRQUIT)!$DATA(ACROUT)

               QUIT 

 +4        IF X=1

               DO SIB

               IF $DATA(ACRQUIT)!$DATA(ACROUT)

                   SET X=1

                   KILL ACRQUIT

                   QUIT 

 +5        IF X=2

               FOR 

                   DO SIB1

                   IF $DATA(ACRQUIT)!$DATA(ACROUT)

                       SET X=1

                       KILL ACRQUIT

                       QUIT 

 +6        IF X=3

               DO DELETEM

 +7        KILL ACRQUIT

 +8        QUIT 

DELETE     DO GET^ACRFEDG1

 +1        IF +Y<1

               QUIT 

 +2        SET DA=ACRDGDA

 +3        SET DIK="^ACRDG("

 +4        DO DIK^ACRFDIC

 +5        QUIT 

DELETEM    DO GETM^ACRFEDG1

 +1        IF +Y<1

               QUIT 

 +2        SET DA(1)=ACRDGDA

 +3        SET DA=ACRDGMDA

 +4        SET DIK="^ACRDG("_ACRDGDA_",""GP"","

 +5        DO DIK^ACRFDIC

 +6        QUIT 

PAUSE      KILL ACRPSE

 +1        SET DIR(0)="YO"

 +2        SET DIR("A")="         List more MEMBERS"

 +3        SET DIR("B")="NO"

 +4        WRITE !

 +5        DO DIR^ACRFDIC

 +6        IF Y'=1

               SET ACRPSE=""

 +7        QUIT 

AREA      ;;AUTTAREA(;;AREA OFFICE.........: ;;

SU        ;;AUTTSU(;;SERVICE UNIT........: ;;

FAC       ;;AUTTLOC(;;FACILITY............: ;;

OFFICE    ;;AUTTPRG(;;OFFICE/DIV/BR/DEPT..: ;;

HEAD       WRITE @IOF

 +1        WRITE !!,@ACRON,ACRDG,@ACROF," Fund Distribution Group"

 +2        WRITE !!?35,"STD"

 +3        WRITE ?77,"STD"

 +4        WRITE !,"ID NO."

 +5        WRITE ?8,"MEMBER"

 +6        WRITE ?36,"%"

 +7        WRITE ?42,"ID NO."

 +8        WRITE ?50,"MEMBER"

 +9        WRITE ?78,"%"

 +10       WRITE !,"------"

 +11       WRITE ?8,"-------------------------"

 +12       WRITE ?35,"---"

 +13       WRITE ?40,"| ------"

 +14       WRITE ?50,"-------------------------"

 +15       WRITE ?77,"---"

 +16       QUIT 

ACREDG    ;EP;

 +1        SET ACRFEDG=""

           DO EN

 +2        QUIT