- 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
