BARRAMR.m

BARRAMR ; IHS/SD/LSL - Aging management report ;08/20/2008

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**7,24**;OCT 26, 2005;Build 69

 ;

 ; IHS/ASDS/LSL - 08/29/00 - Routine created

 ;     Really Age Detail and Bills Listing Reports

 ;

 ; IHS/SD/LSL - 04/19/02 - V1.6 Patch 2

 ;     Modified to accomodate new "Location to sort report by" parameter

 ; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892

 ;

 ;IHS/SD/POT HEAT118656 11/14/2013 fixed <undefined> error if VISIT LOC NIL / NOT DEF BAR*1.8*24

 Q

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

 ;

EN ; EP

 K BARY,BAR

 S BARP("RTN")="BARRAMR"

 S BAR("PRIVACY")=1                ; Privacy act applies

 D:'$D(BARUSR) INIT^BARUTL         ; Set A/R basic variable

 S BAR("LOC")=$$GET1^DIQ(90052.06,DUZ(2),16)   ; BILLING or VISIT

 I BAR("LOC")="" S BAR("LOC")="VISIT"

 D ^BARRSEL                        ; Select exclusion parameters

 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q

 I $D(BARY("RTYP")) S BAR("HD",0)=BARY("RTYP","NM")_" "_BARMENU

 E  S BAR("HD",0)=BARMENU

 D ^BARRHD                         ; Report header

 S BARQ("RC")="COMPUTE^BARRAMR"    ; Compute routine

 S BARQ("RP")="PRINT^BARRAMR"      ; Print routine

 S BARQ("NS")="BAR"                ; Namespace for variables

 S BARQ("RX")="POUT^BARRUTL"       ; Clean-up routine

 D ^BARDBQUE                       ; Double queuing

 D PAZ^BARRUTL

 Q

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

 ;

COMPUTE ;

 ;

 S BAR("SUBR")="BAR-AMR"

 K ^TMP($J,"BAR-AMR")

 S BARP("RTN")="BARRAMR"     ; Routine used to get data if no parameters

 I BAR("LOC")="BILLING" D LOOP^BARRUTL Q

 S BARDUZ2=DUZ(2)

 S DUZ(2)=0

 F  S DUZ(2)=$O(^BARBL(DUZ(2))) Q:'DUZ(2)  D LOOP^BARRUTL

 S DUZ(2)=BARDUZ2

 Q

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

 ;

DATA ; EP

 ; Called by BARRUTL if no parameters

 S BARP("HIT")=0

 D BILL^BARRCHK

 Q:'BARP("HIT")

 S BAR("BAL")=$P(BAR(0),U,15)     ; Current bill amt

 ; Quit if Age Detail report and absolute value of balance < a penny

 I BAR("OPT")="AGE",$FN(BAR("BAL"),"-")<.01 Q

 S BAR("PAT")=$$VAL^XBDIQ1(9000001,BAR("P"),.01)

 S BAR("SORT")=$S(BARY("SORT")="C":BAR("C"),1:BAR("V"))

 I BAR("I")]"" S BAR("ACCT")=$$VAL^XBDIQ1(90050.02,BAR("I"),.01)

 E  S BAR("ACCT")="No A/R Account"

 ;OLD CODE S BAR("L")=$$VAL^XBDIQ1(9999999.06,BAR("L"),.01)

 I BAR("L")]"" S BAR("L")=$$VAL^XBDIQ1(9999999.06,BAR("L"),.01)

 I BAR("L")="" S BAR("L")="UNK LOC" ;BAR*1.8*24

 ; For detail

 S ^TMP($J,"BAR-AMR",BAR("L")_U_BAR("SORT")_U_BAR("ACCT")_U_BAR("PAT")_U_BAR)=""

 ; For summary

 S $P(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT")),U)=$P($G(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT"))),U)+1

 S $P(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT")),U,2)=$P($G(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT"))),U,2)+$P(BAR(0),U,13)

 S $P(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT")),U,3)=$P($G(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT"))),U,3)+BAR("BAL")

 Q

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

 ;

PRINT ; EP

 ; Print

 S BAR("PG")=0

 I BARY("RTYP")=1 D DETAIL^BARRAMR2,FOOTER

 I BARY("RTYP")=2 D SUMM^BARRAMR3,FOOTER

 I BARY("RTYP")=3 D

 . D DETAIL^BARRAMR2

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

 . Q:'$D(@BAR)            ; No data

 . D PAZ^BARRUTL

 . D SUMM^BARRAMR3

 . D FOOTER

 Q

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

 ;

FOOTER ;

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

 I $D(BAR("ST")) D

 . W !!!!?16,"*****  R E P O R T  C O M P L E T E  *****"

 Q

BARRAMR   ; IHS/SD/LSL - Aging management report ;08/20/2008

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**7,24**;OCT 26, 2005;Build 69

 +2       ;

 +3       ; IHS/ASDS/LSL - 08/29/00 - Routine created

 +4       ;     Really Age Detail and Bills Listing Reports

 +5       ;

 +6       ; IHS/SD/LSL - 04/19/02 - V1.6 Patch 2

 +7       ;     Modified to accomodate new "Location to sort report by" parameter

 +8       ; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892

 +9       ;

 +10      ;IHS/SD/POT HEAT118656 11/14/2013 fixed <undefined> error if VISIT LOC NIL / NOT DEF BAR*1.8*24

 +11       QUIT 

 +12      ; *********************************************************************

 +13      ;

EN        ; EP

 +1        KILL BARY,BAR

 +2        SET BARP("RTN")="BARRAMR"

 +3       ; Privacy act applies

           SET BAR("PRIVACY")=1

 +4       ; Set A/R basic variable

           IF '$DATA(BARUSR)

               DO INIT^BARUTL

 +5       ; BILLING or VISIT

           SET BAR("LOC")=$$GET1^DIQ(90052.06,DUZ(2),16)

 +6        IF BAR("LOC")=""

               SET BAR("LOC")="VISIT"

 +7       ; Select exclusion parameters

           DO ^BARRSEL

 +8        IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               QUIT 

 +9        IF $DATA(BARY("RTYP"))

               SET BAR("HD",0)=BARY("RTYP","NM")_" "_BARMENU

 +10      IF '$TEST

               SET BAR("HD",0)=BARMENU

 +11      ; Report header

           DO ^BARRHD

 +12      ; Compute routine

           SET BARQ("RC")="COMPUTE^BARRAMR"

 +13      ; Print routine

           SET BARQ("RP")="PRINT^BARRAMR"

 +14      ; Namespace for variables

           SET BARQ("NS")="BAR"

 +15      ; Clean-up routine

           SET BARQ("RX")="POUT^BARRUTL"

 +16      ; Double queuing

           DO ^BARDBQUE

 +17       DO PAZ^BARRUTL

 +18       QUIT 

 +19      ; *********************************************************************

 +20      ;

COMPUTE   ;

 +1       ;

 +2        SET BAR("SUBR")="BAR-AMR"

 +3        KILL ^TMP($JOB,"BAR-AMR")

 +4       ; Routine used to get data if no parameters

           SET BARP("RTN")="BARRAMR"

 +5        IF BAR("LOC")="BILLING"

               DO LOOP^BARRUTL

               QUIT 

 +6        SET BARDUZ2=DUZ(2)

 +7        SET DUZ(2)=0

 +8        FOR 

               SET DUZ(2)=$ORDER(^BARBL(DUZ(2)))

               IF 'DUZ(2)

                   QUIT 

               DO LOOP^BARRUTL

 +9        SET DUZ(2)=BARDUZ2

 +10       QUIT 

 +11      ; *********************************************************************

 +12      ;

DATA      ; EP

 +1       ; Called by BARRUTL if no parameters

 +2        SET BARP("HIT")=0

 +3        DO BILL^BARRCHK

 +4        IF 'BARP("HIT")

               QUIT 

 +5       ; Current bill amt

           SET BAR("BAL")=$PIECE(BAR(0),U,15)

 +6       ; Quit if Age Detail report and absolute value of balance < a penny

 +7        IF BAR("OPT")="AGE"

               IF $FNUMBER(BAR("BAL"),"-")<.01

                   QUIT 

 +8        SET BAR("PAT")=$$VAL^XBDIQ1(9000001,BAR("P"),.01)

 +9        SET BAR("SORT")=$SELECT(BARY("SORT")="C":BAR("C"),1:BAR("V"))

 +10       IF BAR("I")]""

               SET BAR("ACCT")=$$VAL^XBDIQ1(90050.02,BAR("I"),.01)

 +11      IF '$TEST

               SET BAR("ACCT")="No A/R Account"

 +12      ;OLD CODE S BAR("L")=$$VAL^XBDIQ1(9999999.06,BAR("L"),.01)

 +13       IF BAR("L")]""

               SET BAR("L")=$$VAL^XBDIQ1(9999999.06,BAR("L"),.01)

 +14      ;BAR*1.8*24

           IF BAR("L")=""

               SET BAR("L")="UNK LOC"

 +15      ; For detail

 +16       SET ^TMP($JOB,"BAR-AMR",BAR("L")_U_BAR("SORT")_U_BAR("ACCT")_U_BAR("PAT")_U_BAR)=""

 +17      ; For summary

 +18       SET $PIECE(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT")),U)=$PIECE($GET(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT"))),U)+1

 +19       SET $PIECE(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT")),U,2)=$PIECE($GET(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT"))),U,2)+$PIECE(BAR(0),U,13)

 +20       SET $PIECE(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT")),U,3)=$PIECE($GET(BAR("ST",BAR("L"),BAR("SORT"),BAR("ACCT"))),U,3)+BAR("BAL")

 +21       QUIT 

 +22      ; *********************************************************************

 +23      ;

PRINT     ; EP

 +1       ; Print

 +2        SET BAR("PG")=0

 +3        IF BARY("RTYP")=1

               DO DETAIL^BARRAMR2

               DO FOOTER

 +4        IF BARY("RTYP")=2

               DO SUMM^BARRAMR3

               DO FOOTER

 +5        IF BARY("RTYP")=3

               Begin DoDot:1

 +6                DO DETAIL^BARRAMR2

 +7                IF $GET(BAR("F1"))

                       QUIT 

 +8       ; No data

                   IF '$DATA(@BAR)

                       QUIT 

 +9                DO PAZ^BARRUTL

 +10               DO SUMM^BARRAMR3

 +11               DO FOOTER

               End DoDot:1

 +12       QUIT 

 +13      ; *********************************************************************

 +14      ;

FOOTER    ;

 +1        IF $GET(BAR("F1"))

               QUIT 

 +2        IF $DATA(BAR("ST"))

               Begin DoDot:1

 +3                WRITE !!!!?16,"*****  R E P O R T  C O M P L E T E  *****"

               End DoDot:1

 +4        QUIT