ACRFPAID ;IHS/OIRM/DSD/THL,AEF - RECONCILE PAID AMOUNTS; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;
DOCPAID ;EP;CALCULATE AMOUNT PAID FOR ALL ITEMS ON A DOCUMENT
N ACRSSDA
S ACRSSDA=0
F S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA D ITEM
Q
ITEM ;CALCULATE AMOUNT PAID FOR AN ITEM
N ACRITOT,ACRRRDA
S ACRITOT=0
S ACRRRDA=0
F S ACRRRDA=$O(^ACRRR("B",ACRSSDA,ACRRRDA)) Q:'ACRRRDA D
.Q:'$P($G(^ACRRR(ACRRRDA,0)),U,11)
.S X=$G(^ACRRR(ACRRRDA,"DT"))
.S ACRITOT=ACRITOT+($P(X,U,5)*$P(X,U,6))
Q:'ACRITOT
S DA=ACRSSDA
S DIE="^ACRSS("
S DR="16.1////"_ACRITOT
I $G(ACRFINAL)'=1 S $P(^ACRSS(ACRSSDA,"DT"),U,21)=ACRITOT
E D DIE^ACRFDIC
Q
TVPAID ;EP;ENTER TRAVEL EXPENSES PAID
D ALTOT^ACRFCLM
S ACRSSDA=0
F S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA D
.S ACRSS0=$G(^ACRSS(ACRSSDA,0)),ACRSSDT=$G(^ACRSS(ACRSSDA,"DT"))
.S ACRITOT=$S(+ACRSS0'=1:$P(ACRSSDT,U,9),1:ACRALTOT)
.S DA=ACRSSDA
.S DIE="^ACRSS("
.S DR="16.1////"_ACRITOT
.D DIE^ACRFDIC
Q
PAIDUP ;EP;TO UPDATE ARMS WHEN 1166 BATCH IS CERTIFIED
Q:'$G(ACRFYDA)!'$G(ACRBATDA)
N ACRBATNO,ACRBTYP
S ACRBATNO=$P($G(^AFSLAFP(ACRFYDA,1,ACRBATDA,0)),U)
Q:ACRBATNO=""
S ACRBTYP=$S("ABCG"[$E(ACRBATNO):"V","DEF"[$E(ACRBATNO):"T",1:"")
Q:ACRBTYP=""
N ACRSEQDA
S ACRSEQDA=0
F S ACRSEQDA=$O(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA)) Q:'ACRSEQDA D
.Q:'+$G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,"ARMS")) S ACRDOCDA=+^("ARMS")
.D DOCPAID:$G(ACRBTYP)="V"
.D TVPAID:$G(ACRBTYP)="T"
Q
SYNC ;EP;TO SYNCHRONIZE ARMS FMS DOCUMENT POINTER IN 1166 RECORDS
D ^XBKVAR
D DCALC
D TCALC
D ODOC
N ACRDOC
S ACRDOC=""
F S ACRDOC=$O(^AFSLAFP("N",ACRDOC)) Q:ACRDOC="" D
.S ACRDOCDA=$O(^ACRDOC("C",ACRDOC,0))
.I 'ACRDOCDA S ACRDOCDA=$O(^ACRDOC("B",ACRDOC,0))
.Q:'ACRDOCDA
.N ACRFYDA
.S ACRFYDA=0
.F S ACRFYDA=$O(^AFSLAFP("N",ACRDOC,ACRFYDA)) Q:'ACRFYDA D
..N ACRBATDA
..S ACRBATDA=0
..F S ACRBATDA=$O(^AFSLAFP("N",ACRDOC,ACRFYDA,ACRBATDA)) Q:'ACRBATDA D
...N ACRSEQDA
...S ACRSEQDA=0
...F S ACRSEQDA=$O(^AFSLAFP("N",ACRDOC,ACRFYDA,ACRBATDA,ACRSEQDA)) Q:'ACRSEQDA D
....S DA=ACRSEQDA
....S DA(2)=ACRFYDA
....S DA(1)=ACRBATDA
....S DIE="^AFSLAFP("_DA(2)_",1,"_DA(1)_",1,"
....S DR=".02////"_ACRDOCDA
....D DIE^ACRFDIC
....W "*" ;!,ACRDOC,?10,ACRDOCDA,?20,ACRFYDA,?30,ACRBATDA,?40,ACRSEQDA
Q
DCALC ;EP;CALCULATE ACTUAL PAID AMOUNT FOR ALL DOCUMENTS
N ACRDOCDA
S ACRDOCDA=0
F S ACRDOCDA=$O(^ACRRR("C",ACRDOCDA)) Q:'ACRDOCDA D DOCPAID W "."
Q
TCALC ;EP;TO CALCULATE TRAVEL EXPENSES PAID
N ACRDOCDA
S ACRDOCDA=0
F S ACRDOCDA=$O(^ACRDOC("REF",133,ACRDOCDA)) Q:'ACRDOCDA I $P($G(^ACROBL(ACRDOCDA,"APV")),U,8)="A" D TVPAID W "."
Q
ODOC ;EP;TO CALCULATE DISBURSEMENTS FOR ARMS DOCUMENTS FROM THE OPEN
;DOCUMENT FILE
K ACRDTOT
N ACRDOCDA,ACRATOT,ACRDOC,ACRDTOT,ACROFYDA,ACRODDA,ACRITOT,ACRPTOT
S ACRDOCDA=0
F S ACRDOCDA=$O(^ACRDOC(ACRDOCDA)) Q:'ACRDOCDA D
.Q:$P(^ACRDOC(ACRDOCDA,0),U,15)
.S ACRDOC=$S($P(^ACRDOC(ACRDOCDA,0),U,2)]"":$P(^(0),U,2),1:$P(^(0),U))
.I ACRDOC["-" S ACRDOC=$TR(ACRDOC,"-",""),ACRDOC=$E(ACRDOC,2,11)
.Q:ACRDOC=""
.D O1
.D O2
.D O3
.I ACRDTOT,ACRDTOT'=ACRITOT D
..W "." ;!,ACRDOC,?15,$J($FN(ACRDTOT,"P,",2),12),?30,$J($FN(ACRATOT,"P,",2),12),?45,$J($FN(ACRITOT,"P,",2),12),?60,$J($FN(ACRPTOT,"P,",2),12)
..I $P(^ACROBL(ACRDOCDA,"APV"),U,6)=1,$P(^("DT"),U,2)'=ACRATOT S $P(^("DT"),U,2)=$S(ACRDTOT>ACRATOT:ACRDTOT,1:ACRATOT)
Q
O1 N ACROFYDA,X
S (ACROFYDA,ACRDTOT)=0
F S ACROFYDA=$O(^AFSLODOC("DOCNO",ACRDOC,ACROFYDA)) Q:'ACROFYDA D
.N ACRODDA
.S ACRODDA=0
.F S ACRODDA=$O(^AFSLODOC("DOCNO",ACRDOC,ACROFYDA,ACRODDA)) Q:'ACRODDA D
..S X=$P($G(^AFSLODOC(ACROFYDA,1,ACRODDA,4)),U,4)
..S:$E(X)="+" X=+$E(X,2,99)
..S X=+X
..S:X ACRDTOT=ACRDTOT+X
S:ACRDTOT ACRDTOT=ACRDTOT/100
Q
O2 N X
S (X,ACRITOT,ACRPTOT)=0
F S X=$O(^ACRSS("J",ACRDOCDA,X)) Q:'X S ACRITOT=ACRITOT+$P($G(^ACRSS(X,"DT")),U,4),ACRPTOT=ACRPTOT+$P($G(^("DT")),U,21)
N Z
S Z=0
F S Z=$O(^ACRDOC("MOD",ACRDOCDA,Z)) Q:'Z D O21
Q
O21 S X=0
F S X=$O(^ACRSS("J",Z,X)) Q:'X S ACRITOT=ACRITOT+$P($G(^ACRSS(X,"DT")),U,4),ACRPTOT=ACRPTOT+$P($G(^("DT")),U,21)
Q
O3 N X,Y,Z
S (X,ACRATOT)=0
F S X=$O(^AFSLAFP("N",ACRDOC,X)) Q:'X D
.S Y=0
.F S Y=$O(^AFSLAFP("N",ACRDOC,X,Y)) Q:'Y D
..S Z=0
..F S Z=$O(^AFSLAFP("N",ACRDOC,X,Y,Z)) Q:'Z S ACRATOT=ACRATOT+$P($G(^AFSLAFP(X,1,Y,1,Z,0)),U,11)-$P($G(^(0)),U,12)+$P($G(^(1)),U,6)
Q
MODS ;EP; SYNC ARMS PO MODS
N ACRDOCX,ACRDOCDA,ACRITOT,ACRRRDA
S ACRDOCX=0
F S ACRDOCX=$O(^ACRDOC("MOD",ACRDOCX)) Q:'ACRDOCX D
.S (ACRDOCDA,ACRITOT)=0
.F S ACRDOCDA=$O(^ACRDOC("MOD",ACRDOCX,ACRDOCDA)) Q:'ACRDOCDA D
..S ACRRRDA=0
..F S ACRRRDA=$O(^ACRRR("C",ACRDOCDA,ACRRRDA)) Q:'ACRRRDA D
...Q:'$P(^ACRRR(ACRRRDA,0),U,11)&'$P(^("DT"),U,5) S X=^("DT")
...S ACRITOT=ACRITOT+($P(X,U,5)*$P(X,U,6))
...S ACRDOC=$S($P(^ACRDOC(ACRDOCDA,0),U,2)]"":$P(^(0),U,2),1:$P(^(0),U))
...I ACRDOC["-" S ACRDOC=$TR(ACRDOC,"-",""),ACRDOC=$E(ACRDOC,2,11)
...S X=0
...F S X=$O(^AFSLAFP("N",ACRDOC,X)) Q:'X D
....S Y=0
....F S Y=$O(^AFSLAFP("N",ACRDOC,X,Y)) Q:'Y D
.....S Z=0
.....F S Z=$O(^AFSLAFP("N",ACRDOC,X,Y,Z)) Q:'Z I $P(^AFSLAFP(X,1,Y,1,Z,0),U,11)=ACRITOT W !,ACRDOC,?15,ACRDOCDA
Q
ACRFPAID ;IHS/OIRM/DSD/THL,AEF - RECONCILE PAID AMOUNTS; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;
DOCPAID ;EP;CALCULATE AMOUNT PAID FOR ALL ITEMS ON A DOCUMENT
+1 NEW ACRSSDA
+2 SET ACRSSDA=0
+3 FOR
SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
IF 'ACRSSDA
QUIT
DO ITEM
+4 QUIT
ITEM ;CALCULATE AMOUNT PAID FOR AN ITEM
+1 NEW ACRITOT,ACRRRDA
+2 SET ACRITOT=0
+3 SET ACRRRDA=0
+4 FOR
SET ACRRRDA=$ORDER(^ACRRR("B",ACRSSDA,ACRRRDA))
IF 'ACRRRDA
QUIT
Begin DoDot:1
+5 IF '$PIECE($GET(^ACRRR(ACRRRDA,0)),U,11)
QUIT
+6 SET X=$GET(^ACRRR(ACRRRDA,"DT"))
+7 SET ACRITOT=ACRITOT+($PIECE(X,U,5)*$PIECE(X,U,6))
End DoDot:1
+8 IF 'ACRITOT
QUIT
+9 SET DA=ACRSSDA
+10 SET DIE="^ACRSS("
+11 SET DR="16.1////"_ACRITOT
+12 IF $GET(ACRFINAL)'=1
SET $PIECE(^ACRSS(ACRSSDA,"DT"),U,21)=ACRITOT
+13 IF '$TEST
DO DIE^ACRFDIC
+14 QUIT
TVPAID ;EP;ENTER TRAVEL EXPENSES PAID
+1 DO ALTOT^ACRFCLM
+2 SET ACRSSDA=0
+3 FOR
SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
IF 'ACRSSDA
QUIT
Begin DoDot:1
+4 SET ACRSS0=$GET(^ACRSS(ACRSSDA,0))
SET ACRSSDT=$GET(^ACRSS(ACRSSDA,"DT"))
+5 SET ACRITOT=$SELECT(+ACRSS0'=1:$PIECE(ACRSSDT,U,9),1:ACRALTOT)
+6 SET DA=ACRSSDA
+7 SET DIE="^ACRSS("
+8 SET DR="16.1////"_ACRITOT
+9 DO DIE^ACRFDIC
End DoDot:1
+10 QUIT
PAIDUP ;EP;TO UPDATE ARMS WHEN 1166 BATCH IS CERTIFIED
+1 IF '$GET(ACRFYDA)!'$GET(ACRBATDA)
QUIT
+2 NEW ACRBATNO,ACRBTYP
+3 SET ACRBATNO=$PIECE($GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,0)),U)
+4 IF ACRBATNO=""
QUIT
+5 SET ACRBTYP=$SELECT("ABCG"[$EXTRACT(ACRBATNO):"V","DEF"[$EXTRACT(ACRBATNO):"T",1:"")
+6 IF ACRBTYP=""
QUIT
+7 NEW ACRSEQDA
+8 SET ACRSEQDA=0
+9 FOR
SET ACRSEQDA=$ORDER(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA))
IF 'ACRSEQDA
QUIT
Begin DoDot:1
+10 IF '+$GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,"ARMS"))
QUIT
SET ACRDOCDA=+^("ARMS")
+11 IF $GET(ACRBTYP)="V"
DO DOCPAID
+12 IF $GET(ACRBTYP)="T"
DO TVPAID
End DoDot:1
+13 QUIT
SYNC ;EP;TO SYNCHRONIZE ARMS FMS DOCUMENT POINTER IN 1166 RECORDS
+1 DO ^XBKVAR
+2 DO DCALC
+3 DO TCALC
+4 DO ODOC
+5 NEW ACRDOC
+6 SET ACRDOC=""
+7 FOR
SET ACRDOC=$ORDER(^AFSLAFP("N",ACRDOC))
IF ACRDOC=""
QUIT
Begin DoDot:1
+8 SET ACRDOCDA=$ORDER(^ACRDOC("C",ACRDOC,0))
+9 IF 'ACRDOCDA
SET ACRDOCDA=$ORDER(^ACRDOC("B",ACRDOC,0))
+10 IF 'ACRDOCDA
QUIT
+11 NEW ACRFYDA
+12 SET ACRFYDA=0
+13 FOR
SET ACRFYDA=$ORDER(^AFSLAFP("N",ACRDOC,ACRFYDA))
IF 'ACRFYDA
QUIT
Begin DoDot:2
+14 NEW ACRBATDA
+15 SET ACRBATDA=0
+16 FOR
SET ACRBATDA=$ORDER(^AFSLAFP("N",ACRDOC,ACRFYDA,ACRBATDA))
IF 'ACRBATDA
QUIT
Begin DoDot:3
+17 NEW ACRSEQDA
+18 SET ACRSEQDA=0
+19 FOR
SET ACRSEQDA=$ORDER(^AFSLAFP("N",ACRDOC,ACRFYDA,ACRBATDA,ACRSEQDA))
IF 'ACRSEQDA
QUIT
Begin DoDot:4
+20 SET DA=ACRSEQDA
+21 SET DA(2)=ACRFYDA
+22 SET DA(1)=ACRBATDA
+23 SET DIE="^AFSLAFP("_DA(2)_",1,"_DA(1)_",1,"
+24 SET DR=".02////"_ACRDOCDA
+25 DO DIE^ACRFDIC
+26 ;!,ACRDOC,?10,ACRDOCDA,?20,ACRFYDA,?30,ACRBATDA,?40,ACRSEQDA
WRITE "*"
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
DCALC ;EP;CALCULATE ACTUAL PAID AMOUNT FOR ALL DOCUMENTS
+1 NEW ACRDOCDA
+2 SET ACRDOCDA=0
+3 FOR
SET ACRDOCDA=$ORDER(^ACRRR("C",ACRDOCDA))
IF 'ACRDOCDA
QUIT
DO DOCPAID
WRITE "."
+4 QUIT
TCALC ;EP;TO CALCULATE TRAVEL EXPENSES PAID
+1 NEW ACRDOCDA
+2 SET ACRDOCDA=0
+3 FOR
SET ACRDOCDA=$ORDER(^ACRDOC("REF",133,ACRDOCDA))
IF 'ACRDOCDA
QUIT
IF $PIECE($GET(^ACROBL(ACRDOCDA,"APV")),U,8)="A"
DO TVPAID
WRITE "."
+4 QUIT
ODOC ;EP;TO CALCULATE DISBURSEMENTS FOR ARMS DOCUMENTS FROM THE OPEN
+1 ;DOCUMENT FILE
+2 KILL ACRDTOT
+3 NEW ACRDOCDA,ACRATOT,ACRDOC,ACRDTOT,ACROFYDA,ACRODDA,ACRITOT,ACRPTOT
+4 SET ACRDOCDA=0
+5 FOR
SET ACRDOCDA=$ORDER(^ACRDOC(ACRDOCDA))
IF 'ACRDOCDA
QUIT
Begin DoDot:1
+6 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,15)
QUIT
+7 SET ACRDOC=$SELECT($PIECE(^ACRDOC(ACRDOCDA,0),U,2)]"":$PIECE(^(0),U,2),1:$PIECE(^(0),U))
+8 IF ACRDOC["-"
SET ACRDOC=$TRANSLATE(ACRDOC,"-","")
SET ACRDOC=$EXTRACT(ACRDOC,2,11)
+9 IF ACRDOC=""
QUIT
+10 DO O1
+11 DO O2
+12 DO O3
+13 IF ACRDTOT
IF ACRDTOT'=ACRITOT
Begin DoDot:2
+14 ;!,ACRDOC,?15,$J($FN(ACRDTOT,"P,",2),12),?30,$J($FN(ACRATOT,"P,",2),12),?45,$J($FN(ACRITOT,"P,",2),12),?60,$J($FN(ACRPTOT,"P,",2),12)
WRITE "."
+15 IF $PIECE(^ACROBL(ACRDOCDA,"APV"),U,6)=1
IF $PIECE(^("DT"),U,2)'=ACRATOT
SET $PIECE(^("DT"),U,2)=$SELECT(ACRDTOT>ACRATOT:ACRDTOT,1:ACRATOT)
End DoDot:2
End DoDot:1
+16 QUIT
O1 NEW ACROFYDA,X
+1 SET (ACROFYDA,ACRDTOT)=0
+2 FOR
SET ACROFYDA=$ORDER(^AFSLODOC("DOCNO",ACRDOC,ACROFYDA))
IF 'ACROFYDA
QUIT
Begin DoDot:1
+3 NEW ACRODDA
+4 SET ACRODDA=0
+5 FOR
SET ACRODDA=$ORDER(^AFSLODOC("DOCNO",ACRDOC,ACROFYDA,ACRODDA))
IF 'ACRODDA
QUIT
Begin DoDot:2
+6 SET X=$PIECE($GET(^AFSLODOC(ACROFYDA,1,ACRODDA,4)),U,4)
+7 IF $EXTRACT(X)="+"
SET X=+$EXTRACT(X,2,99)
+8 SET X=+X
+9 IF X
SET ACRDTOT=ACRDTOT+X
End DoDot:2
End DoDot:1
+10 IF ACRDTOT
SET ACRDTOT=ACRDTOT/100
+11 QUIT
O2 NEW X
+1 SET (X,ACRITOT,ACRPTOT)=0
+2 FOR
SET X=$ORDER(^ACRSS("J",ACRDOCDA,X))
IF 'X
QUIT
SET ACRITOT=ACRITOT+$PIECE($GET(^ACRSS(X,"DT")),U,4)
SET ACRPTOT=ACRPTOT+$PIECE($GET(^("DT")),U,21)
+3 NEW Z
+4 SET Z=0
+5 FOR
SET Z=$ORDER(^ACRDOC("MOD",ACRDOCDA,Z))
IF 'Z
QUIT
DO O21
+6 QUIT
O21 SET X=0
+1 FOR
SET X=$ORDER(^ACRSS("J",Z,X))
IF 'X
QUIT
SET ACRITOT=ACRITOT+$PIECE($GET(^ACRSS(X,"DT")),U,4)
SET ACRPTOT=ACRPTOT+$PIECE($GET(^("DT")),U,21)
+2 QUIT
O3 NEW X,Y,Z
+1 SET (X,ACRATOT)=0
+2 FOR
SET X=$ORDER(^AFSLAFP("N",ACRDOC,X))
IF 'X
QUIT
Begin DoDot:1
+3 SET Y=0
+4 FOR
SET Y=$ORDER(^AFSLAFP("N",ACRDOC,X,Y))
IF 'Y
QUIT
Begin DoDot:2
+5 SET Z=0
+6 FOR
SET Z=$ORDER(^AFSLAFP("N",ACRDOC,X,Y,Z))
IF 'Z
QUIT
SET ACRATOT=ACRATOT+$PIECE($GET(^AFSLAFP(X,1,Y,1,Z,0)),U,11)-$PIECE($GET(^(0)),U,12)+$PIECE($GET(^(1)),U,6)
End DoDot:2
End DoDot:1
+7 QUIT
MODS ;EP; SYNC ARMS PO MODS
+1 NEW ACRDOCX,ACRDOCDA,ACRITOT,ACRRRDA
+2 SET ACRDOCX=0
+3 FOR
SET ACRDOCX=$ORDER(^ACRDOC("MOD",ACRDOCX))
IF 'ACRDOCX
QUIT
Begin DoDot:1
+4 SET (ACRDOCDA,ACRITOT)=0
+5 FOR
SET ACRDOCDA=$ORDER(^ACRDOC("MOD",ACRDOCX,ACRDOCDA))
IF 'ACRDOCDA
QUIT
Begin DoDot:2
+6 SET ACRRRDA=0
+7 FOR
SET ACRRRDA=$ORDER(^ACRRR("C",ACRDOCDA,ACRRRDA))
IF 'ACRRRDA
QUIT
Begin DoDot:3
+8 IF '$PIECE(^ACRRR(ACRRRDA,0),U,11)&'$PIECE(^("DT"),U,5)
QUIT
SET X=^("DT")
+9 SET ACRITOT=ACRITOT+($PIECE(X,U,5)*$PIECE(X,U,6))
+10 SET ACRDOC=$SELECT($PIECE(^ACRDOC(ACRDOCDA,0),U,2)]"":$PIECE(^(0),U,2),1:$PIECE(^(0),U))
+11 IF ACRDOC["-"
SET ACRDOC=$TRANSLATE(ACRDOC,"-","")
SET ACRDOC=$EXTRACT(ACRDOC,2,11)
+12 SET X=0
+13 FOR
SET X=$ORDER(^AFSLAFP("N",ACRDOC,X))
IF 'X
QUIT
Begin DoDot:4
+14 SET Y=0
+15 FOR
SET Y=$ORDER(^AFSLAFP("N",ACRDOC,X,Y))
IF 'Y
QUIT
Begin DoDot:5
+16 SET Z=0
+17 FOR
SET Z=$ORDER(^AFSLAFP("N",ACRDOC,X,Y,Z))
IF 'Z
QUIT
IF $PIECE(^AFSLAFP(X,1,Y,1,Z,0),U,11)=ACRITOT
WRITE !,ACRDOC,?15,ACRDOCDA
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
