Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BARMAWO

BARMAWO.m

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