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
