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
