ACRFDIS ;IHS/OIRM/DSD/THL,AEF - ENTER DISTRIBUTION OF DEPARTMENT ACCOUNT; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;ROUTINE USED TO ENTER DISTRIBUTION OF DEPARTMENT ACCOUNT
EN N ACRI,ACRJ
F D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
EXIT K ACR,ACRX,ACRLBDA,ACRALCDA,ACROBJ,ACROBJDA,ACRQUIT,ACRDA,ACRA,ACRMAX,ACRQUIT,ACRQUIT,ACRCANDA
Q
EN1 D DISPLAY
D ENTER
Q
DISPLAY W @IOF
D:$D(ACRDISP) SUBHEAD^ACRFDTP2
W !
K ACR,ACRX
D HEAD
D OCDIS
S ACRJ=0
F ACRI=1:1 D Q:$D(ACRQUIT)!$D(ACROUT)
.D LIST
.D PAUSE:ACRI#10=0
K ACRQUIT
Q
LIST I '$D(ACRX(ACRI)) S ACRQUIT="" Q
S ACRJ=ACRI
D W
Q:'$D(ACRX(ACRJ+1))
S ACRJ=ACRI+10
D W:$D(ACRX(ACRJ))
Q
W I ACRJ=ACRI D
.W !,ACRJ
.W ?4
I ACRJ'=ACRI D
.W ?40,"| ",ACRJ
.W ?46
W $E($P(ACRX(ACRJ),U,5),1,4)
W ?$X+1,$J($P($P(ACRX(ACRJ),U),"."),9)
W ?$X+1,$J($P($P(ACRX(ACRJ),U,2),"."),7)
W ?$X+1,$J($P($P(ACRX(ACRJ),U,4),"."),7)
Q
OC2 S ACRA=$O(ACR(ACRX,0))
F ACRI=1:1:4 S ACRI(ACRI)=$P(ACR(ACRX,ACRA),U,ACRI)
Q
ENTER S DIR(0)="SO^1:Add DISTRIBUTION;2:Change DISTRIBUTION"
S DIR("A")="Which one"
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)
N ACRY
S ACRY=Y
D:ACRY=1 NEW
D:ACRY=2 MOD
Q
NEW S DIC="^AUTTOBJC("
S DIC(0)="AEMQZ"
S DIC("A")="Which OBJECT CODE: "
W !
D DIC^ACRFDIC
I $E(X)[U!(Y<1) S ACRQUIT="" Q
S ACROBJDA=+Y,ACROBJ=Y(0,0)_" "
I $D(ACR(ACROBJ)) D W1 Q
S DIR(0)="YO"
S DIR("A")="ADD a DISTRIBUTION for OBJECT CODE "_ACROBJ
W !
D DIR^ACRFDIC
Q:Y'=1
S X=0.00
S DIC="^ACRFDIS("
S DIC(0)="L"
S DIC("DR")="1////0.00;2////0.00;3////0.00;.02////"_DT_";.09////"_ACRFDNFY_";.03////"_ACROBJDA_";.05////"_ACRALCDA_";.06////"_ACRCANDA_";.07////"_ACRSSADA_";.08////"_ACRALWDA_";.04////"_ACRLBDA
D FILE^ACRFDIC
S DA=+Y
S DIE="^ACRFDIS("
S DR=".01NEW DISTRIBUTION....: ;.02////"_DT
W !!
S ACR="!,""AMOUNT AVAILABLE....: "",@ACRON,$J($FN(ACRFDNDD,""P"",2),10),@ACROF"
W @ACR
D DIE^ACRFDIC
Q
MOD S DIR(0)="NO^1:"_ACRMAX
S DIR("A")="Which one"
W !
D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
S ACRY=Y
S ACRA=$P(ACRX(ACRY),U,3)
S ACROBJ=$P(^AUTTOBJC($P(^ACRFDIS(ACRA,0),U,3),0),U)
W !!?5,"CURRENT DISTRIBUTION FOR THIS OBJECT CODE FOR THIS DEPARTMENT ACCOUNT"
W !?5,"----------------------------------------------------------------"
W !?10,"OBJT"
W !?10,"CLSS"
W ?16,"DISTRIBTION"
W !?10,"----"
W ?16,"-----------"
W !?10,ACROBJ
W ?16,$J($P(^ACRFDIS(ACRA,0),U),11)
S DA=ACRA
S DIE="^ACRFDIS("
S DR=".01NEW DISTRIBUTION...."
S ACR="!,""AMOUNT AVAILABLE....: "",@ACRON,$J($FN(ACRFDNDD,""P"",2),10),@ACROF"
W !!
W @ACR
D DIE^ACRFDIC
Q
PAUSE S DIR(0)="YO"
S DIR("A")=" List more OBJECT CODES"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
I Y=1 D Q
.S ACRI=ACRI+10
.D HEAD
S ACRQUIT=""
Q
OCDIS S ACRA=0
F ACRJ=1:1 S ACRA=$O(^ACRFDIS("LB",ACRLBDA,ACRA)) Q:'ACRA D OCDIS1
S ACRMAX=ACRJ-1
S ACRA=0
F ACRJ=1:1 S ACRA=$O(ACR(ACRA)) Q:'ACRA S ACRX(ACRJ)=ACR(ACRA)
S ACRMAX=ACRJ-1
Q
OCDIS1 S ACR=$P(^AUTTOBJC($P(^ACRFDIS(ACRA,0),U,3),0),U)_" "
S:'$D(ACR(ACR)) ACR(ACR)="^^"_ACRA_"^^"_ACR
D OCDIS2
Q
OCDIS2 S $P(ACR(ACR),U)=$P(ACR(ACR),U)+$P(^ACRFDIS(ACRA,0),U)
F ACRI=2,4 S $P(ACR(ACR),U,ACRI)=$P(ACR(ACR),U,ACRI)+$P($G(^ACRFDIS(ACRA,"BA")),U,ACRI)
Q
HEAD W !?4,"OBJT"
W ?11,"Y-T-D"
W ?40,"|"
W ?46,"OBJT"
W ?53,"Y-T-D"
W !,"NO."
W ?4,"CLSS"
W ?9,"DISTRIBTN"
W ?19,"PENDNG"
W ?27,"OBLGTED"
W ?40,"| NO."
W ?46,"CLSS"
W ?51,"DISTRIBTN"
W ?61,"PENDNG"
W ?69,"OBLGTED"
W !,"---"
W ?4,"----"
W ?9,"---------"
W ?19,"-------"
W ?27,"-------"
W ?40,"| ---"
W ?46,"----"
W ?51,"---------"
W ?61,"-------"
W ?69,"-------"
Q
W1 W !!,*7,"A distribution for this OBJECT CODE already exists."
H 2
Q
ACRFDIS ;IHS/OIRM/DSD/THL,AEF - ENTER DISTRIBUTION OF DEPARTMENT ACCOUNT; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;ROUTINE USED TO ENTER DISTRIBUTION OF DEPARTMENT ACCOUNT
EN NEW ACRI,ACRJ
+1 FOR
DO EN1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
EXIT KILL ACR,ACRX,ACRLBDA,ACRALCDA,ACROBJ,ACROBJDA,ACRQUIT,ACRDA,ACRA,ACRMAX,ACRQUIT,ACRQUIT,ACRCANDA
+1 QUIT
EN1 DO DISPLAY
+1 DO ENTER
+2 QUIT
DISPLAY WRITE @IOF
+1 IF $DATA(ACRDISP)
DO SUBHEAD^ACRFDTP2
+2 WRITE !
+3 KILL ACR,ACRX
+4 DO HEAD
+5 DO OCDIS
+6 SET ACRJ=0
+7 FOR ACRI=1:1
Begin DoDot:1
+8 DO LIST
+9 IF ACRI#10=0
DO PAUSE
End DoDot:1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+10 KILL ACRQUIT
+11 QUIT
LIST IF '$DATA(ACRX(ACRI))
SET ACRQUIT=""
QUIT
+1 SET ACRJ=ACRI
+2 DO W
+3 IF '$DATA(ACRX(ACRJ+1))
QUIT
+4 SET ACRJ=ACRI+10
+5 IF $DATA(ACRX(ACRJ))
DO W
+6 QUIT
W IF ACRJ=ACRI
Begin DoDot:1
+1 WRITE !,ACRJ
+2 WRITE ?4
End DoDot:1
+3 IF ACRJ'=ACRI
Begin DoDot:1
+4 WRITE ?40,"| ",ACRJ
+5 WRITE ?46
End DoDot:1
+6 WRITE $EXTRACT($PIECE(ACRX(ACRJ),U,5),1,4)
+7 WRITE ?$X+1,$JUSTIFY($PIECE($PIECE(ACRX(ACRJ),U),"."),9)
+8 WRITE ?$X+1,$JUSTIFY($PIECE($PIECE(ACRX(ACRJ),U,2),"."),7)
+9 WRITE ?$X+1,$JUSTIFY($PIECE($PIECE(ACRX(ACRJ),U,4),"."),7)
+10 QUIT
OC2 SET ACRA=$ORDER(ACR(ACRX,0))
+1 FOR ACRI=1:1:4
SET ACRI(ACRI)=$PIECE(ACR(ACRX,ACRA),U,ACRI)
+2 QUIT
ENTER SET DIR(0)="SO^1:Add DISTRIBUTION;2:Change DISTRIBUTION"
+1 SET DIR("A")="Which one"
+2 DO DIR^ACRFDIC
+3 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+4 NEW ACRY
+5 SET ACRY=Y
+6 IF ACRY=1
DO NEW
+7 IF ACRY=2
DO MOD
+8 QUIT
NEW SET DIC="^AUTTOBJC("
+1 SET DIC(0)="AEMQZ"
+2 SET DIC("A")="Which OBJECT CODE: "
+3 WRITE !
+4 DO DIC^ACRFDIC
+5 IF $EXTRACT(X)[U!(Y<1)
SET ACRQUIT=""
QUIT
+6 SET ACROBJDA=+Y
SET ACROBJ=Y(0,0)_" "
+7 IF $DATA(ACR(ACROBJ))
DO W1
QUIT
+8 SET DIR(0)="YO"
+9 SET DIR("A")="ADD a DISTRIBUTION for OBJECT CODE "_ACROBJ
+10 WRITE !
+11 DO DIR^ACRFDIC
+12 IF Y'=1
QUIT
+13 SET X=0.00
+14 SET DIC="^ACRFDIS("
+15 SET DIC(0)="L"
+16 SET DIC("DR")="1////0.00;2////0.00;3////0.00;.02////"_DT_";.09////"_ACRFDNFY_";.03////"_ACROBJDA_";.05////"_ACRALCDA_";.06////"_ACRCANDA_";.07////"_ACRSSADA_";.08////"_ACRALWDA_";.04////"_ACRLBDA
+17 DO FILE^ACRFDIC
+18 SET DA=+Y
+19 SET DIE="^ACRFDIS("
+20 SET DR=".01NEW DISTRIBUTION....: ;.02////"_DT
+21 WRITE !!
+22 SET ACR="!,""AMOUNT AVAILABLE....: "",@ACRON,$J($FN(ACRFDNDD,""P"",2),10),@ACROF"
+23 WRITE @ACR
+24 DO DIE^ACRFDIC
+25 QUIT
MOD SET DIR(0)="NO^1:"_ACRMAX
+1 SET DIR("A")="Which one"
+2 WRITE !
+3 DO DIR^ACRFDIC
+4 IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+5 SET ACRY=Y
+6 SET ACRA=$PIECE(ACRX(ACRY),U,3)
+7 SET ACROBJ=$PIECE(^AUTTOBJC($PIECE(^ACRFDIS(ACRA,0),U,3),0),U)
+8 WRITE !!?5,"CURRENT DISTRIBUTION FOR THIS OBJECT CODE FOR THIS DEPARTMENT ACCOUNT"
+9 WRITE !?5,"----------------------------------------------------------------"
+10 WRITE !?10,"OBJT"
+11 WRITE !?10,"CLSS"
+12 WRITE ?16,"DISTRIBTION"
+13 WRITE !?10,"----"
+14 WRITE ?16,"-----------"
+15 WRITE !?10,ACROBJ
+16 WRITE ?16,$JUSTIFY($PIECE(^ACRFDIS(ACRA,0),U),11)
+17 SET DA=ACRA
+18 SET DIE="^ACRFDIS("
+19 SET DR=".01NEW DISTRIBUTION...."
+20 SET ACR="!,""AMOUNT AVAILABLE....: "",@ACRON,$J($FN(ACRFDNDD,""P"",2),10),@ACROF"
+21 WRITE !!
+22 WRITE @ACR
+23 DO DIE^ACRFDIC
+24 QUIT
PAUSE SET DIR(0)="YO"
+1 SET DIR("A")=" List more OBJECT CODES"
+2 SET DIR("B")="NO"
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF Y=1
Begin DoDot:1
+6 SET ACRI=ACRI+10
+7 DO HEAD
End DoDot:1
QUIT
+8 SET ACRQUIT=""
+9 QUIT
OCDIS SET ACRA=0
+1 FOR ACRJ=1:1
SET ACRA=$ORDER(^ACRFDIS("LB",ACRLBDA,ACRA))
IF 'ACRA
QUIT
DO OCDIS1
+2 SET ACRMAX=ACRJ-1
+3 SET ACRA=0
+4 FOR ACRJ=1:1
SET ACRA=$ORDER(ACR(ACRA))
IF 'ACRA
QUIT
SET ACRX(ACRJ)=ACR(ACRA)
+5 SET ACRMAX=ACRJ-1
+6 QUIT
OCDIS1 SET ACR=$PIECE(^AUTTOBJC($PIECE(^ACRFDIS(ACRA,0),U,3),0),U)_" "
+1 IF '$DATA(ACR(ACR))
SET ACR(ACR)="^^"_ACRA_"^^"_ACR
+2 DO OCDIS2
+3 QUIT
OCDIS2 SET $PIECE(ACR(ACR),U)=$PIECE(ACR(ACR),U)+$PIECE(^ACRFDIS(ACRA,0),U)
+1 FOR ACRI=2,4
SET $PIECE(ACR(ACR),U,ACRI)=$PIECE(ACR(ACR),U,ACRI)+$PIECE($GET(^ACRFDIS(ACRA,"BA")),U,ACRI)
+2 QUIT
HEAD WRITE !?4,"OBJT"
+1 WRITE ?11,"Y-T-D"
+2 WRITE ?40,"|"
+3 WRITE ?46,"OBJT"
+4 WRITE ?53,"Y-T-D"
+5 WRITE !,"NO."
+6 WRITE ?4,"CLSS"
+7 WRITE ?9,"DISTRIBTN"
+8 WRITE ?19,"PENDNG"
+9 WRITE ?27,"OBLGTED"
+10 WRITE ?40,"| NO."
+11 WRITE ?46,"CLSS"
+12 WRITE ?51,"DISTRIBTN"
+13 WRITE ?61,"PENDNG"
+14 WRITE ?69,"OBLGTED"
+15 WRITE !,"---"
+16 WRITE ?4,"----"
+17 WRITE ?9,"---------"
+18 WRITE ?19,"-------"
+19 WRITE ?27,"-------"
+20 WRITE ?40,"| ---"
+21 WRITE ?46,"----"
+22 WRITE ?51,"---------"
+23 WRITE ?61,"-------"
+24 WRITE ?69,"-------"
+25 QUIT
W1 WRITE !!,*7,"A distribution for this OBJECT CODE already exists."
+1 HANG 2
+2 QUIT
