BARRPAY2.m

BARRPAY2   ; IHS/SD/PKD - TOP PAYERS REPORT ; 07/2/2010

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005

 ; Print:  called from BARRPAY

 ; New Reports - Top Payers - PKD 

 Q

 ; *******************************

PRINT ; EP   - 

 ; Need to resort ^TMP($J,"BAR-PAY" by Amount Paid

 S BAR("COL")="W !,"_"""A/R ACCOUNT                      TX CNT        AMOUNT PD           ALLOWABLE"""

 K ^TMP($J,"BAR-PAYS")  ; Sort into this

 K SUBTOT

 N ALLOW,AMT,ARACCT,CNT,DATA,LOC,LOCNM,PAYER,TMP,SUBTOT

SORT  ; sort by high paid amts

 ;"ARACT" ,LOC , PAYER)= COUNT ^ AMOUNT ^ ALLOWED AMT 

 S LOC="" F  S LOC=$O(^TMP($J,"BAR-PAY","ARACT",LOC)) Q:'LOC  D  ;

 . S ARACCT="" F  S ARACCT=$O(^TMP($J,"BAR-PAY","ARACT",LOC,ARACCT),1,TMP) Q:'ARACCT  D  ; TMP contains DATA

 . . S BARACX=$P(^BARAC(DUZ(2),ARACCT,0),U)  ; ADDED LINE

 . . S PAYER=$P(^AUTNINS(+BARACX,0),U,1)_U_ARACCT  ; allow for dupl names

 . . S LOCNM=$P(^BAR(90052.05,DUZ(2),LOC,0),U,4)

 . . S CNT=$P(TMP,U),AMT=$P(TMP,U,2),ALLOW=$P(TMP,U,3)

 . . S ^TMP($J,"BAR-PAYS",-AMT,LOCNM,PAYER)=CNT_U_ALLOW  ;

SUBSORT  ; Sort by Visit Location & Additional Requested sort

 ;  . S ^TMP($J,"BAR-PAY",BARTAG,VISITLOC,SORT(1),BARPAYER)=TMP

  S BARTAG="" F  S BARTAG=$O(^TMP($J,"BAR-PAY",BARTAG)) Q:BARTAG=""  D  Q:$G(BAR("F1"))

 . S LOC="" F  S LOC=$O(^TMP($J,"BAR-PAY",BARTAG,LOC)) Q:'LOC  D  Q:$G(BAR("F1"))

 . . S SORT(1)=""  F  S SORT(1)=$O(^TMP($J,"BAR-PAY",BARTAG,LOC,SORT(1))) Q:SORT(1)=""  D  Q:$G(BAR("F1"))

 . . . S ARACCT="" F  S ARACCT=$O(^TMP($J,"BAR-PAY",BARTAG,LOC,SORT(1),ARACCT),1,DATA) Q:ARACCT=""  D  Q:$G(BAR("F1"))  ;

 . . . . S BARACX=$P(^BARAC(DUZ(2),ARACCT,0),U)

 . . . . S CNT=$P(DATA,U),AMT=$P(DATA,U,2),ALLOW=$P(DATA,U,3)

 . . . . S PAYER=$P(^AUTNINS(+BARACX,0),U,1)_U_ARACCT  ; allow for dupl names

 . . . . S LOCNM=$P(^BAR(90052.05,DUZ(2),LOC,0),U,4)

 . . . . S ^TMP($J,"BAR-PAYS1",SORT(1),-AMT,LOCNM,PAYER)=CNT_U_ALLOW

 S BAR("PG")=0

 D HDB^BARRPSRB

 ;

 N LIMIT,AMT

 I $D(SUBNM) D PRTSBTL

 K SUBTOT  Q:$G(BAR("F1"))

GRTOT S AMT="" F LIMIT=1:1:BAR("NBR TO PRINT") S AMT=$O(^TMP($J,"BAR-PAYS",AMT)) Q:AMT=""  D  Q:$G(BAR("F1"))

 . S LOCNM="" F  S LOCNM=$O(^TMP($J,"BAR-PAYS",AMT,LOCNM)) Q:LOCNM=""  D  Q:$G(BAR("F1"))

 . . S PAYER="" F  S PAYER=$O(^TMP($J,"BAR-PAYS",AMT,LOCNM,PAYER),1,DATA) Q:PAYER=""  D  Q:$G(BAR("F1"))

 . . . I $Y>(IOSL-5) D HD^BARRPSRB Q:$G(BAR("F1"))

 . . . W !,$P(PAYER,U),?32,$J($P(DATA,U),7),?40,$J($FN(-AMT,",",2),16),?59,$J($FN($P(DATA,U,2),",",2),16)  ; strips off the AUTIN IEN

 . . . I $I(SUBTOT("CNT"),$P(DATA,U))  ; Increment totals

 . . . I $I(SUBTOT("AMT"),-AMT)

 . . . I $I(SUBTOT("ALLOW"),$P(DATA,U,2))

 . . . I $Y>(IOSL-5) D HD^BARRPSRB Q:$G(BAR("F1"))

 Q:$G(BAR("F1"))

 I $D(SUBTOT) D

 . W !!,"GRAND TOTALS",?33,$J($FN($G(SUBTOT("CNT")),","),6)

 . W ?40,$J($FN($G(SUBTOT("AMT")),",",2),16),?59,$J($FN($G(SUBTOT("ALLOW")),",",2),16),!!

 E  W !!!,"Nothing to report",!!!

 D PAZ^BARRUTL

 Q

PRTSBTL  ;

 N SUBTOTG  ; Grand Totals

 S SORT(1)="" F  S SORT(1)=$O(^TMP($J,"BAR-PAYS1",SORT(1))) Q:SORT(1)=""  D  D SORTSUB Q:$G(BAR("F1"))

 . I $Y>(IOSL-5) D HD^BARRPSRB Q:$G(BAR("F1"))

 . W !,?10,SUBNM,SORT(1)

 . S AMT=""  F LIMIT=1:1:BAR("NBR TO PRINT") S AMT=$O(^TMP($J,"BAR-PAYS1",SORT(1),AMT)) Q:AMT=""  D  Q:$G(BAR("F1"))

 . . S VLOC=""  S VLOC=$O(^TMP($J,"BAR-PAYS1",SORT(1),AMT,VLOC)) Q:VLOC=""  D  Q:$G(BAR("F1"))

 . . . S PAYER="" F  S PAYER=$O(^TMP($J,"BAR-PAYS1",SORT(1),AMT,VLOC,PAYER),1,DATA) Q:PAYER=""  D  Q:$G(BAR("F1"))

 . . . . W !,$P(PAYER,U),?32,$J($FN($P(DATA,U),","),7),?40,$J($FN(-AMT,",",2),16),?59,$J($FN($P(DATA,U,2),",",2),16)  ; strips off the IEN of Payer

 . . . . I $I(SUBTOT("CNT"),$P(DATA,U)),$I(SUBTOTG("GRCNT"),$P(DATA,U))  ; $Increment totals- Rpt Sort & Grand

 . . . . I $I(SUBTOT("AMT"),-AMT),$I(SUBTOTG("GRAMT"),-AMT)

 . . . . I $I(SUBTOT("ALLOW"),$P(DATA,U,2)),$I(SUBTOTG("GRALLOW"),$P(DATA,U,2))

 . . . . I $Y>(IOSL-5) D HD^BARRPSRB Q:$G(BAR("F1"))

 Q:$G(BAR("F1"))

 I $D(SUBTOTG) D

 . W !!,"TOTALS",?33,$J($FN($G(SUBTOTG("GRCNT")),","),6)

 . W ?40,$J($FN($G(SUBTOTG("GRAMT")),",",2),16),?59,$J($FN($G(SUBTOTG("GRALLOW")),",",2),16),!!

 D PAZ^BARRUTL I $Y>(IOSL-5) D HDB^BARRPSRB

  Q

 ; 

SORTSUB  ;

 Q:'$D(SUBTOT)

 W !,?5,"SUB-TOTALS",?33,$J($FN($G(SUBTOT("CNT")),","),6),?40,$J($FN($G(SUBTOT("AMT")),",",2),16),?59,$J($FN($G(SUBTOT("ALLOW")),",",2),16),!

 K SUBTOT

 I $Y>(IOSL-5) D HD^BARRPSRB Q:$G(BAR("F1"))

 Q

BARRPAY2  ; IHS/SD/PKD - TOP PAYERS REPORT ; 07/2/2010

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**19**;OCT 26, 2005

 +2       ; Print:  called from BARRPAY

 +3       ; New Reports - Top Payers - PKD 

 +4        QUIT 

 +5       ; *******************************

PRINT     ; EP   - 

 +1       ; Need to resort ^TMP($J,"BAR-PAY" by Amount Paid

 +2        SET BAR("COL")="W !,"_"""A/R ACCOUNT                      TX CNT        AMOUNT PD           ALLOWABLE"""

 +3       ; Sort into this

           KILL ^TMP($JOB,"BAR-PAYS")

 +4        KILL SUBTOT

 +5        NEW ALLOW,AMT,ARACCT,CNT,DATA,LOC,LOCNM,PAYER,TMP,SUBTOT

SORT      ; sort by high paid amts

 +1       ;"ARACT" ,LOC , PAYER)= COUNT ^ AMOUNT ^ ALLOWED AMT 

 +2       ;

           SET LOC=""

           FOR 

               SET LOC=$ORDER(^TMP($JOB,"BAR-PAY","ARACT",LOC))

               IF 'LOC

                   QUIT 

               Begin DoDot:1

 +3       ; TMP contains DATA

                   SET ARACCT=""

                   FOR 

                       SET ARACCT=$ORDER(^TMP($JOB,"BAR-PAY","ARACT",LOC,ARACCT),1,TMP)

                       IF 'ARACCT

                           QUIT 

                       Begin DoDot:2

 +4       ; ADDED LINE

                           SET BARACX=$PIECE(^BARAC(DUZ(2),ARACCT,0),U)

 +5       ; allow for dupl names

                           SET PAYER=$PIECE(^AUTNINS(+BARACX,0),U,1)_U_ARACCT

 +6                        SET LOCNM=$PIECE(^BAR(90052.05,DUZ(2),LOC,0),U,4)

 +7                        SET CNT=$PIECE(TMP,U)

                           SET AMT=$PIECE(TMP,U,2)

                           SET ALLOW=$PIECE(TMP,U,3)

 +8       ;

                           SET ^TMP($JOB,"BAR-PAYS",-AMT,LOCNM,PAYER)=CNT_U_ALLOW

                       End DoDot:2

               End DoDot:1

SUBSORT   ; Sort by Visit Location & Additional Requested sort

 +1       ;  . S ^TMP($J,"BAR-PAY",BARTAG,VISITLOC,SORT(1),BARPAYER)=TMP

 +2        SET BARTAG=""

           FOR 

               SET BARTAG=$ORDER(^TMP($JOB,"BAR-PAY",BARTAG))

               IF BARTAG=""

                   QUIT 

               Begin DoDot:1

 +3                SET LOC=""

                   FOR 

                       SET LOC=$ORDER(^TMP($JOB,"BAR-PAY",BARTAG,LOC))

                       IF 'LOC

                           QUIT 

                       Begin DoDot:2

 +4                        SET SORT(1)=""

                           FOR 

                               SET SORT(1)=$ORDER(^TMP($JOB,"BAR-PAY",BARTAG,LOC,SORT(1)))

                               IF SORT(1)=""

                                   QUIT 

                               Begin DoDot:3

 +5       ;

                                   SET ARACCT=""

                                   FOR 

                                       SET ARACCT=$ORDER(^TMP($JOB,"BAR-PAY",BARTAG,LOC,SORT(1),ARACCT),1,DATA)

                                       IF ARACCT=""

                                           QUIT 

                                       Begin DoDot:4

 +6                                        SET BARACX=$PIECE(^BARAC(DUZ(2),ARACCT,0),U)

 +7                                        SET CNT=$PIECE(DATA,U)

                                           SET AMT=$PIECE(DATA,U,2)

                                           SET ALLOW=$PIECE(DATA,U,3)

 +8       ; allow for dupl names

                                           SET PAYER=$PIECE(^AUTNINS(+BARACX,0),U,1)_U_ARACCT

 +9                                        SET LOCNM=$PIECE(^BAR(90052.05,DUZ(2),LOC,0),U,4)

 +10                                       SET ^TMP($JOB,"BAR-PAYS1",SORT(1),-AMT,LOCNM,PAYER)=CNT_U_ALLOW

                                       End DoDot:4

                                       IF $GET(BAR("F1"))

                                           QUIT 

                               End DoDot:3

                               IF $GET(BAR("F1"))

                                   QUIT 

                       End DoDot:2

                       IF $GET(BAR("F1"))

                           QUIT 

               End DoDot:1

               IF $GET(BAR("F1"))

                   QUIT 

 +11       SET BAR("PG")=0

 +12       DO HDB^BARRPSRB

 +13      ;

 +14       NEW LIMIT,AMT

 +15       IF $DATA(SUBNM)

               DO PRTSBTL

 +16       KILL SUBTOT

           IF $GET(BAR("F1"))

               QUIT 

GRTOT      SET AMT=""

           FOR LIMIT=1:1:BAR("NBR TO PRINT")

               SET AMT=$ORDER(^TMP($JOB,"BAR-PAYS",AMT))

               IF AMT=""

                   QUIT 

               Begin DoDot:1

 +1                SET LOCNM=""

                   FOR 

                       SET LOCNM=$ORDER(^TMP($JOB,"BAR-PAYS",AMT,LOCNM))

                       IF LOCNM=""

                           QUIT 

                       Begin DoDot:2

 +2                        SET PAYER=""

                           FOR 

                               SET PAYER=$ORDER(^TMP($JOB,"BAR-PAYS",AMT,LOCNM,PAYER),1,DATA)

                               IF PAYER=""

                                   QUIT 

                               Begin DoDot:3

 +3                                IF $Y>(IOSL-5)

                                       DO HD^BARRPSRB

                                       IF $GET(BAR("F1"))

                                           QUIT 

 +4       ; strips off the AUTIN IEN

                                   WRITE !,$PIECE(PAYER,U),?32,$JUSTIFY($PIECE(DATA,U),7),?40,$JUSTIFY($FNUMBER(-AMT,",",2),16),?59,$JUSTIFY($FNUMBER($PIECE(DATA,U,2),",",2),16)

 +5       ; Increment totals