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

BARMAWO6.m

Go to the documentation of this file. 
  1. BARMAWO6 ; IHS/SD/LSL - Automatic Write Off for Manilac ;
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**22,24,28**;OCT 26, 2005;Build 92
  1.  ;IHS/ASDS/LSL-12/11/00 - Routine created
  1.  ;     This routine is intended to be used to clean up A/R 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.  ;     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
  1.  ;     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.
  1.  ;
  1.  ;IHS/ASDS/LSL-01/22/01 Modified to mark bill complete in 3PB and populate payment mult.
  1.  ;IHS/ASDS/LSL-01/23/01 Modified to allow write off by visit location
  1.  ;IHS/ASDS/LSL-06/15/01 V1.5 Patch 1 - NOIS HQW-0601-100051 Extend expiration date to 12/31/2001.
  1.  ;IHS/ASDS/LSL-09/07/01 V1.5 Patch 2 Modified to include finance specifications; DOS must be at least 3 years old
  1.  ;   Don't allow write-off of non-bens; Option expires by parameter or default to 10/15/01
  1.  ;   One time only?????
  1.  ;
  1.  ;IHS/SD/PKD-03/28/11 1.8 Manilaq, Alaska write-offs through 1/1/09 has been approved
  1.  ;  Heat 19931.  Modify to allow Date Range to be entered regardless of Parameter file
  1.  ;  From: Glen Fowler [mailto:glen.fowler@maniilaq.org] 
  1.  ;Sent: Thursday, December 16, 2010 1:41 PM
  1.  ;  Subject: RE: A/R request [19931]
  1.  ; Currently, we are working aged Medicare claims, as the 12/31/10 deadline to submit claims (10-1-08 to 12/31/09) will deny on timely filing limits.  
  1.  ; Subsequently, we will be ready to run the AWO the first of the year.  Need new WriteOff code ...
  1.  ;
  1.  ;IHS/SD/POT 1/2/2014 HEAT147266 fixed start / end dates
  1.  ;IHS/SD/SDR 1.8*28 CR8349 HEAT293633 - Fixed date on summary line at end.  BAREXPDT is no longer defined (code was commented out at some point).
  1.  ;   Also fixed end date check to be inclusive of last day.  Cleaned up messages to user to make them clearer.  Added code to ask if they want to adjust
  1.  ;   based on DOS or Approval Date.  Added code for Approval Date.
  1.  ; *****************
  1.  Q
  1.  ;
  1. EN ;EP
  1.  W !!,"This option was updated in bar*1.8*22 to remove the date check."
  1.  W !,"It will now run for ANY date and should be used with EXTREME"
  1.  W !,"caution and only by OIT."
  1.  ;start new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  W !!,"You should use D ^%GO to backup globals ^BARBL, ^BARTR, and"
  1.  W !,"^ABMDBILL prior to running as a precaution."
  1.  W !!,"Users should be off the system when running.  :)"
  1.  W !!
  1.  D PAZ
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!$D(DIRUT)
  1.  ;end new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  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.  ;
  1.  W !," This menu is meant to be used as a Write-off tool. "
  1.  W !!," The user is asked for: "
  1.  W !,"  *A locally added Adjustment Type code for Auto Write-off, IEN or Full Name of"
  1.  W !,"    Write-off Code"
  1.  W !,"  *Inclusion of Non-Beneficiaries or not, "
  1.  W !,"  *A list of visit locations (or all),"
  1.  W !,"  *An inclusive Date Range of Bills to be written off,"
  1.  W !,"  *A list of A/R Accounts (or all). "
  1.  ;start old bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  ;W !!," The account balance of each bill found with a DOS up to and including the "
  1.  ;W !," end date, will be written off to the Adjustment Code entered, if the following"
  1.  ;W !," conditions are met:"
  1.  ;end old start new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  W !!," The account balance of each bill found within the specified date range will "
  1.  W !," be written off to the Adjustment Code entered if the following conditions"
  1.  W !," are met:"
  1.  ;end new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  ;
  1.  ;W !!?5,"1.  The DOS on the bill is within date range entered"  ;BAR*1.8*Manilac ;BAR*1.8*28 CR8349 IHS/SD/SDR HEAT 293633
  1.  W !!?5,"1.  The DOS or Approval ddate on the bill is within date range entered." ;BAR*1.8*28 CR8349 IHS/SD/SDR HEAT 293633
  1.  W !?5,"2.  The A/R Account tied to the bill is in the list specified, "
  1.  W !?5,"3.  The account is NON-BENEFICIARY or BENEFICARY, as selected."
  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.  ;
  1.  S QUIT=0
  1.  W !
  1.  ;IHS/SD/PKD 4/5/11 Manilaq wants to write off Non-Ben as well as BEN
  1.  ;
  1.  S ADJTYP=0 D ADJCAT
  1.  I QUIT D XIT Q
  1.  S (BARQUIT,BENPLUS)=0
  1.  D ASKBEN
  1.  I BARQUIT D XIT Q
  1.  D ASKLOC                                 ;Ask visit location list
  1.  I '+BARLOC D XIT Q
  1.  D ASKDTYP ;ask Date Type ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT 293633
  1.  D ASKDOS                                 ;Ask Date of Service
  1.  Q:'$D(BARDOS)!($G(BARDOS("E"))="")  ;Quit if invalid date entered
  1.  D ASKACCT                                ;Ask A/R Account List
  1.  I '+BARACCT D XIT Q
  1.  D ASKRBACK  ;ask rollback y/n  ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  D ASKSESS  ;ask if ufms session for trans  ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  D CONTINUE^BARMAWO7  ;Display;ask continue
  1.  I '+BARCONT D XIT Q  ;Don't continue
  1.  ;start new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  I +$G(NEWDUZ)'=0 D
  1.  .S BARHDUZ=DUZ
  1.  .S DUZ=NEWDUZ
  1.  ;end new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  ;
  1.  D LOOPDUZ^BARMAWO7  ;1.8*Manilac PKD 3/28/11
  1.  ;BAR*1.8*Manilac
  1.  ;W !!!,$G(BARCNT)," Bills written off to Auto Write-off ",$G(BAREXPDT)  ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  ;start new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  W !!!,$G(BARCNT)," Bills written off to Auto Write-off ",$$SDT^BARDUTL(DT),!!  ;display today for when write-off was done
  1.  I +$G(UFMSESID)'=0 D
  1.  .S ERATSTA=0
  1.  .S CHOICE=1
  1.  .S LIST(1)=DUZ_U_UFMSESID
  1.  .D DISPLAYT^BARUFLOG(DUZ,UFMSESID,"VIEW",ERATSTA)
  1.  .S X=$$SETSESS^BARUFUT(DUZ,UFMSESID,"RC")  ;reconcile session
  1.  .S DUZ=BARHDUZ
  1.  ;end new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  D XIT
  1.  Q
  1.  ;*****************
  1.  ;
  1. ASKLOC ;
  1.  ;Ask list of visit locs
  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.  ;start new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1. ASKDTYP ;EP
  1.  S DIR(0)="S^D:Date of Service;A:Approval Date"
  1.  D ^DIR
  1.  I Y="D" S BAR("DTYP")="E"  ;DOS x-ref
  1.  I Y="A" S BAR("DTYP")="AG"  ;Approval Date x-ref
  1.  Q
  1.  ;end new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  ;
  1. ASKDOS ;
  1. DATE ; don't force dates 3 years into past  
  1.  ;IHS/SD/PKD 3/28/11 1.8*Manilac
  1.  ;Select date range
  1.  S BARDOS=$$DATE^BARDUTL(1)
  1.  I BARDOS<1 Q
  1.  ;P.OTT 1/2/2014 start new code BAR*1.8*24
  1.  S BARDOS1=BARDOS S Y=BARDOS
  1.  D DD^%DT
  1.  S BARDOS1("E")=Y  ;External start Date
  1.  ;end new code BAR*1.8*24
  1.  ;S BARDOS2=$$DATE^BARDUTL(2)  ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  S BARDOS2=$$DATE^BARDUTL(2)_.999999  ;be sure to include last day in write-off with .999999  ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  I BARDOS2<1 W ! G DATE
  1.  I BARDOS2<BARDOS D  G DATE
  1.  .W *7
  1.  .W !!,"The END date must not be before the START date.",!
  1.  ;S Y=BARDOS2 ;BAR*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  S Y=$P(BARDOS2,".") ;don't display .999999 when displaying selected date to user  ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  ;IHS/SD/TPF 7/29/2011 TOOK OUT RESTRICTION PER MALINAC REQUEST.
  1.  ;I Y>3100100 W *7," Date later than 12/31/2009 is not acceptable at this time" G DATE  ;bar*1.8*22 HEAT53513
  1.  D DD^%DT
  1.  S BARDOS("E")=Y  ;External End Date
  1.  S BARDOS2("E")=Y  ;External End Date ;P.OTT 1/2/2014
  1.  Q
  1.  ;*****************
  1.  ;
  1. ASKACCT ; 
  1.  ;Ask for list of A/R Accounts
  1.  K DIC,X,Y
  1.  W !
  1.  I 'BENPLUS W !,"Selecting ALL A/R accounts will Write off Only BENEFICIARY accounts"
  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.  .;IHS/SD/PKD 4/5/11 1.8*MANILAQ 2 chgs:  
  1.  .;1 - see if ok to include NONBEN's  (BENPLUS=1)
  1.  .;2 - change to "NON-BEN" since that's what returned
  1.  .;I BAR("ACCTTYPE")["NON-BENEFICIARY" D  Q
  1. NON .I 'BENPLUS I BAR("ACCTTYPE")["NON-BEN" D  Q  ;BENPLUS=0 if ONLY NON-BEN
  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 !!! ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  Q
  1.  ;*****************
  1.  ;
  1. ASKBEN  ;EP
  1.  ;IHS/SD/PKD 1.8*Manilaq Allow Non-Bens to be written off
  1.  W !,"   ***********   **************   ***************   *************************"
  1.  W !,"Generally, this Write-Off should apply to BENEFICIARY patients ONLY."
  1.  W !,"However, you may specify whether to include Non-Beneficiary patients as well."
  1.  W !,"   ***********   **************   ***************   *************************",!
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Include Non-Beneficiaries?"
  1.  S DIR("B")="No"
  1.  D ^DIR
  1.  K DIR
  1.  S (BARQUIT,BENPLUS)=0
  1.  S:Y=1 BENPLUS=1  ;Include Non-Beneficiaries
  1.  S:Y=U BARQUIT=1
  1.  Q
  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
  1.  ;
  1. ADJTYPE  ;EP  IHS/SD/PKD 1.8*20 from BARTRANS
  1.  ;Select ADJ TYPES 
  1.  K BARY("ADJ TYP")
  1.  K DIC
  1.  S DIC=90052.02
  1.  S DIC(0)="AEQX"
  1.  W !
  1.  S DIC("A")="Please select ADJUSTMENT TYPE: "
  1.  D ^DIC
  1.  I $G(DUOUT)=1 S QUIT=1 W !!,"      QUITTING" Q
  1.  I Y<1 W !,"Required Input" G ADJTYPE
  1.  S BARY("ADJ TYP",+Y)=$P(Y,U,2)
  1.  I '$D(BARY("ADJ TYP")) W !,"Required Input" G ADJTYPE
  1.  I $P(^BARTBL(+Y,0),U,3)'="WO" W !,"Please enter a valid Write-Off code" G ADJTYPE
  1.  S ADJTYPE=+Y
  1.  K DIC
  1.  W !
  1.  Q
  1. ADJCAT ;choices
  1.  K DIC,DIE,DR,DA
  1.  S DIC(0)="AEZ"
  1.  S DIC=90052.01
  1.  ;W !!,"     Select WRITE-OFF (3) or NON-PAYMENT (4), please"  ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  W !!,"     Select WRITE-OFF(3), NON-PAYMENT(4), or PAYMENT CREDIT(20) please"  ;include pymt credit as selectable option  ;bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1.  S DIC("S")="I "",3,4,20,""[("",""_Y_"","")"
  1.  S DIC("W")="N C,DINAME W ""  "" W ""   "",$P(^(0),U,2)"
  1.  D ^DIC
  1.  S BARCAT=""
  1.  I $G(DUOUT)=1 S QUIT=1 W !!,"      QUITTING" Q
  1.  I Y>0 S BARCAT=+Y,BARY("ADJ CAT",BARCAT)=Y(0)
  1.  E  W !!,"Required field, Please select" G ADJCAT
  1. ADJTYP K DIC,DIE,DR,DA
  1.  S DIC(0)="AEQSZ"
  1.  W !!,"     Now select an Adjustment Type Code",!
  1.  S DIC=90052.02  ;^BARTBL - Adj Type Codes for NonPayment or WriteOff
  1.  K ADJTYP S ADJTYP=","
  1.  S TYP=0 F  S TYP=$O(^BARTBL("D",BARCAT,TYP)) Q:'TYP  S ADJTYP=ADJTYP_TYP_","
  1.  N Q S Q=""""
  1.  S DIC("S")="I "_Q_ADJTYP_Q_"[("",""_Y_"","")"
  1.  S DIC("W")="N C,DINAME W ""  "" W ""   "",$P(^(0),U,2)"
  1.  D ^DIC
  1.  I $G(DUOUT)=1 S QUIT=1 W !!,"      QUITTING" Q
  1.  I $P(Y(0),U,2)'=BARCAT W !!,*7,?10,"*** Problem w/ dictionary, this is not an AdjCat ",BARY("ADJ CAT",BARCAT) G ADJTYP
  1.  K ADJTYP
  1.  K DIC
  1.  I +Y>0 S ADJTYPE=+Y
  1.  E  G ADJTYP
  1.  S BARY("ADJ TYP",ADJTYPE)=$P(^BARTBL(ADJTYPE,0),U,1)
  1.  Q
  1.  ;start new bar*1.8*28 CR8349 IHS/SD/SDR HEAT293633
  1. ASKRBACK ;EP
  1.  ;ask user if they wish to rollback bills after posting
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Rollback bills after they have been written off"
  1.  S DIR("B")="No"
  1.  D ^DIR
  1.  K DIR
  1.  S (BARQUIT,BARRBACK)=0
  1.  S:Y=1 BARRBACK=1
  1.  S:Y=U BARQUIT=1
  1.  Q
  1. ASKSESS ;EP
  1.  ;Open new cashiering session to capture trans; then ask user if they want to transmit/ignore them
  1.  K UFMSESID
  1.  S BARUXMIT=0
  1.  S BARUSESS=0
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Open cashiering session to capture transactions"
  1.  S DIR("B")="Yes"
  1.  D ^DIR
  1.  K DIR
  1.  S BARQUIT=0
  1.  S:Y=1 BARUSESS=1
  1.  S:Y=U BARQUIT=1
  1.  Q:BARUSESS'=1
  1.  ;
  1.  S (NEWDUZ,NEWSESS,NEWUSRNM)=""
  1.  S REJECT=0
  1.  K DIC,DIR,DIE,DA,DR
  1.  S DIC("A")="Open new cashiering session for user: "
  1.  S DIC="^BARSESS("_DUZ(2)_","
  1.  S DIC(0)="AEQML"
  1.  D ^DIC
  1.  I Y<0 S ESC=X Q
  1.  S NEWDUZ=+Y
  1.  K DIC,DIE,DR,DA,DIR
  1.  D NOW^%DTC
  1.  S SESSID=%
  1.  S DA(1)=NEWDUZ
  1.  S X=SESSID
  1.  S DIC(0)="L"
  1.  S DIC("P")=$P(^DD(90057,1101,0),U,2)
  1.  S DIC="^BARSESS(DUZ(2),"_DA(1)_",11,"      D ^DIC
  1.  I Y<0 W !!,"SESSION COULD NOT BE CREATED!!" H 2 G ASKSESS
  1.  S NEWSESS=+Y
  1.  S X=$$SETSESS^BARUFUT(NEWDUZ,$P(Y,U,2),"O")  ;SET OPEN STATUS
  1.  I X=0 W !!,"STATUS COULD NOT BE SET!!" H 2 G ASKSESS
  1.  S NEWUSRNM=$P($G(^VA(200,NEWDUZ,0)),U)
  1.  W !!!,"A NEW SESSION HAS BEEN OPENED FOR "_NEWUSRNM_" TO BE USED FOR WRITEOFF TRANSACTIONS"
  1.  W !!,"SESSION: ",NEWSESS,?30,"STATUS: ",$$CURSTAT^BARUFUT(NEWDUZ,NEWSESS,"E")
  1.  W !
  1.  S UFMSESID=NEWSESS
  1.  ;
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Should transactions be sent to UFMS"
  1.  D ^DIR
  1.  K DIR
  1.  S (BARQUIT,BARUXMIT)=0
  1.  S:Y=1 BARUXMIT=1
  1.  S:Y=U BARQUIT=1
  1.  Q
  1.  ;EOR - IHS/DIT/CPC 1.8*28