BARMAWO ; IHS/SD/LSL - Automatic Write Off ;
;;1.8;IHS ACCOUNTS RECEIVABLE;**1,2,28**;OCT 26, 2005;Build 92
;
; IHS/ASDS/LSL - 12/11/00 - Routine created
; This routine is intended to be used to clean up accounts
; receivable on dates of service prior to 06/30/00. It is intended
; to be a one time option. It may not be used after 07/01/01.
;
; All bills for up to and including the DOS specified for the
; A/R Accounts specified will be written off to a special code if
; The amount billed is not greater than 20,000, the date of service
; is before 06/30/2000, and there is not a credit balance.
;
; IHS/ASDS/LSL - 01/22/01
; Modified to mark bill complete in 3PB and populate payment mult.
;
; IHS/ASDS/LSL - 01/23/01
; Modified to allow write off by visit location
;
; IHS/ASDS/LSL - 06/15/01 - V1.5 Patch 1 - NOIS HQW-0601-100051
; Extend expiration date to 12/31/2001.
;
; IHS/ASDS/LSL - 09/07/01 - V1.5 Patch 2
; Modified to include finance specifications
; DOS must be at least 3 years old
; Don't allow write-off of non-bens
; Option expires by parameter or default to 10/15/01
; One time only?????
;
; *********************************************************************
;STOP!!! STOP!!!! STOP!!!!
;IHS/SD/SDR 1.8*28 HEAT293633 - This is an old, outdated routine and shouldn't be used
; without review and possible changes. Routine EN^BARMAWO6 should be used instead. A
; quit has been added to this routine so it can't be accidentally run.
; *********************************************************************
;
Q
;
EN ;EP - IHS/DIT/CPC 1.8*28 CR 8349 START
W "*********************************************************************",!
W " STOP!!! STOP!!!! STOP!!!!",!
W "This is an old, outdated routine and shouldn't be used. Please ",!
W "request assistance from OIT before starting the write-off process.",!
W "*********************************************************************",!
H 10
Q ;IHS/DIT/CPC 1.8*28 CR 8349 STOP
;
S BARHOLD=DUZ(2)
S (BARCONT,BARCNT)=0
S BARSECT=$$GET1^DIQ(200,DUZ,29,"I") ; Serv/Sect from NEW PERSON
;BAR*1.8*1 SPLIT MESSAGE SO ONE IS APPROPRIATE FOR UFMS AND THE OTHER FOR INTERIM
S BAREXP=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,15)
;I BAREXP=3070430 D
I BAREXP=3070525 D ;BAR*1.8*2
.W !!,"This menu is meant to be used as a tool for meeting the UFMS"
.W !,"clean-up deadline. The user is asked for a list of visit locations (or all),"
.W !,"and list of A/R Accounts (or all). The account balance of each bill found"
.W !,"with a DOS up to and including 9/30/2005 will be written off to"
.W !,"code 916 Auto Write-off 2007 if the following conditions are met:"
E D
.W !!,"This menu is meant to be used as a tool for meeting the A/R Interim Policy"
.W !,"clean-up deadline. The user is asked for a list of visit locations (or all),"
.W !,"date of service (DOS) and list of A/R Accounts (or all). The account balance"
.W !,"of each bill found with a DOS up to and including the DOS entered will be"
.W !,"written off to code 502 Auto Write-off 2001 if the following conditions are met:"
;BAR*1.8*1
;I BAREXP=3070430 W !!?5,"1. The DOS on the bill is prior to 10/1/2005"
I BAREXP=3070525 W !!?5,"1. The DOS on the bill is prior to 10/1/2005" ;BAR*1.8*2
E W !!?5,"1. The DOS on the bill is at least three (3) years old."
;W !!?5,"1. The DOS on the bill is at least three (3) years old."
W !?5,"2. The amount billed is less than 20,000.00"
W !?5,"3. The A/R Account tied to the bill is in the list specified"
W !?5," and not NON-BENEFICIARY."
W !?5,"4. There is a positive balance left on the bill"
W !?5,"5. The Visit Location tied to the bill is in the list specified"
S BAREXP=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,15)
S:BAREXP="" BAREXP=3011015
S Y=BAREXP
D DD^%DT
S BAREXPDT=Y
W !!,"This menu option expires on ",BAREXPDT,"."
;
I DT>BAREXP D Q
. W !!!?20,"*** This option expired on ",BAREXPDT," *****"
. D PAZ
. D XIT
W !!
D ASKLOC ; Ask visit location list
I '+BARLOC D XIT Q
D ASKDOS ; Ask Date of Service
Q:'$D(BARDOS) ; Quit if invalid date entered
D ASKACCT ; Ask A/R Account List
I '+BARACCT D XIT Q
D CONTINUE ; Display choices ask continue
I '+BARCONT D XIT Q ; Don't continue
D LOOPDUZ^BARMAWO1
;BAR*1.8*1
;I BAREXP=3070430 D
I BAREXP=3070525 D ;BAR*1.8*2
.W !!!,BARCNT," Bills written off to Auto Write-off 2007."
E W !!!,BARCNT," Bills written off to Auto Write-off 2001."
D XIT
Q
; *********************************************************************
;
ASKLOC ;
; Ask list of visit locations
K DIC,X,Y
S BARLOC=1
S DIC="^BAR(90052.05,DUZ(2),"
S DIC(0)="ZAEMQ"
S DIC("A")="Select LOCATION: ALL// "
F D Q:+Y<0
. I $D(BAR("LOC")) S DIC("A")="Select Another LOCATION: "
. D ^DIC
. Q:+Y<0
. S BAR("LOC",+Y)=$P(Y,U,2)
I '$D(BAR("LOC")) D
. I $D(DUOUT) S BARLOC=0 Q
. W "ALL"
K DIC
W !
Q
; *********************************************************************
;
ASKDOS ;
; Ask date of Service
;BAR*1.8*1
;THIS IS A ONE TIME THING FOR THE UFMS WRITE OFF
;if option expire date is april 30,2007 we know its for UFMS
;I BAREXP=3070430 D Q
I BAREXP=3070525 D Q ;BAR*1.8*2
.S BARDOS=3050930
.S BARDOS("E")="9/30/2005"
;END UFMS
S BARDOS2=DT-30000 ; 3 years ago
S Y=BARDOS2
D DD^%DT
S BARDOSE=Y
K DIR
S DIR("A")="Enter Date of Service"
S DIR("?")="Enter a date less than or equal to "_BARDOSE_"."
S DIR("?",1)="Dates up to and including the one entered will be written off."
S DIR(0)="DE^:"_BARDOS2
D ^DIR
Q:'+Y
S BARDOS=Y
S BARDOS("E")=Y(0)
Q
; *********************************************************************
;
ASKACCT ;
; Ask for list of A/R Accounts
K DIC,X,Y
W !
S BARACCT=1
S DIC="^BARAC(DUZ(2),"
S DIC(0)="AEMQ"
S DIC("A")="Select A/R Account: ALL// "
F D Q:+Y<0
. I $D(BAR("ACCT")) S DIC("A")="Select Another A/R Account: "
. D ^DIC
. Q:+Y<0
. S BAR("ACCTTYPE")=$$GET1^DIQ(90050.02,+Y,1.08)
. I BAR("ACCTTYPE")["NON-BENEFICIARY" D Q
. . W !,"Cannot use this option on Non-Beneficiaries",!
. S BAR("ACCT",+Y)=$P(Y,U,2)
I '$D(BAR("ACCT")) D
. I $D(DUOUT) S BARACCT=0 Q
. W "ALL"
K DIC
W !!!
Q
; *********************************************************************
;
CONTINUE ;
; Display choices to user and ask if they wish to continue.
; Tell them bills written off will scroll on the screen if they wish to
; capture.
W "You have chosen to write off bills meeting the above criteria"
W !,"for dates of service up to and including ",BARDOS("E")
W !!,"for the following Locations: "
I '$D(BAR("LOC")) W ?40,"ALL"
I $D(BAR("LOC")) D
. S BARTMP=0
. F S BARTMP=$O(BAR("LOC",BARTMP)) Q:'+BARTMP D
. . W ?40,$P(^DIC(4,BARTMP,0),U),!
W !,"for the following A/R accounts: "
I '$D(BAR("ACCT")) W ?40,"ALL"
I $D(BAR("ACCT")) D
. S BARTMP=0
. F S BARTMP=$O(BAR("ACCT",BARTMP)) Q:'+BARTMP D
. . W ?40,$$VAL^XBDIQ1(90050.02,BARTMP,.01),!
W !!,"The bill number and amount written off will scroll by on the screen"
W !,"if you wish to capture this information.",!
;
K DIR
S DIR(0)="Y"
S DIR("A")="Continue"
S DIR("B")="No"
D ^DIR
K DIR
S:Y=1 BARCONT=1
Q
; *********************************************************************
;
PAZ ;EP to pause report
I '$D(IO("Q")),$E(IOST)="C",'$D(IO("S")) D
.F W ! Q:$Y+3>IOSL
.K DIR S DIR(0)="E" D ^DIR K DIR
Q
; *********************************************************************
;
XIT ;
; Clean up
S DUZ(2)=BARHOLD
D ^BARVKL0 ; Kill local variables
Q
BARMAWO ; IHS/SD/LSL - Automatic Write Off ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,2,28**;OCT 26, 2005;Build 92
+2 ;
+3 ; IHS/ASDS/LSL - 12/11/00 - Routine created
+4 ; This routine is intended to be used to clean up accounts
+5 ; receivable on dates of service prior to 06/30/00. It is intended
+6 ; to be a one time option. It may not be used after 07/01/01.
+7 ;
+8 ; All bills for up to and including the DOS specified for the
+9 ; A/R Accounts specified will be written off to a special code if
+10 ; The amount billed is not greater than 20,000, the date of service
+11 ; is before 06/30/2000, and there is not a credit balance.
+12 ;
+13 ; IHS/ASDS/LSL - 01/22/01
+14 ; Modified to mark bill complete in 3PB and populate payment mult.
+15 ;
+16 ; IHS/ASDS/LSL - 01/23/01
+17 ; Modified to allow write off by visit location
+18 ;
+19 ; IHS/ASDS/LSL - 06/15/01 - V1.5 Patch 1 - NOIS HQW-0601-100051
+20 ; Extend expiration date to 12/31/2001.
+21 ;
+22 ; IHS/ASDS/LSL - 09/07/01 - V1.5 Patch 2
+23 ; Modified to include finance specifications
+24 ; DOS must be at least 3 years old
+25 ; Don't allow write-off of non-bens
+26 ; Option expires by parameter or default to 10/15/01
+27 ; One time only?????
+28 ;
+29 ; *********************************************************************
+30 ;STOP!!! STOP!!!! STOP!!!!
+31 ;IHS/SD/SDR 1.8*28 HEAT293633 - This is an old, outdated routine and shouldn't be used
+32 ; without review and possible changes. Routine EN^BARMAWO6 should be used instead. A
+33 ; quit has been added to this routine so it can't be accidentally run.
+34 ; *********************************************************************
+35 ;
+36 QUIT
+37 ;
EN ;EP - IHS/DIT/CPC 1.8*28 CR 8349 START
+1 WRITE "*********************************************************************",!
+2 WRITE " STOP!!! STOP!!!! STOP!!!!",!
+3 WRITE "This is an old, outdated routine and shouldn't be used. Please ",!
+4 WRITE "request assistance from OIT before starting the write-off process.",!
+5 WRITE "*********************************************************************",!
+6 HANG 10
+7 ;IHS/DIT/CPC 1.8*28 CR 8349 STOP
QUIT
+8 ;
+9 SET BARHOLD=DUZ(2)
+10 SET (BARCONT,BARCNT)=0
+11 ; Serv/Sect from NEW PERSON
SET BARSECT=$$GET1^DIQ(200,DUZ,29,"I")
+12 ;BAR*1.8*1 SPLIT MESSAGE SO ONE IS APPROPRIATE FOR UFMS AND THE OTHER FOR INTERIM
+13 SET BAREXP=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,15)
+14 ;I BAREXP=3070430 D
+15 ;BAR*1.8*2
IF BAREXP=3070525
Begin DoDot:1
+16 WRITE !!,"This menu is meant to be used as a tool for meeting the UFMS"
+17 WRITE !,"clean-up deadline. The user is asked for a list of visit locations (or all),"
+18 WRITE !,"and list of A/R Accounts (or all). The account balance of each bill found"
+19 WRITE !,"with a DOS up to and including 9/30/2005 will be written off to"
+20 WRITE !,"code 916 Auto Write-off 2007 if the following conditions are met:"
End DoDot:1
+21 IF '$TEST
Begin DoDot:1
+22 WRITE !!,"This menu is meant to be used as a tool for meeting the A/R Interim Policy"
+23 WRITE !,"clean-up deadline. The user is asked for a list of visit locations (or all),"
+24 WRITE !,"date of service (DOS) and list of A/R Accounts (or all). The account balance"
+25 WRITE !,"of each bill found with a DOS up to and including the DOS entered will be"
+26 WRITE !,"written off to code 502 Auto Write-off 2001 if the following conditions are met:"
End DoDot:1
+27 ;BAR*1.8*1
+28 ;I BAREXP=3070430 W !!?5,"1. The DOS on the bill is prior to 10/1/2005"
+29 ;BAR*1.8*2
IF BAREXP=3070525
WRITE !!?5,"1. The DOS on the bill is prior to 10/1/2005"
+30 IF '$TEST
WRITE !!?5,"1. The DOS on the bill is at least three (3) years old."
+31 ;W !!?5,"1. The DOS on the bill is at least three (3) years old."
+32 WRITE !?5,"2. The amount billed is less than 20,000.00"
+33 WRITE !?5,"3. The A/R Account tied to the bill is in the list specified"
+34 WRITE !?5," and not NON-BENEFICIARY."
+35 WRITE !?5,"4. There is a positive balance left on the bill"
+36 WRITE !?5,"5. The Visit Location tied to the bill is in the list specified"
+37 SET BAREXP=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,15)
+38 IF BAREXP=""
SET BAREXP=3011015
+39 SET Y=BAREXP
+40 DO DD^%DT
+41 SET BAREXPDT=Y
+42 WRITE !!,"This menu option expires on ",BAREXPDT,"."
+43 ;
+44 IF DT>BAREXP
Begin DoDot:1
+45 WRITE !!!?20,"*** This option expired on ",BAREXPDT," *****"
+46 DO PAZ
+47 DO XIT
End DoDot:1
QUIT
+48 WRITE !!
+49 ; Ask visit location list
DO ASKLOC
+50 IF '+BARLOC
DO XIT
QUIT
+51 ; Ask Date of Service
DO ASKDOS
+52 ; Quit if invalid date entered
IF '$DATA(BARDOS)
QUIT
+53 ; Ask A/R Account List
DO ASKACCT
+54 IF '+BARACCT
DO XIT
QUIT
+55 ; Display choices ask continue
DO CONTINUE
+56 ; Don't continue
IF '+BARCONT
DO XIT
QUIT
+57 DO LOOPDUZ^BARMAWO1
+58 ;BAR*1.8*1
+59 ;I BAREXP=3070430 D
+60 ;BAR*1.8*2
IF BAREXP=3070525
Begin DoDot:1
+61 WRITE !!!,BARCNT," Bills written off to Auto Write-off 2007."
End DoDot:1
+62 IF '$TEST
WRITE !!!,BARCNT," Bills written off to Auto Write-off 2001."
+63 DO XIT
+64 QUIT
+65 ; *********************************************************************
+66 ;
ASKLOC ;
+1 ; Ask list of visit locations
+2 KILL DIC,X,Y
+3 SET BARLOC=1
+4 SET DIC="^BAR(90052.05,DUZ(2),"
+5 SET DIC(0)="ZAEMQ"
+6 SET DIC("A")="Select LOCATION: ALL// "
+7 FOR
Begin DoDot:1
+8 IF $DATA(BAR("LOC"))
SET DIC("A")="Select Another LOCATION: "
+9 DO ^DIC
+10 IF +Y<0
QUIT
+11 SET BAR("LOC",+Y)=$PIECE(Y,U,2)
End DoDot:1
IF +Y<0
QUIT
+12 IF '$DATA(BAR("LOC"))
Begin DoDot:1
+13 IF $DATA(DUOUT)
SET BARLOC=0
QUIT
+14 WRITE "ALL"
End DoDot:1
+15 KILL DIC
+16 WRITE !
+17 QUIT
+18 ; *********************************************************************
+19 ;
ASKDOS ;
+1 ; Ask date of Service
+2 ;BAR*1.8*1
+3 ;THIS IS A ONE TIME THING FOR THE UFMS WRITE OFF
+4 ;if option expire date is april 30,2007 we know its for UFMS
+5 ;I BAREXP=3070430 D Q
+6 ;BAR*1.8*2
IF BAREXP=3070525
Begin DoDot:1
+7 SET BARDOS=3050930
+8 SET BARDOS("E")="9/30/2005"
End DoDot:1
QUIT
+9 ;END UFMS
+10 ; 3 years ago
SET BARDOS2=DT-30000
+11 SET Y=BARDOS2
+12 DO DD^%DT
+13 SET BARDOSE=Y
+14 KILL DIR
+15 SET DIR("A")="Enter Date of Service"
+16 SET DIR("?")="Enter a date less than or equal to "_BARDOSE_"."
+17 SET DIR("?",1)="Dates up to and including the one entered will be written off."
+18 SET DIR(0)="DE^:"_BARDOS2
+19 DO ^DIR
+20 IF '+Y
QUIT
+21 SET BARDOS=Y
+22 SET BARDOS("E")=Y(0)
+23 QUIT
+24 ; *********************************************************************
+25 ;
ASKACCT ;
+1 ; Ask for list of A/R Accounts
+2 KILL DIC,X,Y
+3 WRITE !
+4 SET BARACCT=1
+5 SET DIC="^BARAC(DUZ(2),"
+6 SET DIC(0)="AEMQ"
+7 SET DIC("A")="Select A/R Account: ALL// "
+8 FOR
Begin DoDot:1
+9 IF $DATA(BAR("ACCT"))
SET DIC("A")="Select Another A/R Account: "
+10 DO ^DIC
+11 IF +Y<0
QUIT
+12 SET BAR("ACCTTYPE")=$$GET1^DIQ(90050.02,+Y,1.08)
+13 IF BAR("ACCTTYPE")["NON-BENEFICIARY"
Begin DoDot:2
+14 WRITE !,"Cannot use this option on Non-Beneficiaries",!
End DoDot:2
QUIT
+15 SET BAR("ACCT",+Y)=$PIECE(Y,U,2)
End DoDot:1
IF +Y<0
QUIT
+16 IF '$DATA(BAR("ACCT"))
Begin DoDot:1
+17 IF $DATA(DUOUT)
SET BARACCT=0
QUIT
+18 WRITE "ALL"
End DoDot:1
+19 KILL DIC
+20 WRITE !!!
+21 QUIT
+22 ; *********************************************************************
+23 ;
CONTINUE ;
+1 ; Display choices to user and ask if they wish to continue.
+2 ; Tell them bills written off will scroll on the screen if they wish to
+3 ; capture.
+4 WRITE "You have chosen to write off bills meeting the above criteria"
+5 WRITE !,"for dates of service up to and including ",BARDOS("E")
+6 WRITE !!,"for the following Locations: "
+7 IF '$DATA(BAR("LOC"))
WRITE ?40,"ALL"
+8 IF $DATA(BAR("LOC"))
Begin DoDot:1
+9 SET BARTMP=0
+10 FOR
SET BARTMP=$ORDER(BAR("LOC",BARTMP))
IF '+BARTMP
QUIT
Begin DoDot:2
+11 WRITE ?40,$PIECE(^DIC(4,BARTMP,0),U),!
End DoDot:2
End DoDot:1
+12 WRITE !,"for the following A/R accounts: "
+13 IF '$DATA(BAR("ACCT"))
WRITE ?40,"ALL"
+14 IF $DATA(BAR("ACCT"))
Begin DoDot:1
+15 SET BARTMP=0
+16 FOR
SET BARTMP=$ORDER(BAR("ACCT",BARTMP))
IF '+BARTMP
QUIT
Begin DoDot:2
+17 WRITE ?40,$$VAL^XBDIQ1(90050.02,BARTMP,.01),!
End DoDot:2
End DoDot:1
+18 WRITE !!,"The bill number and amount written off will scroll by on the screen"
+19 WRITE !,"if you wish to capture this information.",!
+20 ;
+21 KILL DIR
+22 SET DIR(0)="Y"
+23 SET DIR("A")="Continue"
+24 SET DIR("B")="No"
+25 DO ^DIR
+26 KILL DIR
+27 IF Y=1
SET BARCONT=1
+28 QUIT
+29 ; *********************************************************************
+30 ;
PAZ ;EP to pause report
+1 IF '$DATA(IO("Q"))
IF $EXTRACT(IOST)="C"
IF '$DATA(IO("S"))
Begin DoDot:1
+2 FOR
WRITE !
IF $Y+3>IOSL
QUIT
+3 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
End DoDot:1
+4 QUIT
+5 ; *********************************************************************
+6 ;
XIT ;
+1 ; Clean up
+2 SET DUZ(2)=BARHOLD
+3 ; Kill local variables
DO ^BARVKL0
+4 QUIT
