- 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
