ABPAPD7B ;ALLOCATE UNAPPLIED PAYMENTS;[ 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
BEGIN ;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 ABPAI=0:0 D Q:+ABPADOS=0
..S ABPADOS=$O(ABPA("PP",ABPADOS)) Q:+ABPADOS=0
..S DA=0 F ABPAJ=0:0 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 ABPAK=0:0 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
.Q
;PROCEDURE TO PROCESS UNASSIGNED DEDUCTIBLE TRANSACTIONS
I +ABPA("UP","D")>0 S ABPADOS=0 D
.F ABPAI=0:0 D Q:+ABPA("UP","D")=0!(+ABPADOS=0)
..S ABPADOS=$O(ABPA("PP",ABPADOS)) Q:+ABPADOS=0
..S DA=0 F ABPAJ=0:0 D Q:+DA=0
...S DA=$O(ABPA("PP",ABPADOS,DA)) Q:+DA=0
...S ABPADATA=ABPA("PP",ABPADOS,DA),ABPACURB=+ABPADATA
...I ABPACURB'<ABPA("UP","D") D Q
....S $P(ABPADATA,"^",4)=$P(ABPADATA,"^",4)+ABPA("UP","D")
....S $P(ABPADATA,"^",6)=$P(ABPADATA,"^",6)+ABPA("UP","D")
....S $P(ABPADATA,"^")=$P(ABPADATA,"^")-ABPA("UP","D")
....S ABPACTOB=ABPACTOB-ABPA("UP","D"),ABPA("UP","D")=0
....S ABPA("PP",ABPADOS,DA)=ABPADATA
...S $P(ABPADATA,"^",4)=$P(ABPADATA,"^",4)+ABPACURB
...S $P(ABPADATA,"^",6)=$P(ABPADATA,"^",6)+ABPACURB
...S $P(ABPADATA,"^")=0,ABPA("UP","D")=ABPA("UP","D")-ABPACURB
...S ABPACTOB=ABPACTOB-ABPACURB,ABPA("PP",ABPADOS,DA)=ABPADATA
.Q
;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 ABPAI=0:0 D Q:+ABPADOS=0
..S ABPADOS=$O(ABPA("PP",ABPADOS)) Q:+ABPADOS=0
..S DA=0 F ABPAJ=0:0 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 ABPAK=0:0 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
Q
ABPAPD7B ;ALLOCATE UNAPPLIED PAYMENTS;[ 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
BEGIN ;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 ABPAI=0:0
Begin DoDot:2
+4 SET ABPADOS=$ORDER(ABPA("PP",ABPADOS))
IF +ABPADOS=0
QUIT
+5 SET DA=0
FOR ABPAJ=0:0
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 ABPAK=0:0
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
End DoDot:3
IF +DA=0
QUIT
End DoDot:2
IF +ABPADOS=0
QUIT
+18 QUIT
End DoDot:1
+19 ;PROCEDURE TO PROCESS UNASSIGNED DEDUCTIBLE TRANSACTIONS
+20 IF +ABPA("UP","D")>0
SET ABPADOS=0
Begin DoDot:1
+21 FOR ABPAI=0:0
Begin DoDot:2
+22 SET ABPADOS=$ORDER(ABPA("PP",ABPADOS))
IF +ABPADOS=0
QUIT
+23 SET DA=0
FOR ABPAJ=0:0
Begin DoDot:3
+24 SET DA=$ORDER(ABPA("PP",ABPADOS,DA))
IF +DA=0
QUIT
+25 SET ABPADATA=ABPA("PP",ABPADOS,DA)
SET ABPACURB=+ABPADATA
+26 IF ABPACURB'<ABPA("UP","D")
Begin DoDot:4
+27 SET $PIECE(ABPADATA,"^",4)=$PIECE(ABPADATA,"^",4)+ABPA("UP","D")
+28 SET $PIECE(ABPADATA,"^",6)=$PIECE(ABPADATA,"^",6)+ABPA("UP","D")
+29 SET $PIECE(ABPADATA,"^")=$PIECE(ABPADATA,"^")-ABPA("UP","D")
+30 SET ABPACTOB=ABPACTOB-ABPA("UP","D")
SET ABPA("UP","D")=0
+31 SET ABPA("PP",ABPADOS,DA)=ABPADATA
End DoDot:4
QUIT
+32 SET $PIECE(ABPADATA,"^",4)=$PIECE(ABPADATA,"^",4)+ABPACURB
+33 SET $PIECE(ABPADATA,"^",6)=$PIECE(ABPADATA,"^",6)+ABPACURB
+34 SET $PIECE(ABPADATA,"^")=0
SET ABPA("UP","D")=ABPA("UP","D")-ABPACURB
+35 SET ABPACTOB=ABPACTOB-ABPACURB
SET ABPA("PP",ABPADOS,DA)=ABPADATA
End DoDot:3
IF +DA=0
QUIT
End DoDot:2
IF +ABPA("UP","D")=0!(+ABPADOS=0)
QUIT
+36 QUIT
End DoDot:1
+37 ;PROCEDURE TO PROCESS UNASSIGNED PAYMENT TRANSACTIONS
+38 IF +ABPA("UP","S")>0
SET ABPA("S$")=ABPA("UP","S")
SET ABPATCNT=0
Begin DoDot:1
+39 SET ABPATBAL=ABPACTOB
SET ABPADOS=0
FOR ABPAI=0:0
Begin DoDot:2
+40 SET ABPADOS=$ORDER(ABPA("PP",ABPADOS))
IF +ABPADOS=0
QUIT
+41 SET DA=0
FOR ABPAJ=0:0
Begin DoDot:3
+42 SET DA=$ORDER(ABPA("PP",ABPADOS,DA))
IF +DA=0
QUIT
SET ABPATCNT=ABPATCNT+1
+43 SET ABPADATA=ABPA("PP",ABPADOS,DA)
SET ABPACURB=+ABPADATA
+44 IF ABPATBAL>0
SET ABPA("%")=ABPACURB/ABPATBAL
+45 IF '$TEST
SET ABPA("%")=$PIECE(^ABPVAO(ABPATDFN,1,DA,0),"^",7)/ABPACAMT
+46 SET ABPA("$")=$JUSTIFY((ABPA("S$")*ABPA("%")),10,2)
+47 FOR ABPAK=0:0
IF $EXTRACT(ABPA("$"),1)'=" "
QUIT
SET ABPA("$")=$EXTRACT(ABPA("$"),2,99)
+48 IF ABPATCNT=ABPACCNT
SET ABPA("$")=ABPA("UP","S")
+49 SET $PIECE(ABPADATA,"^",5)=$PIECE(ABPADATA,"^",5)+ABPA("$")
+50 SET $PIECE(ABPADATA,"^",6)=$PIECE(ABPADATA,"^",6)+ABPA("$")
+51 SET $PIECE(ABPADATA,"^")=$PIECE(ABPADATA,"^")-ABPA("$")
+52 SET ABPA("UP","S")=ABPA("UP","S")-ABPA("$")
+53 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
+54 QUIT
