BARRPRAC.m

BARRPRAC ; IHS/SD/SDR - Reimbursable Activity Report ; 04/09/2013

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

 ;;AUG 2013 NOHEAT P.OTTIS ADDED FILTER FOR FED LOC ONLY

 Q

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

 ;

EN ; EP

 K BARY,BAR

 S BARDONE=0

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

 S BARP("RTN")="BARRPRAC"       ; Routine used to gather data

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

 S BAR("LOC")="VISIT"           ; PSR should always be VISIT

 D DTTYP

 Q:BARDONE=1

 D DATES                        ; Ask transaction date range

 I +BARSTART<1 D XIT Q          ; Dates answered wrong

 D SETHDR                       ; Build header array

 S BARQ("RC")="COMPUTE^BARRPRAC"  ; Build tmp global with data

 S BARQ("RP")="PRINT^BARRPRAC"    ; Print reports from tmp global

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

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

 D ^BARDBQUE                    ; Double queuing

 D PAZ^BARRUTL                  ; Press return to continue

 Q

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

DTTYP ;EP

 D ^XBFMK

 S DIR(0)="SO^1:Approval Date;2:Visit Date"

 S DIR("A")="Select TYPE of DATE Desired"

 D ^DIR

 K DIR

 I $D(DUOUT)!$D(DTOUT) S BARDONE=1

 S BARY("DT")=$S(Y=1:"A",1:"V")

 Q

 ;

DATES ;

 ; Ask Date Range

 S BARDTYP=$S(BARY("DT")="A":"Approval Date",1:"Date of Service")

 W !!," ============ Entry of "_BARDTYP_" Range =============",!

 S BARSTART=$$DATE^BARDUTL(1)

 I BARSTART<1 Q

 S BAREND=$$DATE^BARDUTL(2)

 I BAREND<1 W ! G DATES

 I BAREND<BARSTART D  G DATES

 .W *7

 .W !!,"The END date must not be before the START date.",!

 S BARY("DT",1)=BARSTART

 S BARY("DT",2)=BAREND

 Q

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

 ;

SETHDR ;

 ; Build header array

 S BAR("OPT")="RAC"

 S BAR("LVL")=0

 S BAR("HD",0)="Reimbursable Activity Report"

 D DT^BARRHD

 S BAR("LVL")=$G(BAR("LVL"))+1

 S BAR("HD",BAR("LVL"))=""

 S BAR("TXT")="ALL"

 I $D(BARY("LOC")) S BAR("TXT")=$P(^DIC(4,BARY("LOC"),0),U)

 I BAR("LOC")="BILLING" D

 . S BAR("TXT")=BAR("TXT")_" Visit location(s) under "

 . S BAR("TXT")=BAR("TXT")_$P(^DIC(4,DUZ(2),0),U)

 . S BAR("TXT")=BAR("TXT")_" Billing Location"

 E  S BAR("TXT")=BAR("TXT")_" Visit location(s) regardless of Billing Location"

 S BAR("CONJ")="at "

 D CHK^BARRHD

 Q

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

 ;

COMPUTE ; EP

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

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

 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 ;old code

 F  S DUZ(2)=$O(^BARBL(DUZ(2))) Q:'DUZ(2)  I $$IHS^BARUFUT(DUZ(2)) D LOOP^BARRUTL ;FED LOC ONLY 8/27/13

 S DUZ(2)=BARDUZ2

 Q

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

 ;

DATA ; EP

 S BAR0=$G(^BARBL(DUZ(2),BAR,0))

 S D0=$P(BAR0,U,3)

 S BARITYP=$$VALI^BARVPM(8)  ;GET INTERNAL CODE INSTEAD OF 'STANDS FOR'

 S:(BARITYP'="N") BARACCT=$$GET1^DIQ(90050.02,$P(BAR0,U,3),".01","E")

 S:(BARITYP="N") BARACCT="NON-BENEFICIARY"

 S BARBILLN=$P(BAR0,U)

 S BARAPPDT=$$CDT^BARDUTL($P(BAR0,U,18))

 S BARDUZ2=$P(BAR0,U,22)

 S BARIEN=$P(BAR0,U,17)

 S BARAPPR=$P($G(^ABMDBILL(BARDUZ2,BARIEN,1)),U,4)

 S BARAPPR=$$GET1^DIQ(200,BARAPPR,".01","E")

 S BARBAMT=$J($FN($P(BAR0,U,13),",",2),13)

 S BARCBAMT=$J($FN($P(BAR0,U,15),",",2),13)

 S BARDOS=$$CDT^BARDUTL($P($G(^BARBL(DUZ(2),BAR,1)),U,2))

 S D0=$P(BAR0,U,3)

 S BARITYP=$$VALI^BARVPM(8)  ;GET INTERNAL CODE INSTEAD OF 'STANDS FOR'

 S BARITIEN=$O(^AUTTINTY("C",BARITYP,0))

 S BARITYP=$$GET1^DIQ(9999999.181,BARITIEN,".01","E")

 S BARSIEN=$O(^BARBL(DUZ(2),BAR,9,9999999),-1)

 S:BARSIEN BARSTAT=$P($G(^BARBL(DUZ(2),BAR,9,BARSIEN,0)),U,3)

 S:'BARSIEN BARSTAT="NONE"

 S BARVLOC=$$GET1^DIQ(90050.01,BAR,108,"E")

 S BARREC=BARBILLN_U_BARACCT_U_BARAPPDT_U_BARAPPR_U_BARBAMT_U_BARCBAMT_U_BARDOS_U_BARITYP_U_BARSTAT_U_BARVLOC

 S ^TMP($J,"BAR-RAC",BARBILLN)=BARREC

 Q

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

XIT ;

 D ^BARVKL0

 Q

PRINT ;

 W !,"BILL#^A/R ACCT^APPROVAL DATE^APPROVING OFFICAL^BILL AMOUNT^CURRENT BILL AMOUNT^DATE OF SERVICE^INSURER TYPE^STATUS FIELD^VISIT LOCATION"

 S BARB=""

 F  S BARB=$O(^TMP($J,"BAR-RAC",BARB)) Q:BARB=""  D

 .W !,$G(^TMP($J,"BAR-RAC",BARB))

 Q

BARRPRAC  ; IHS/SD/SDR - Reimbursable Activity Report ; 04/09/2013

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

 +2       ;;AUG 2013 NOHEAT P.OTTIS ADDED FILTER FOR FED LOC ONLY

 +3        QUIT 

 +4       ; *********************************************************************

 +5       ;

EN        ; EP

 +1        KILL BARY,BAR

 +2        SET BARDONE=0

 +3       ; Set up basic A/R Variables

           IF '$DATA(BARUSR)

               DO INIT^BARUTL

 +4       ; Routine used to gather data

           SET BARP("RTN")="BARRPRAC"

 +5       ; Privacy act applies (used BARRHD)

           SET BAR("PRIVACY")=1

 +6       ; PSR should always be VISIT

           SET BAR("LOC")="VISIT"

 +7        DO DTTYP

 +8        IF BARDONE=1

               QUIT 

 +9       ; Ask transaction date range

           DO DATES

 +10      ; Dates answered wrong

           IF +BARSTART<1

               DO XIT

               QUIT 

 +11      ; Build header array

           DO SETHDR

 +12      ; Build tmp global with data

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

 +13      ; Print reports from tmp global

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

 +14      ; Namespace for variables

           SET BARQ("NS")="BAR"

 +15      ; Clean-up routine

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

 +16      ; Double queuing

           DO ^BARDBQUE

 +17      ; Press return to continue

           DO PAZ^BARRUTL

 +18       QUIT 

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

DTTYP     ;EP

 +1        DO ^XBFMK

 +2        SET DIR(0)="SO^1:Approval Date;2:Visit Date"

 +3        SET DIR("A")="Select TYPE of DATE Desired"

 +4        DO ^DIR

 +5        KILL DIR

 +6        IF $DATA(DUOUT)!$DATA(DTOUT)

               SET BARDONE=1

 +7        SET BARY("DT")=$SELECT(Y=1:"A",1:"V")

 +8        QUIT 

 +9       ;

DATES     ;

 +1       ; Ask Date Range

 +2        SET BARDTYP=$SELECT(BARY("DT")="A":"Approval Date",1:"Date of Service")

 +3        WRITE !!," ============ Entry of "_BARDTYP_" Range =============",!

 +4        SET BARSTART=$$DATE^BARDUTL(1)

 +5        IF BARSTART<1

               QUIT 

 +6        SET BAREND=$$DATE^BARDUTL(2)

 +7        IF BAREND<1

               WRITE !

               GOTO DATES

 +8        IF BAREND<BARSTART

               Begin DoDot:1

 +9                WRITE *7

 +10               WRITE !!,"The END date must not be before the START date.",!

               End DoDot:1

               GOTO DATES

 +11       SET BARY("DT",1)=BARSTART

 +12       SET BARY("DT",2)=BAREND

 +13       QUIT 

 +14      ; ********************************************************************

 +15      ;

SETHDR    ;

 +1       ; Build header array

 +2        SET BAR("OPT")="RAC"

 +3        SET BAR("LVL")=0

 +4        SET BAR("HD",0)="Reimbursable Activity Report"

 +5        DO DT^BARRHD

 +6        SET BAR("LVL")=$GET(BAR("LVL"))+1

 +7        SET BAR("HD",BAR("LVL"))=""

 +8        SET BAR("TXT")="ALL"

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

               SET BAR("TXT")=$PIECE(^DIC(4,BARY("LOC"),0),U)

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

               Begin DoDot:1

 +11               SET BAR("TXT")=BAR("TXT")_" Visit location(s) under "

 +12               SET BAR("TXT")=BAR("TXT")_$PIECE(^DIC(4,DUZ(2),0),U)

 +13               SET BAR("TXT")=BAR("TXT")_" Billing Location"

               End DoDot:1

 +14      IF '$TEST

               SET BAR("TXT")=BAR("TXT")_" Visit location(s) regardless of Billing Location"

 +15       SET BAR("CONJ")="at "

 +16       DO CHK^BARRHD

 +17       QUIT 

 +18      ; *********************************************************************

 +19      ;

COMPUTE   ; EP

 +1        SET BAR("SUBR")="BAR-RAC"

 +2        KILL ^TMP($JOB,"BAR-RAC")

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

               DO LOOP^BARRUTL

               QUIT 

 +4        SET BARDUZ2=DUZ(2)

 +5        SET DUZ(2)=0

 +6       ;F  S DUZ(2)=$O(^BARBL(DUZ(2))) Q:'DUZ(2) D LOOP^BARRUTL ;old code

 +7       ;FED LOC ONLY 8/27/13

           FOR 

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

               IF 'DUZ(2)

                   QUIT 

               IF $$IHS^BARUFUT(DUZ(2))

                   DO LOOP^BARRUTL

 +8        SET DUZ(2)=BARDUZ2

 +9        QUIT 

 +10      ; *********************************************************************

 +11      ;

DATA      ; EP

 +1        SET BAR0=$GET(^BARBL(DUZ(2),BAR,0))

 +2        SET D0=$PIECE(BAR0,U,3)

 +3       ;GET INTERNAL CODE INSTEAD OF 'STANDS FOR'

           SET BARITYP=$$VALI^BARVPM(8)

 +4        IF (BARITYP'="N")

               SET BARACCT=$$GET1^DIQ(90050.02,$PIECE(BAR0,U,3),".01","E")

 +5        IF (BARITYP="N")

               SET BARACCT="NON-BENEFICIARY"

 +6        SET BARBILLN=$PIECE(BAR0,U)

 +7        SET BARAPPDT=$$CDT^BARDUTL($PIECE(BAR0,U,18))

 +8        SET BARDUZ2=$PIECE(BAR0,U,22)

 +9        SET BARIEN=$PIECE(BAR0,U,17)

 +10       SET BARAPPR=$PIECE($GET(^ABMDBILL(BARDUZ2,BARIEN,1)),U,4)

 +11       SET BARAPPR=$$GET1^DIQ(200,BARAPPR,".01","E")

 +12       SET BARBAMT=$JUSTIFY($FNUMBER($PIECE(BAR0,U,13),",",2),13)

 +13       SET BARCBAMT=$JUSTIFY($FNUMBER($PIECE(BAR0,U,15),",",2),13)

 +14       SET BARDOS=$$CDT^BARDUTL($PIECE($GET(^BARBL(DUZ(2),BAR,1)),U,2))

 +15       SET D0=$PIECE(BAR0,U,3)

 +16      ;GET INTERNAL CODE INSTEAD OF 'STANDS FOR'

           SET BARITYP=$$VALI^BARVPM(8)

 +17       SET BARITIEN=$ORDER(^AUTTINTY("C",BARITYP,0))

 +18       SET BARITYP=$$GET1^DIQ(9999999.181,BARITIEN,".01","E")

 +19       SET BARSIEN=$ORDER(^BARBL(DUZ(2),BAR,9,9999999),-1)

 +20       IF BARSIEN

               SET BARSTAT=$PIECE($GET(^BARBL(DUZ(2),BAR,9,BARSIEN,0)),U,3)

 +21       IF 'BARSIEN

               SET BARSTAT="NONE"

 +22       SET BARVLOC=$$GET1^DIQ(90050.01,BAR,108,"E")

 +23       SET BARREC=BARBILLN_U_BARACCT_U_BARAPPDT_U_BARAPPR_U_BARBAMT_U_BARCBAMT_U_BARDOS_U_BARITYP_U_BARSTAT_U_BARVLOC

 +24       SET ^TMP($JOB,"BAR-RAC",BARBILLN)=BARREC

 +25       QUIT 

 +26      ; *********************************************************************

XIT       ;

 +1        DO ^BARVKL0

 +2        QUIT 

PRINT     ;

 +1        WRITE !,"BILL#^A/R ACCT^APPROVAL DATE^APPROVING OFFICAL^BILL AMOUNT^CURRENT BILL AMOUNT^DATE OF SERVICE^INSURER TYPE^STATUS FIELD^VISIT LOCATION"

 +2        SET BARB=""

 +3        FOR 

               SET BARB=$ORDER(^TMP($JOB,"BAR-RAC",BARB))

               IF BARB=""

                   QUIT 

               Begin DoDot:1

 +4                WRITE !,$GET(^TMP($JOB,"BAR-RAC",BARB))

               End DoDot:1

 +5        QUIT