ABPAPD7A ;ALLOCATE APPLIED PAYMENT TRANS.;[ 07/25/91 11:52 AM ]
;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
W !!,"<<< NOT AN ENTRY POINT - ACCESS DENIED >>>",!! Q
BEGIN ;ENTRY POINT
;PROCEDURE TO ALLCOCATE DIRECTLY APPLIED CURRENT TRANSACTIONS
S ABPACDFN=0 F ABPAI=0:0 D Q:+ABPACDFN=0
.S ABPACDFN=$O(ABPA("AP",ABPACDFN)) Q:+ABPACDFN=0
.Q:$D(^ABPVAO(ABPATDFN,1,ABPACDFN,0))'=1 S ABPADOS=+^(0)
.F ABPAJ=1:1:6 S @("ABPAP"_ABPAJ)=0
.S DA=0 F ABPAJ=0:0 D Q:+DA=0
..S DA=$O(ABPA("AP",ABPACDFN,DA)) Q:+DA=0
..I $P(ABPA("AP",ABPACDFN,DA),"^",2)="P" D Q
...S ABPAP2=ABPAP2+(+ABPA("AP",ABPACDFN,DA))
..I $P(ABPA("AP",ABPACDFN,DA),"^",2)="N" D Q
...S ABPAP3=ABPAP3+(+ABPA("AP",ABPACDFN,DA))
..I $P(ABPA("AP",ABPACDFN,DA),"^",2)="D" D Q
...S ABPAP4=ABPAP4+(+ABPA("AP",ABPACDFN,DA))
..I $P(ABPA("AP",ABPACDFN,DA),"^",2)="S" D Q
...S ABPAP5=ABPAP5+(+ABPA("AP",ABPACDFN,DA))
.F ABPAJ=2:1:5 D
..S $P(ABPA("CP",ABPADOS,ABPACDFN),"^",ABPAJ)=@("ABPAP"_ABPAJ)
.S ABPACPD=0 F ABPAJ=2:1:5 S ABPACPD=@("ABPAP"_ABPAJ)+ABPACPD
.S $P(ABPA("CP",ABPADOS,ABPACDFN),"^",6)=ABPACPD
;---------------------------------------------------------------------
;THIS PROCEDURE WILL ALLOCATE ANY PAYMENT TRANSACTION NOT DIRECTLY
;LINKED TO A SPECIFIC BILL ACCROSS ALL BILLS INVOLVED IN THE TRANS-
;ACTION ACCORDING TO THE PROPORTIONAL VALUE OF EACH BILL'S OUT-
;STANDING BALANCE AT THE TIME OF ALLOCATION.
;DEDUCTIBLE TRANSACTIONS ARE DEDUCTED FROM THE OLDEST BILL OR BILLS
;UNTIL THE ENTIRE TRANSACTION HAS BEEN ALLOCATED PRIOR TO ANY OTHER
;TRANSACTIONS BEING PROPROTIONATELY ALLOCATED.
S (ABPA("PB"),ABPA("NB"),ABPA("DB"),ABPA("SB"),ABPACTOB,ABPADOS)=0
F ABPAI=0:0 D Q:+ABPADOS=0
.S ABPADOS=$O(ABPA("HP",ABPADOS)) Q:+ABPADOS=0
.S DA=0 F ABPAJ=0:0 D Q:+DA=0
..S DA=$O(ABPA("HP",ABPADOS,DA)) Q:+DA=0
..F ABPAK=1:1:6 D
...S @("ABPAP"_ABPAK)=$P(ABPA("HP",ABPADOS,DA),"^",ABPAK)
...S @("ABPAT"_ABPAK)=$P(ABPA("CP",ABPADOS,DA),"^",ABPAK)
..S ABPAZ=0 F ABPAX=2:1:5 D
...S ABPAY=@("ABPAP"_ABPAX)+@("ABPAT"_ABPAX),ABPAZ=ABPAZ+ABPAY
...S $P(ABPA("PP",ABPADOS,DA),"^",ABPAX)=ABPAY
..S $P(ABPA("PP",ABPADOS,DA),"^",6)=ABPAZ
..S $P(ABPA("PP",ABPADOS,DA),"^")=ABPAP1-ABPAT6
..S ABPACTOB=ABPACTOB+(ABPAP1-ABPAT6)
..S ABPA("PB")=ABPA("PB")+$P(ABPA("PP",ABPADOS,DA),"^",2)
..S ABPA("NB")=ABPA("NB")+$P(ABPA("PP",ABPADOS,DA),"^",3)
..S ABPA("DB")=ABPA("DB")+$P(ABPA("PP",ABPADOS,DA),"^",4)
..S ABPA("SB")=ABPA("SB")+$P(ABPA("PP",ABPADOS,DA),"^",5)
I +ABPA("UP","N")<0 D NONCOV^ABPAPD7D
I +ABPA("UP","D")<0 D DEDUCT^ABPAPD7D
I +ABPA("UP","S")<0 D PAID^ABPAPD7D
G BEGIN^ABPAPD7B
ABPAPD7A ;ALLOCATE APPLIED PAYMENT TRANS.;[ 07/25/91 11:52 AM ]
+1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
+2 WRITE !!,"<<< NOT AN ENTRY POINT - ACCESS DENIED >>>",!!
QUIT
BEGIN ;ENTRY POINT
+1 ;PROCEDURE TO ALLCOCATE DIRECTLY APPLIED CURRENT TRANSACTIONS
+2 SET ABPACDFN=0
FOR ABPAI=0:0
Begin DoDot:1
+3 SET ABPACDFN=$ORDER(ABPA("AP",ABPACDFN))
IF +ABPACDFN=0
QUIT
+4 IF $DATA(^ABPVAO(ABPATDFN,1,ABPACDFN,0))'=1
QUIT
SET ABPADOS=+^(0)
+5 FOR ABPAJ=1:1:6
SET @("ABPAP"_ABPAJ)=0
+6 SET DA=0
FOR ABPAJ=0:0
Begin DoDot:2
+7 SET DA=$ORDER(ABPA("AP",ABPACDFN,DA))
IF +DA=0
QUIT
+8 IF $PIECE(ABPA("AP",ABPACDFN,DA),"^",2)="P"
Begin DoDot:3
+9 SET ABPAP2=ABPAP2+(+ABPA("AP",ABPACDFN,DA))
End DoDot:3
QUIT
+10 IF $PIECE(ABPA("AP",ABPACDFN,DA),"^",2)="N"
Begin DoDot:3
+11 SET ABPAP3=ABPAP3+(+ABPA("AP",ABPACDFN,DA))
End DoDot:3
QUIT
+12 IF $PIECE(ABPA("AP",ABPACDFN,DA),"^",2)="D"
Begin DoDot:3
+13 SET ABPAP4=ABPAP4+(+ABPA("AP",ABPACDFN,DA))
End DoDot:3
QUIT
+14 IF $PIECE(ABPA("AP",ABPACDFN,DA),"^",2)="S"
Begin DoDot:3
+15 SET ABPAP5=ABPAP5+(+ABPA("AP",ABPACDFN,DA))
End DoDot:3
QUIT
End DoDot:2
IF +DA=0
QUIT
+16 FOR ABPAJ=2:1:5
Begin DoDot:2
+17 SET $PIECE(ABPA("CP",ABPADOS,ABPACDFN),"^",ABPAJ)=@("ABPAP"_ABPAJ)
End DoDot:2
+18 SET ABPACPD=0
FOR ABPAJ=2:1:5
SET ABPACPD=@("ABPAP"_ABPAJ)+ABPACPD
+19 SET $PIECE(ABPA("CP",ABPADOS,ABPACDFN),"^",6)=ABPACPD
End DoDot:1
IF +ABPACDFN=0
QUIT
+20 ;---------------------------------------------------------------------
+21 ;THIS PROCEDURE WILL ALLOCATE ANY PAYMENT TRANSACTION NOT DIRECTLY
+22 ;LINKED TO A SPECIFIC BILL ACCROSS ALL BILLS INVOLVED IN THE TRANS-
+23 ;ACTION ACCORDING TO THE PROPORTIONAL VALUE OF EACH BILL'S OUT-
+24 ;STANDING BALANCE AT THE TIME OF ALLOCATION.
+25 ;DEDUCTIBLE TRANSACTIONS ARE DEDUCTED FROM THE OLDEST BILL OR BILLS
+26 ;UNTIL THE ENTIRE TRANSACTION HAS BEEN ALLOCATED PRIOR TO ANY OTHER
+27 ;TRANSACTIONS BEING PROPROTIONATELY ALLOCATED.
+28 SET (ABPA("PB"),ABPA("NB"),ABPA("DB"),ABPA("SB"),ABPACTOB,ABPADOS)=0
+29 FOR ABPAI=0:0
Begin DoDot:1
+30 SET ABPADOS=$ORDER(ABPA("HP",ABPADOS))
IF +ABPADOS=0
QUIT
+31 SET DA=0
FOR ABPAJ=0:0
Begin DoDot:2
+32 SET DA=$ORDER(ABPA("HP",ABPADOS,DA))
IF +DA=0
QUIT
+33 FOR ABPAK=1:1:6
Begin DoDot:3
+34 SET @("ABPAP"_ABPAK)=$PIECE(ABPA("HP",ABPADOS,DA),"^",ABPAK)
+35 SET @("ABPAT"_ABPAK)=$PIECE(ABPA("CP",ABPADOS,DA),"^",ABPAK)
End DoDot:3
+36 SET ABPAZ=0
FOR ABPAX=2:1:5
Begin DoDot:3
+37 SET ABPAY=@("ABPAP"_ABPAX)+@("ABPAT"_ABPAX)
SET ABPAZ=ABPAZ+ABPAY
+38 SET $PIECE(ABPA("PP",ABPADOS,DA),"^",ABPAX)=ABPAY
End DoDot:3
+39 SET $PIECE(ABPA("PP",ABPADOS,DA),"^",6)=ABPAZ
+40 SET $PIECE(ABPA("PP",ABPADOS,DA),"^")=ABPAP1-ABPAT6
+41 SET ABPACTOB=ABPACTOB+(ABPAP1-ABPAT6)
+42 SET ABPA("PB")=ABPA("PB")+$PIECE(ABPA("PP",ABPADOS,DA),"^",2)
+43 SET ABPA("NB")=ABPA("NB")+$PIECE(ABPA("PP",ABPADOS,DA),"^",3)
+44 SET ABPA("DB")=ABPA("DB")+$PIECE(ABPA("PP",ABPADOS,DA),"^",4)
+45 SET ABPA("SB")=ABPA("SB")+$PIECE(ABPA("PP",ABPADOS,DA),"^",5)
End DoDot:2
IF +DA=0
QUIT
End DoDot:1
IF +ABPADOS=0
QUIT
+46 IF +ABPA("UP","N")<0
DO NONCOV^ABPAPD7D
+47 IF +ABPA("UP","D")<0
DO DEDUCT^ABPAPD7D
+48 IF +ABPA("UP","S")<0
DO PAID^ABPAPD7D
+49 GOTO BEGIN^ABPAPD7B
