ABPAPD7D ;ALLOCATE UNAPPLIED DEDUCTIBLE REFUNDS;[ 07/25/91 11:53 AM ]
;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
W !!,"<<< NOT AN ENTRY POINT - ACCESS DENIED >>>",!! Q
NONCOV ;ENTRY POINT
;PROCEDURE TO PROCESS UNASSIGNED NON-COVERED SERVICE TRANSACTIONS
I +ABPA("UP","N")<0 S ABPA("N$")=ABPA("UP","N"),ABPATCNT=0 D
.S ABPATBAL=ABPACTOB,ABPADOS=0 F D Q:+ABPADOS=0
..S ABPADOS=$O(ABPA("PP",ABPADOS)) Q:+ABPADOS=0
..S DA=0 F D Q:+DA=0
...S DA=$O(ABPA("PP",ABPADOS,DA)) Q:+DA=0 S ABPATCNT=ABPATCNT+1
...S ABPADATA=ABPA("PP",ABPADOS,DA),ABPACURB=+ABPADATA
...I ABPATBAL>0 S ABPA("%")=ABPACURB/ABPATBAL
...E S ABPA("%")=$P(^ABPVAO(ABPATDFN,1,DA,0),"^",7)/ABPACAMT
...S ABPA("$")=$J((ABPA("N$")*ABPA("%")),10,2)
...F Q:$E(ABPA("$"),1)'=" " S ABPA("$")=$E(ABPA("$"),2,99)
...I ABPATCNT=ABPACCNT S ABPA("$")=ABPA("UP","N")
...S $P(ABPADATA,"^",3)=$P(ABPADATA,"^",3)+ABPA("$")
...S $P(ABPADATA,"^",6)=$P(ABPADATA,"^",6)+ABPA("$")
...S $P(ABPADATA,"^")=$P(ABPADATA,"^")-ABPA("$")
...S ABPA("UP","N")=ABPA("UP","N")-ABPA("$")
...S ABPACTOB=ABPACTOB-ABPA("$"),ABPA("PP",ABPADOS,DA)=ABPADATA
...I -ABPA("N$")>ABPA("NB") S ABPA("RBERR")=""
Q
DEDUCT ;ENTRY POINT
;PROCEDURE TO PROCESS UNASSIGNED DEDUCTIBLE REFUND TRANSACTIONS
I +ABPA("UP","D")<0 K ABPA("TPP") S ABPADOS=0 D
.F D Q:+ABPADOS=0
..S ABPADOS=$O(ABPA("PP",ABPADOS)) Q:+ABPADOS=0
..S DA=0 F D Q:+DA=0
...S DA=$O(ABPA("PP",ABPADOS,DA)) Q:+DA=0
...S ABPA("TPP",9999999-ABPADOS,999-DA)=""
.I -ABPA("UP","D")>ABPA("DB") S ABPA("RBERR")=""
.S ABPADOS=0,ABPATCNT=0 F D Q:+ABPA("UP","D")=0!(+ABPADOS=0)
..S ABPADOS=$O(ABPA("TPP",ABPADOS)) Q:+ABPADOS=0
..S DA=0 F D Q:+DA=0
...S DA=$O(ABPA("TPP",ABPADOS,DA)) Q:+DA=0
...S ABPADATA=ABPA("PP",9999999-ABPADOS,999-DA) S ABPATCNT=ABPATCNT+1
...S ABPACURB=+$P(ABPADATA,"^",4) I ABPACURB'>-ABPA("UP","D") D Q
....S $P(ABPADATA,"^",6)=$P(ABPADATA,"^",6)-ABPACURB
....S $P(ABPADATA,"^")=+ABPADATA+ABPACURB,ABPACTOB=ABPACTOB+ABPACURB
....S ABPA("UP","D")=ABPA("UP","D")+$P(ABPADATA,"^",4)
....S $P(ABPADATA,"^",4)=0 I ABPATCNT=ABPACCNT D
.....S $P(ABPADATA,"^",4)=ABPA("UP","D")
.....S $P(ABPADATA,"^")=+ABPADATA+ABPA("UP","D")
.....S ABPACTOB=ABPACTOB+ABPA("UP","D")
.....S $P(ABPADATA,"^",6)=$P(ABPADATA,"^",6)-ABPA("UP","D")
....S ABPA("PP",9999999-ABPADOS,999-DA)=ABPADATA
...S $P(ABPADATA,"^",6)=$P(ABPADATA,"^",6)+ABPA("UP","D")
...S $P(ABPADATA,"^")=$P(ABPADATA,"^")-ABPA("UP","D")
...S ABPACTOB=ABPACTOB-ABPA("UP","D")
...S $P(ABPADATA,"^",4)=$P(ABPADATA,"^",4)+ABPA("UP","D")
...S ABPA("UP","D")=0,ABPA("PP",9999999-ABPADOS,999-DA)=ABPADATA
Q
PAID ;ENTRY POINT
;PROCEDURE TO PROCESS UNASSIGNED PAYMENT TRANSACTIONS
I +ABPA("UP","S")<0 S ABPA("S$")=ABPA("UP","S"),ABPATCNT=0 D
.S ABPATBAL=ABPACTOB,ABPADOS=0 F D Q:+ABPADOS=0
..S ABPADOS=$O(ABPA("PP",ABPADOS)) Q:+ABPADOS=0
..S DA=0 F D Q:+DA=0
...S DA=$O(ABPA("PP",ABPADOS,DA)) Q:+DA=0 S ABPATCNT=ABPATCNT+1
...S ABPADATA=ABPA("PP",ABPADOS,DA),ABPACURB=+ABPADATA
...I ABPATBAL>0 S ABPA("%")=ABPACURB/ABPATBAL
...E S ABPA("%")=$P(^ABPVAO(ABPATDFN,1,DA,0),"^",7)/ABPACAMT
...S ABPA("$")=$J((ABPA("S$")*ABPA("%")),10,2)
...F Q:$E(ABPA("$"),1)'=" " S ABPA("$")=$E(ABPA("$"),2,99)
...I ABPATCNT=ABPACCNT S ABPA("$")=ABPA("UP","S")
...S $P(ABPADATA,"^",5)=$P(ABPADATA,"^",5)+ABPA("$")
...S $P(ABPADATA,"^",6)=$P(ABPADATA,"^",6)+ABPA("$")
...S $P(ABPADATA,"^")=$P(ABPADATA,"^")-ABPA("$")
...S ABPA("UP","S")=ABPA("UP","S")-ABPA("$")
...S ABPACTOB=ABPACTOB-ABPA("$"),ABPA("PP",ABPADOS,DA)=ABPADATA
I -ABPA("S$")>ABPA("SB") S ABPA("RBERR")=""
Q
ABPAPD7D ;ALLOCATE UNAPPLIED DEDUCTIBLE REFUNDS;[ 07/25/91 11:53 AM ]
+1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
+2 WRITE !!,"<<< NOT AN ENTRY POINT - ACCESS DENIED >>>",!!
QUIT
NONCOV ;ENTRY POINT
+1 ;PROCEDURE TO PROCESS UNASSIGNED NON-COVERED SERVICE TRANSACTIONS
+2 IF +ABPA("UP","N")<0
SET ABPA("N$")=ABPA("UP","N")
SET ABPATCNT=0
Begin DoDot:1
+3 SET ABPATBAL=ABPACTOB
SET ABPADOS=0
FOR
Begin DoDot:2
+4 SET ABPADOS=$ORDER(ABPA("PP",ABPADOS))
IF +ABPADOS=0
QUIT
+5 SET DA=0
FOR
Begin DoDot:3
+6 SET DA=$ORDER(ABPA("PP",ABPADOS,DA))
IF +DA=0
QUIT
SET ABPATCNT=ABPATCNT+1
+7 SET ABPADATA=ABPA("PP",ABPADOS,DA)
SET ABPACURB=+ABPADATA
+8 IF ABPATBAL>0
SET ABPA("%")=ABPACURB/ABPATBAL
+9 IF '$TEST
SET ABPA("%")=$PIECE(^ABPVAO(ABPATDFN,1,DA,0),"^",7)/ABPACAMT
+10 SET ABPA("$")=$JUSTIFY((ABPA("N$")*ABPA("%")),10,2)
+11 FOR
IF $EXTRACT(ABPA("$"),1)'=" "
QUIT
SET ABPA("$")=$EXTRACT(ABPA("$"),2,99)
+12 IF ABPATCNT=ABPACCNT
SET ABPA("$")=ABPA("UP","N")
+13 SET $PIECE(ABPADATA,"^",3)=$PIECE(ABPADATA,"^",3)+ABPA("$")
+14 SET $PIECE(ABPADATA,"^",6)=$PIECE(ABPADATA,"^",6)+ABPA("$")
+15 SET $PIECE(ABPADATA,"^")=$PIECE(ABPADATA,"^")-ABPA("$")
+16 SET ABPA("UP","N")=ABPA("UP","N")-ABPA("$")
+17 SET ABPACTOB=ABPACTOB-ABPA("$")
SET ABPA("PP",ABPADOS,DA)=ABPADATA
+18 IF -ABPA("N$")>ABPA("NB")
SET ABPA("RBERR")=""
End DoDot:3
IF +DA=0
QUIT
End DoDot:2
IF +ABPADOS=0
QUIT
End DoDot:1
+19 QUIT
DEDUCT ;ENTRY POINT
+1 ;PROCEDURE TO PROCESS UNASSIGNED DEDUCTIBLE REFUND TRANSACTIONS
+2 IF +ABPA("UP","D")<0
KILL ABPA("TPP")
SET ABPADOS=0
Begin DoDot:1
+3 FOR
Begin DoDot:2
+4 SET ABPADOS=$ORDER(ABPA("PP",ABPADOS))
IF +ABPADOS=0
QUIT
+5 SET DA=0
FOR
Begin DoDot:3
+6 SET DA=$ORDER(ABPA("PP",ABPADOS,DA))
IF +DA=0
QUIT
+7 SET ABPA("TPP",9999999-ABPADOS,999-DA)=""
End DoDot:3
IF +DA=0
QUIT
End DoDot:2
IF +ABPADOS=0
QUIT
+8 IF -ABPA("UP","D")>ABPA("DB")
SET ABPA("RBERR")=""
+9 SET ABPADOS=0
SET ABPATCNT=0
FOR
Begin DoDot:2
+10 SET ABPADOS=$ORDER(ABPA("TPP",ABPADOS))
IF +ABPADOS=0
QUIT
+11 SET DA=0
FOR
Begin DoDot:3
+12 SET DA=$ORDER(ABPA("TPP",ABPADOS,DA))
IF +DA=0
QUIT
+13 SET ABPADATA=ABPA("PP",9999999-ABPADOS,999-DA)
SET ABPATCNT=ABPATCNT+1
+14 SET ABPACURB=+$PIECE(ABPADATA,"^",4)
IF ABPACURB'>-ABPA("UP","D")
Begin DoDot:4
+15 SET $PIECE(ABPADATA,"^",6)=$PIECE(ABPADATA,"^",6)-ABPACURB
+16 SET $PIECE(ABPADATA,"^")=+ABPADATA+ABPACURB
SET ABPACTOB=ABPACTOB+ABPACURB
+17 SET ABPA("UP","D")=ABPA("UP","D")+$PIECE(ABPADATA,"^",4)
+18 SET $PIECE(ABPADATA,"^",4)=0
IF ABPATCNT=ABPACCNT
Begin DoDot:5
+19 SET $PIECE(ABPADATA,"^",4)=ABPA("UP","D")
+20 SET $PIECE(ABPADATA,"^")=+ABPADATA+ABPA("UP","D")
+21 SET ABPACTOB=ABPACTOB+ABPA("UP","D")
+22 SET $PIECE(ABPADATA,"^",6)=$PIECE(ABPADATA,"^",6)-ABPA("UP","D")
End DoDot:5
+23 SET ABPA("PP",9999999-ABPADOS,999-DA)=ABPADATA
End DoDot:4
QUIT
+24 SET $PIECE(ABPADATA,"^",6)=$PIECE(ABPADATA,"^",6)+ABPA("UP","D")
+25 SET $PIECE(ABPADATA,"^")=$PIECE(ABPADATA,"^")-ABPA("UP","D")
+26 SET ABPACTOB=ABPACTOB-ABPA("UP","D")
+27 SET $PIECE(ABPADATA,"^",4)=$PIECE(ABPADATA,"^",4)+ABPA("UP","D")
+28 SET ABPA("UP","D")=0
SET ABPA("PP",9999999-ABPADOS,999-DA)=ABPADATA
End DoDot:3
IF +DA=0
QUIT
End DoDot:2
IF +ABPA("UP","D")=0!(+ABPADOS=0)
QUIT
End DoDot:1
+29 QUIT
PAID ;ENTRY POINT
+1 ;PROCEDURE TO PROCESS UNASSIGNED PAYMENT TRANSACTIONS
+2 IF +ABPA("UP","S")<0
SET ABPA("S$")=ABPA("UP","S")
SET ABPATCNT=0
Begin DoDot:1
+3 SET ABPATBAL=ABPACTOB
SET ABPADOS=0
FOR
Begin DoDot:2
+4 SET ABPADOS=$ORDER(ABPA("PP",ABPADOS))
IF +ABPADOS=0
QUIT
+5 SET DA=0
FOR
Begin DoDot:3
+6 SET DA=$ORDER(ABPA("PP",ABPADOS,DA))
IF +DA=0
QUIT
SET ABPATCNT=ABPATCNT+1
+7 SET ABPADATA=ABPA("PP",ABPADOS,DA)
SET ABPACURB=+ABPADATA
+8 IF ABPATBAL>0
SET ABPA("%")=ABPACURB/ABPATBAL
+9 IF '$TEST
SET ABPA("%")=$PIECE(^ABPVAO(ABPATDFN,1,DA,0),"^",7)/ABPACAMT
+10 SET ABPA("$")=$JUSTIFY((ABPA("S$")*ABPA("%")),10,2)
+11 FOR
IF $EXTRACT(ABPA("$"),1)'=" "
QUIT
SET ABPA("$")=$EXTRACT(ABPA("$"),2,99)
+12 IF ABPATCNT=ABPACCNT
SET ABPA("$")=ABPA("UP","S")
+13 SET $PIECE(ABPADATA,"^",5)=$PIECE(ABPADATA,"^",5)+ABPA("$")
+14 SET $PIECE(ABPADATA,"^",6)=$PIECE(ABPADATA,"^",6)+ABPA("$")
+15 SET $PIECE(ABPADATA,"^")=$PIECE(ABPADATA,"^")-ABPA("$")
+16 SET ABPA("UP","S")=ABPA("UP","S")-ABPA("$")
+17 SET ABPACTOB=ABPACTOB-ABPA("$")
SET ABPA("PP",ABPADOS,DA)=ABPADATA
End DoDot:3
IF +DA=0
QUIT
End DoDot:2
IF +ABPADOS=0
QUIT
End DoDot:1
+18 IF -ABPA("S$")>ABPA("SB")
SET ABPA("RBERR")=""
+19 QUIT
