- 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
