BARRLBL ; IHS/SD/LSL - Large and Small Balance Reports ;08/20/2008
;;1.8;IHS ACCOUNTS RECEIVABLE;**7**;OCT 26, 2005
; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
; IHS/SD/LSL - 04/04/2003 - Version 1.8
; Routine created. New reports
;
; ********************************************************************
Q
;
EN ; EP
K BARY,BAR
S BARP("RTN")="BARRLBL"
S BAR("PRIVACY")=1 ; Privacy act applies
D:'$D(BARUSR) INIT^BARUTL ; Set A/R basic variable
S BAR("LOC")="VISIT" ; Always visit location
D ^BARRSEL ; Select exclusion parameters
I $D(BARY("ALL")) S BARY("ALL")=$$CONVERT^BARRSL2(BARY("ALL"))
I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q
; Use OBAL x-ref if not specific patient or account
I '$D(BARY("ACCT")),'$D(BARY("PAT")) S BARY("STCR")=1
S BAR("HD",0)=BARMENU
I BAR("OPT")="LBL" S BAR("HD",0)=BAR("HD",0)_" over $"_$FN(BARY("LBL"),",",2)
I BAR("OPT")="SBL" S BAR("HD",0)=BAR("HD",0)_" under $"_$FN(BARY("SBL"),",",2)
D ^BARRHD ; Report header
S BARQ("RC")="COMPUTE^BARRLBL" ; Compute routine
S BARQ("RP")="PRINT^BARRLBL" ; 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-LBL"
K ^TMP($J,"BAR-LBL")
S BARP("RTN")="BARRLBL" ; Routine used to get data if no parameters
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 ;
S BARBAL=$$GET1^DIQ(90050.01,BAR,15)
I BAR("OPT")="SBL",BARBAL<0 Q
I BAR("OPT")="SBL",BARBAL>BARY("SBL") Q
I BAR("OPT")="LBL",BARBAL<BARY("LBL") Q
S BARP("HIT")=0
D BILL^BARRCHK
Q:'BARP("HIT")
S BARLOC=""
S:BAR("L")]"" BARLOC=$$GET1^DIQ(4,BAR("L"),.01)
S:BARLOC="" BARLOC="No Visit Location" ; Visit Location Name
S BARACCT=""
S:BAR("I")]"" BARACCT=$$GET1^DIQ(90050.02,BAR("I"),.01)
S:BARACCT="" BARACCT="No A/R Account" ; A/R Account Name
S:'+BAR("A") BAR("A")=9999999
I $G(BARY("SORT"))="C" D
. S BAR2=BAR("C")
. I BAR2]"",BAR2'=99999 S BAR2=$$GET1^DIQ(40.7,BAR2,.01)
. S:BAR2=""!(BAR2=99999) BAR2="No Clinic Type"
I $G(BARY("SORT"))="V" D
. S BAR2=BAR("V")
. I BAR2]"",BAR2'=99999 S BAR2=$$GET1^DIQ(9002274.8,BAR2,.01)
. S:BAR2=""!(BAR2=99999) BAR2="No Visit Type"
S BARBILL=$P(BAR(0),U,13)
S BARBL=$P(BAR(0),U)
S BARAGE=$$GET1^DIQ(90050.01,BAR,7.2)
S BARDTB=$$FMDIFF^XLFDT(DT,BAR("D"))
;
I $D(BARY("SORT")) D CLINVIS
E D ACCT
;
S BARHOLD=$G(^TMP($J,"BAR-LBL",BARLOC))
S $P(^TMP($J,"BAR-LBL",BARLOC),U)=$P(BARHOLD,U)+BARDTB
S $P(^TMP($J,"BAR-LBL",BARLOC),U,2)=$P(BARHOLD,U,2)+BARBILL
S $P(^TMP($J,"BAR-LBL",BARLOC),U,3)=$P(BARHOLD,U,3)+BARBAL
S $P(^TMP($J,"BAR-LBL",BARLOC),U,4)=$P(BARHOLD,U,4)+BARAGE
S $P(^TMP($J,"BAR-LBL",BARLOC),U,5)=$P(BARHOLD,U,5)+1
;
S BARHOLD=$G(^TMP($J,"BAR-LBL"))
S $P(^TMP($J,"BAR-LBL"),U)=$P(BARHOLD,U)+BARDTB
S $P(^TMP($J,"BAR-LBL"),U,2)=$P(BARHOLD,U,2)+BARBILL
S $P(^TMP($J,"BAR-LBL"),U,3)=$P(BARHOLD,U,3)+BARBAL
S $P(^TMP($J,"BAR-LBL"),U,4)=$P(BARHOLD,U,4)+BARAGE
S $P(^TMP($J,"BAR-LBL"),U,5)=$P(BARHOLD,U,5)+1
Q
; ********************************************************************
;
ACCT ;
; Store data by AR Account
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U)=BAR("D")
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U,2)=BARDTB
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U,3)=BARBILL
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U,4)=BARBAL
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U,5)=BARAGE
;
S BARHOLD=$G(^TMP($J,"BAR-LBL",BARLOC,BARACCT))
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT),U)=$P(BARHOLD,U)+BARDTB
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT),U,2)=$P(BARHOLD,U,2)+BARBILL
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT),U,3)=$P(BARHOLD,U,3)+BARBAL
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT),U,4)=$P(BARHOLD,U,4)+BARAGE
S $P(^TMP($J,"BAR-LBL",BARLOC,BARACCT),U,5)=$P(BARHOLD,U,5)+1
Q
; ********************************************************************
;
CLINVIS ;
; Store data by Clinic/Visit Type
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U)=BAR("D")
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U,2)=BARDTB
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U,3)=BARBILL
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U,4)=BARBAL
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U,5)=BARAGE
;
S BARHOLD=$G(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT))
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT),U)=$P(BARHOLD,U)+BARDTB
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT),U,2)=$P(BARHOLD,U,2)+BARBILL
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT),U,3)=$P(BARHOLD,U,3)+BARBAL
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT),U,4)=$P(BARHOLD,U,4)+BARAGE
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2,BARACCT),U,5)=$P(BARHOLD,U,5)+1
;
S BARHOLD=$G(^TMP($J,"BAR-LBL",BARLOC,BAR2))
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2),U)=$P(BARHOLD,U)+BARDTB
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2),U,2)=$P(BARHOLD,U,2)+BARBILL
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2),U,3)=$P(BARHOLD,U,3)+BARBAL
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2),U,4)=$P(BARHOLD,U,4)+BARAGE
S $P(^TMP($J,"BAR-LBL",BARLOC,BAR2),U,5)=$P(BARHOLD,U,5)+1
Q
; ********************************************************************
; ********************************************************************
;
PRINT ;
; Print reports
K BAR2,BARHOLD,BARBILL,BAR3P,BARACCT,BARLOC,BARDTB,BAR("D"),BAR("A")
K BARBAL,BARAGE
I BAR("OPT")="LBL" D LARGE^BARRLBL2 Q
I BAR("OPT")="SBL" D SMALL^BARRLBL3 Q
Q
BARRLBL ; IHS/SD/LSL - Large and Small Balance Reports ;08/20/2008
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**7**;OCT 26, 2005
+2 ; MODIFIED XTMP FILE NAME TO TMP TO MEET SAC REQUIREMENTS;MRS:BAR*1.8*7 IM29892
+3 ; IHS/SD/LSL - 04/04/2003 - Version 1.8
+4 ; Routine created. New reports
+5 ;
+6 ; ********************************************************************
+7 QUIT
+8 ;
EN ; EP
+1 KILL BARY,BAR
+2 SET BARP("RTN")="BARRLBL"
+3 ; Privacy act applies
SET BAR("PRIVACY")=1
+4 ; Set A/R basic variable
IF '$DATA(BARUSR)
DO INIT^BARUTL
+5 ; Always visit location
SET BAR("LOC")="VISIT"
+6 ; Select exclusion parameters
DO ^BARRSEL
+7 IF $DATA(BARY("ALL"))
SET BARY("ALL")=$$CONVERT^BARRSL2(BARY("ALL"))
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+9 ; Use OBAL x-ref if not specific patient or account
+10 IF '$DATA(BARY("ACCT"))
IF '$DATA(BARY("PAT"))
SET BARY("STCR")=1
+11 SET BAR("HD",0)=BARMENU
+12 IF BAR("OPT")="LBL"
SET BAR("HD",0)=BAR("HD",0)_" over $"_$FNUMBER(BARY("LBL"),",",2)
+13 IF BAR("OPT")="SBL"
SET BAR("HD",0)=BAR("HD",0)_" under $"_$FNUMBER(BARY("SBL"),",",2)
+14 ; Report header
DO ^BARRHD
+15 ; Compute routine
SET BARQ("RC")="COMPUTE^BARRLBL"
+16 ; Print routine
SET BARQ("RP")="PRINT^BARRLBL"
+17 ; Namespace for variables
SET BARQ("NS")="BAR"
+18 ; Clean-up routine
SET BARQ("RX")="POUT^BARRUTL"
+19 ; Double queuing
DO ^BARDBQUE
+20 DO PAZ^BARRUTL
+21 QUIT
+22 ; ********************************************************************
+23 ;
COMPUTE ;
+1 ;
+2 SET BAR("SUBR")="BAR-LBL"
+3 KILL ^TMP($JOB,"BAR-LBL")
+4 ; Routine used to get data if no parameters
SET BARP("RTN")="BARRLBL"
+5 SET BARDUZ2=DUZ(2)
+6 SET DUZ(2)=0
+7 FOR
SET DUZ(2)=$ORDER(^BARBL(DUZ(2)))
IF 'DUZ(2)
QUIT
DO LOOP^BARRUTL
+8 SET DUZ(2)=BARDUZ2
+9 QUIT
+10 ; *********************************************************************
+11 ;
DATA ;
+1 SET BARBAL=$$GET1^DIQ(90050.01,BAR,15)
+2 IF BAR("OPT")="SBL"
IF BARBAL<0
QUIT
+3 IF BAR("OPT")="SBL"
IF BARBAL>BARY("SBL")
QUIT
+4 IF BAR("OPT")="LBL"
IF BARBAL<BARY("LBL")
QUIT
+5 SET BARP("HIT")=0
+6 DO BILL^BARRCHK
+7 IF 'BARP("HIT")
QUIT
+8 SET BARLOC=""
+9 IF BAR("L")]""
SET BARLOC=$$GET1^DIQ(4,BAR("L"),.01)
+10 ; Visit Location Name
IF BARLOC=""
SET BARLOC="No Visit Location"
+11 SET BARACCT=""
+12 IF BAR("I")]""
SET BARACCT=$$GET1^DIQ(90050.02,BAR("I"),.01)
+13 ; A/R Account Name
IF BARACCT=""
SET BARACCT="No A/R Account"
+14 IF '+BAR("A")
SET BAR("A")=9999999
+15 IF $GET(BARY("SORT"))="C"
Begin DoDot:1
+16 SET BAR2=BAR("C")
+17 IF BAR2]""
IF BAR2'=99999
SET BAR2=$$GET1^DIQ(40.7,BAR2,.01)
+18 IF BAR2=""!(BAR2=99999)
SET BAR2="No Clinic Type"
End DoDot:1
+19 IF $GET(BARY("SORT"))="V"
Begin DoDot:1
+20 SET BAR2=BAR("V")
+21 IF BAR2]""
IF BAR2'=99999
SET BAR2=$$GET1^DIQ(9002274.8,BAR2,.01)
+22 IF BAR2=""!(BAR2=99999)
SET BAR2="No Visit Type"
End DoDot:1
+23 SET BARBILL=$PIECE(BAR(0),U,13)
+24 SET BARBL=$PIECE(BAR(0),U)
+25 SET BARAGE=$$GET1^DIQ(90050.01,BAR,7.2)
+26 SET BARDTB=$$FMDIFF^XLFDT(DT,BAR("D"))
+27 ;
+28 IF $DATA(BARY("SORT"))
DO CLINVIS
+29 IF '$TEST
DO ACCT
+30 ;
+31 SET BARHOLD=$GET(^TMP($JOB,"BAR-LBL",BARLOC))
+32 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC),U)=$PIECE(BARHOLD,U)+BARDTB
+33 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC),U,2)=$PIECE(BARHOLD,U,2)+BARBILL
+34 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC),U,3)=$PIECE(BARHOLD,U,3)+BARBAL
+35 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC),U,4)=$PIECE(BARHOLD,U,4)+BARAGE
+36 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC),U,5)=$PIECE(BARHOLD,U,5)+1
+37 ;
+38 SET BARHOLD=$GET(^TMP($JOB,"BAR-LBL"))
+39 SET $PIECE(^TMP($JOB,"BAR-LBL"),U)=$PIECE(BARHOLD,U)+BARDTB
+40 SET $PIECE(^TMP($JOB,"BAR-LBL"),U,2)=$PIECE(BARHOLD,U,2)+BARBILL
+41 SET $PIECE(^TMP($JOB,"BAR-LBL"),U,3)=$PIECE(BARHOLD,U,3)+BARBAL
+42 SET $PIECE(^TMP($JOB,"BAR-LBL"),U,4)=$PIECE(BARHOLD,U,4)+BARAGE
+43 SET $PIECE(^TMP($JOB,"BAR-LBL"),U,5)=$PIECE(BARHOLD,U,5)+1
+44 QUIT
+45 ; ********************************************************************
+46 ;
ACCT ;
+1 ; Store data by AR Account
+2 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U)=BAR("D")
+3 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U,2)=BARDTB
+4 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U,3)=BARBILL
+5 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U,4)=BARBAL
+6 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT,BAR("A"),BARBL),U,5)=BARAGE
+7 ;
+8 SET BARHOLD=$GET(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT))
+9 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT),U)=$PIECE(BARHOLD,U)+BARDTB
+10 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT),U,2)=$PIECE(BARHOLD,U,2)+BARBILL
+11 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT),U,3)=$PIECE(BARHOLD,U,3)+BARBAL
+12 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT),U,4)=$PIECE(BARHOLD,U,4)+BARAGE
+13 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BARACCT),U,5)=$PIECE(BARHOLD,U,5)+1
+14 QUIT
+15 ; ********************************************************************
+16 ;
CLINVIS ;
+1 ; Store data by Clinic/Visit Type
+2 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U)=BAR("D")
+3 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U,2)=BARDTB
+4 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U,3)=BARBILL
+5 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U,4)=BARBAL
+6 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT,BAR("A"),BARBL),U,5)=BARAGE
+7 ;
+8 SET BARHOLD=$GET(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT))
+9 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT),U)=$PIECE(BARHOLD,U)+BARDTB
+10 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT),U,2)=$PIECE(BARHOLD,U,2)+BARBILL
+11 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT),U,3)=$PIECE(BARHOLD,U,3)+BARBAL
+12 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT),U,4)=$PIECE(BARHOLD,U,4)+BARAGE
+13 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2,BARACCT),U,5)=$PIECE(BARHOLD,U,5)+1
+14 ;
+15 SET BARHOLD=$GET(^TMP($JOB,"BAR-LBL",BARLOC,BAR2))
+16 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2),U)=$PIECE(BARHOLD,U)+BARDTB
+17 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2),U,2)=$PIECE(BARHOLD,U,2)+BARBILL
+18 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2),U,3)=$PIECE(BARHOLD,U,3)+BARBAL
+19 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2),U,4)=$PIECE(BARHOLD,U,4)+BARAGE
+20 SET $PIECE(^TMP($JOB,"BAR-LBL",BARLOC,BAR2),U,5)=$PIECE(BARHOLD,U,5)+1
+21 QUIT
+22 ; ********************************************************************
+23 ; ********************************************************************
+24 ;
PRINT ;
+1 ; Print reports
+2 KILL BAR2,BARHOLD,BARBILL,BAR3P,BARACCT,BARLOC,BARDTB,BAR("D"),BAR("A")
+3 KILL BARBAL,BARAGE
+4 IF BAR("OPT")="LBL"
DO LARGE^BARRLBL2
QUIT
+5 IF BAR("OPT")="SBL"
DO SMALL^BARRLBL3
QUIT
+6 QUIT
