- 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
