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