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

BARMAWO1.m

Go to the documentation of this file.
  1. BARMAWO1 ; IHS/SD/LSL - Automatic Write-off (con't) ;
  1. ;;1.8;IHS ACCOUNTS RECEIVABLE;**1,2,28**;OCT 26, 2005;Build 92
  1. ;
  1. ; IHS/ASDS/LSL - 06/15/2001 - V1.5 Patch 1 - NOIS HQW-0601-100051
  1. ; Modifying BARMAWO to extend the expiration date resulted in
  1. ; the routine being too large. Created this routine to break
  1. ; up BARMAWO.
  1. ;
  1. ; IHS/ASDS/LSL - 09/07/01 - V1.5 Patch 2
  1. ; Modified to accomodate finance changes as documented in BARMAWO
  1. ;
  1. ; IHS/SD/LSL - 07/24/02 - V1.7 - NOIS CMA-0702-110082
  1. ; Resolve <UNDEF>WRITEOFF+17^BARMAWO1
  1. ;
  1. ; IHS/SD/LSL - 11/26/02 - V1.7 - NOIS QAA-1200-130051
  1. ; Quit if error in getting A/R Transaction
  1. ;
  1. ; IHS/SD/LSL - 12/06/02 - V1.7 - NOIS NHA-0601-180049
  1. ; Find 3P bill correctly.
  1. ;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. LOOPDUZ ; EP
  1. ; Loop A/R Bill File by DUZ(2)
  1. S BARDUZ=0
  1. F S BARDUZ=$O(^BARBL(BARDUZ)) Q:'+BARDUZ D LOOPDT
  1. Q
  1. ; *********************************************************************
  1. LOOPDT ;
  1. ; Loop A/R Bill File by date of service
  1. S BARVISIT=0
  1. F S BARVISIT=$O(^BARBL(BARDUZ,"E",BARVISIT)) Q:'+BARVISIT!(BARVISIT>BARDOS) D LOOPBIL
  1. Q
  1. ; *********************************************************************
  1. LOOPBIL ;
  1. ; Loop bills for date of service
  1. S BARBL2=0
  1. F S BARBL2=$O(^BARBL(BARDUZ,"E",BARVISIT,BARBL2)) Q:'+BARBL2 D WRITEOFF
  1. Q
  1. ; *********************************************************************
  1. WRITEOFF ;
  1. ; Write off bills that meet criteria
  1. Q:'$D(^BARBL(BARDUZ,BARBL2)) ; No bill data
  1. S BAR(0)=$G(^BARBL(BARDUZ,BARBL2,0)) ; A/R Bill 0 node
  1. S BAR(1)=$G(^BARBL(BARDUZ,BARBL2,1)) ; A/R Bill 0 node
  1. S BARBAL=$P(BAR(0),U,15) ; Bill Balance
  1. S BARAMT=$P(BAR(0),U,13) ; Billed Amount
  1. S BARVSTL=$P(BAR(1),U,8) ; Visit location
  1. ; Q if A/R account is not on bill
  1. Q:$P(BAR(0),U,3)=""
  1. ; Q if visit location not in list
  1. I $D(BAR("LOC")),'$D(BAR("LOC",BARVSTL)) Q
  1. ; Q if A/R account not in list
  1. I $D(BAR("ACCT")),'$D(BAR("ACCT",$P(BAR(0),U,3))) Q
  1. S BARACT=$P(BAR(0),U,3) ;A/R Account
  1. ;BAR*1.8*2 LOGIC BELOW DOES NOT WORK BECAUSE OF CHANGES MADE TO SET OF CODES
  1. ;BY AUPN DEVELOPER
  1. ;S BARITYP=$$GET1^DIQ(90050.02,BARACT,1.08)
  1. ;I BARITYP["NON-BENEFICIARY" Q ;Don't write off non-bens
  1. S D0=BARACT ;BAR*1.8*2
  1. S BARITYP=$$VALI^BARVPM(8) ;GET INTERNAL CODE INSTEAD OF 'STANDS FOR'
  1. Q:BARITYP="N" ;NON-BEN CODE
  1. ;
  1. I BARBAL'>0 D Q ; Don't want 0 or credit bal
  1. . S ^BARTMP("BARAWO",BARDUZ,DT,DUZ,"CREDIT",BARBL2)=""
  1. I BARAMT>20000 D Q ; May only write-off $20,000
  1. . S ^BARTMP("BARAWO",BARDUZ,DT,DUZ,"TOO HIGH",BARBL2)=""
  1. ;I $P(BAR(1),U,2)>(DT-30000) D Q
  1. ;. S ^BARTMP("BARAWO2",BARDUZ,DT,DUZ,"DATE",BARBL2)=""
  1. ;BAR*1.8*1 UFMS. IF EXP DATE TO USE OPTION IS 4/30/2007 THIS IS A UFMS WRITEOFF
  1. ;AND THERE IS NO DATE LIMIT PAST 3 YEARS ON DOS
  1. ;I BAREXP'=3070430 D Q
  1. I BAREXP'=3070525 D Q
  1. .I $P(BAR(1),U,2)>(DT-30000) D
  1. .. S ^BARTMP("BARAWO2",BARDUZ,DT,DUZ,"DATE",BARBL2)=""
  1. S DUZ(2)=BARDUZ
  1. S BARTRIEN=$$NEW^BARTR ; Create new transaction
  1. I BARTRIEN<1 D MSG^BARTR(BARBL2) Q
  1. S DA=BARTRIEN
  1. S DIE=90050.03
  1. S DR="2////^S X=BARBAL" ; Credit ($$$)
  1. S DR=DR_";4////^S X=BARBL2" ; A/R Bill
  1. S DR=DR_";5////^S X=$P(BAR(1),U)" ; A/R Patient
  1. S DR=DR_";6////^S X=$P(BAR(0),U,3)" ; A/R Account
  1. S DR=DR_";8////^S X=DUZ(2)" ; Parent Location
  1. S DR=DR_";9////^S X=DUZ(2)" ; Parent ASUFAC
  1. S DR=DR_";10////^S X=BARSECT" ; A/R Section
  1. S DR=DR_";11////^S X=$P(BAR(1),U,8)" ; Visit location
  1. S DR=DR_";12////^S X=DT" ; Date
  1. S DR=DR_";13////^S X=DUZ" ; A/R Entry by
  1. S DR=DR_";101////43" ; Transaction type (Adj)
  1. S DR=DR_";102////3" ; Adj Category (Write off)
  1. S DR=DR_";103////916" ; Adj Type (Auto write off)
  1. S DIDEL=90050
  1. D ^DIE ; Populate transaction file
  1. K DIDEL,DIE,DA,DR
  1. D TR^BARTDO(BARTRIEN) ; Post from Trans to files
  1. K BARBL
  1. S BARCNT=BARCNT+1
  1. W !,$P(BAR(0),U),?25," for ",$J($FN(BARBAL,",",2),10)," written off."
  1. D ROLLBILL ; Roll info to 3PB
  1. Q
  1. ; *********************************************************************
  1. ROLLBILL ;
  1. ; For bills written off, update Payment multiple in 3P and mark bill
  1. ; complete in 3PB. Also mark bill as rolled in A/R
  1. S BARBLDA=BARBL2
  1. D SETVAR^BARROLL ; Set A/R vars to roll to 3PB
  1. S ROLL=0 ;BAR*1.8*1 UFMS WRITE-OFF
  1. D ROLL
  1. Q:'ROLL ;BAR*1.8*1 UFMS WRITE-OFF
  1. D SETBLRL^BARROLL ; Mark bill as rolled
  1. Q
  1. ; *********************************************************************
  1. ROLL ;EP
  1. ; Changed code NHA-0601-180049 V1.6 Patch 4
  1. ; Roll A/R vars to 3PB
  1. K DIE,DA,DR
  1. S BAR("3P BILL LOC")=$$FIND3PB^BARUTL(DUZ(2),BARBLDA)
  1. S DUZO2=DUZ(2)
  1. S DUZ(2)=$P(BAR("3P BILL LOC"),",")
  1. S Y=$P(BAR("3P BILL LOC"),",",2)
  1. ;BEGIN ;IF CAN'T FIND 3P BILL INFO SKIP ROLL OVER BAR*1.8*1
  1. I DUZ(2)=""!(Y="") S ROLL=0,DUZ(2)=DUZO2 Q
  1. S ROLL=1
  1. ;END
  1. S Y=Y_"^"_DUZ(2)
  1. S DIC=$$DIC^XBDIQ1(9002274.4)
  1. S BARGBL=DIC_+Y_")"
  1. I $D(@BARGBL) D ROLLTPB ; Roll to 3PB
  1. S DUZ(2)=DUZO2
  1. Q
  1. ; *********************************************************************
  1. ROLLTPB ;
  1. ; File A/R data in payment mult of 3PB
  1. M ABM=BARSUM
  1. S X=Y
  1. ;S Z=BAR3PNM ;IM18173 BAR*1.8*1
  1. S ABMP("BDFN")=+X ; IEN to 3PB BILL
  1. S ABMP("BILL")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"^",1) ; Bill #
  1. ;BEGIN IM18173
  1. ;I '$D(Z) D ; Z UNDEF IFF rtn called by A/R 1.0
  1. ;. S ABMP("AR1.0")=""
  1. ;. S Y=ABM
  1. ;. K ABM
  1. ;. S ABM("AMT")=Y
  1. ;I $G(Z)]"",ABMP("BILL")'=Z D LKUP^ABMAROLL
  1. ;END IM18173
  1. I 'ABMP("BDFN") Q
  1. ; File A/R data in payment multiple of 3P BILL and complete bill
  1. D FILE^ABMAROLL
  1. Q