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

BARCLU0.m

Go to the documentation of this file. 
  1. BARCLU0 ; IHS/SD/LSL - COLLECTION BATCH ENTRY FOR EOBS ; 07/22/2010
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,16,19,28**;OCT 26, 2005;Build 92
  1.  ;;
  1.  ; IHS/ASDS/LSL - 06/18/2001 - V1.5 Patch 1 - NOIS HQW-0201-100027
  1.  ;     FM 22 issue.  Modified to include E in DIC(0)
  1.  ;
  1.  ; IHS/SD/LSL - 02/26/04 - V1.7 Patch 5
  1.  ;     Change CHECK prompt to CHK/EFT #
  1.  ;
  1.  ; IHS/SD/TMM 06/18/2010 1.8*Patch 19 - M819
  1.  ;   M819 - NEWITEM^BARCLU moved to ^BARCLU4 due to SAC size limitation
  1.  ; *********************************************************************
  1.  ;
  1. EDITEM ; EP
  1.  ; edit collection item
  1.  K DIE,BARBL
  1.  S DA=BARITDA
  1.  S DA(1)=BARCLDA
  1.  S DIE=BARDIC_BARCLDA_",1,"
  1.  D:BARX=51 EOB
  1.  D:BARX=52 CASH
  1.  D:BARX=53 CC
  1.  D:BARX=55 REFUND
  1.  D:BARX=81 CHECK
  1.  D:BARX=99 GL
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. CHECK ; EP
  1.  ; for checks
  1.  S DR="11Check/EFT #;"
  1.  ;S:+BARCLID(22,"I") DR=DR_"20R;" ;BAR*1.8*3 UFMS ASK TREASURYDEPOSITNUMBER ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S:+BARCLID(22,"I") DR=DR_"20////"_$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)_";"  ;TDN  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S:+BARCLID(12,"I") DR=DR_"12;" ;bk num
  1.  ; -------------------------------
  1.  ;
  1. CACC ; EP
  1.  D CACC^BARCLU01 ;split for size
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. CC ; EP
  1.  ; credit card
  1.  S DR=""
  1.  D CACC
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. GL ; EP
  1.  ; general ledger entry
  1.  S DR="203;" D CACC
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. REFUND ; EP
  1.  ; refund
  1.  S DR="102;Q;6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;6;5;7;8;Q;"
  1.  S:+BARSPAR(3,"I") DR=DR_"10;"
  1.  S DR=DR_"201//^S X=$G(BARBL(3));301;16//^S X=BARCLID(3)"
  1.  S DIDEL=90050
  1.  D ^DIE
  1.  K DIDEL
  1.  ; -------------------------------
  1.  ;
  1. CASH ; EP
  1.  ; cash col
  1.  S DR=""
  1.  D CACC
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. EOB ; EP
  1.  ; ask PAYOR (A/R Account with DISV(screen)
  1.  I BARITDA'>$G(BARLAST) D  Q
  1.  . W !,"A sequence error has been detected."
  1.  . W !,"Please notate exactly what you were doing"
  1.  . W !,"to provide assistance to the programmers"
  1.  . W !,BARLAST,?10,BARITDA
  1.  . D EOP^BARUTL(0)
  1.  ; -------------------------------
  1.  ;
  1. EOBEDIT ;
  1.  S BARQUIT=0
  1.  K DR
  1.  S BARPAYOR=$G(BARCLIT(7))
  1.  I BARPAYOR=-1 S BARPAYOR=""
  1.  ; -------------------------------
  1.  ;
  1. RESEL ;
  1.  D SPAYOR
  1.  I Y'>0 S BARQUIT=1 Q
  1.  S BARAC=+Y
  1.  S DIE=BARDIC_BARCLDA_",1,"
  1.  S DA=BARITDA
  1.  S DA(1)=BARCLDA
  1.  S DR="7////"_BARAC
  1.  D ^DIE
  1.  I +BARAC'>0 W !,"FILEING ERROR .. SELECT PAYOR ",! G RESEL
  1.  ; -------------------------------
  1.  ;
  1. SAME  ; EP
  1.   ; loop with same payor
  1.   ;
  1. ITEMEOB ;
  1.  K BARQUIT
  1.  S DIE=BARDIC_BARCLDA_",1,"
  1.  S DA=BARITDA
  1.  S DA(1)=BARCLDA
  1.  S DR="7////^S X=BARAC;2////51;17////E"
  1.  S DIDEL=90050
  1.  D ^DIE
  1.  K DIDEL
  1.  ;
  1.  D BARCLIT^BARCLU
  1.  S BARITTYP=BARCLIT(2)
  1.  W $$EN^BARVDF("IOF")
  1.  W !!,"ENTERING ",BARCL(.01)
  1.  W ?30,"TYPE: ",BARCLID(2)
  1.  ;W ?50,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15),!!  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  W ?50,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15)
  1.  I +BARCLID(22,"I") D
  1.  .W !,"TDN/IPAC: ",$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
  1.  .W ?35,"TDN/IPAC AMOUNT: ",$FN($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2)
  1.  .W !,"TDN/IPAC/Deposit Date: ",$$GET1^DIQ(90051.01,BARCLDA_",",30,"E")  ;BAR*1.8*16 IHS/SD/TPF 1/21/2010
  1.  W !!
  1.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  W "ITEM ",BARITDA
  1.  W ?20,BARCLIT(7)
  1.  W !," ^ at Check Number to ask Payor"
  1.  W !," ^ at Payor to exit entry"
  1.  S DR="11Check/EFT #;S:X="""" BARQUIT=1"
  1.  ;S:+BARCLID(22,"I") DR=DR_";20R;" ;BAR*1.8*3 UFMS ASK TREASURY DEPOSIT NUMBER  ;IHS/SD/SDR/ bar*1.8*4 DD item 4.1.5.1
  1.  ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S BARTDN=$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)
  1.  S:+BARCLID(22,"I") DR=DR_";20////^S X=BARTDN"
  1.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S DIDEL=90050
  1.  S D0=$G(BARCLDA),D1=$G(BARITDA)  ;;PARAMS FOR COLL BATCH ITEMS FIELD 20 OUTPUT TRANSFORM - IHS/DIT/CPC - BAR*1.8*28 CR5994
  1.  D ^DIE
  1.  K DIDEL
  1.  I +BARCLID(22,"I") W !,"TREASURY DEPOSIT/IPAC: "_BARTDN  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  ;
  1.  I $D(Y) S BARQUIT=1
  1.  I $G(BARQUIT) G EOBEDIT ; return to payor question
  1.  ;BEGIN BAR*1.8*16 IHS/SD/TPF 1/21/2010
  1.  N LIST,DOCARE
  1.  D CHECKDUP($$GET1^DIQ(90051.1101,BARITDA_","_BARCLDA_",",11),.LIST)
  1.  I $D(LIST) D  G:DOCARE ITEMEOB
  1.  .K DIR
  1.  .S DIR(0)="Y"
  1.  .S DIR("B")="No"
  1.  .W !!,"Duplicates have been found."
  1.  .S DIR("A")="Are you sure you wish to use this check number?"
  1.  .D ^DIR
  1.  .S DOCARE='Y
  1.  K LIST,DOCARE
  1.  W !!
  1.  ;END
  1.  S DR="103///@;"
  1.  S:BARCLID(12,"I") DR=DR_"12;" ;bnk num
  1.  ;start old code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  ;S DR=DR_"101;" ;amt
  1.  ;S:BARCLID(13,"I") DR=DR_"10;" ;in/out pat
  1.  ;end old code start new code 4.1.5.1
  1.  S DIDEL=90050
  1.  D ^DIE
  1.  K DIDEL
  1. AMT S DR="101" ;amt
  1.  S:($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)["NONPAY") DR=DR_"////0"  ;IHS/SD/SDR bar*1.8*4 SCR 88
  1.  D ^DIE
  1.  K DR
  1.  I +BARCLID(22,"I"),($P($G(^BARCOL(DUZ(2),BARCLDA,1,BARITDA,1)),U))>($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29)) D  G AMT
  1.  .W !!,"AMOUNT OF CREDIT IS GREATER THAN TDN/IPAC OF ",$FN($P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,29),",",2),".  PLEASE CORRECT"
  1.  S:BARCLID(13,"I") DR="10;" ;in/out pat
  1.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  ;S:'BARSPAR(2,"I") DR=DR_"8///^S X=BARSPAR(.01)"  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S:'BARSPAR(2,"I") DR=$S($G(DR)'="":DR_"8///^S X=BARSPAR(.01)",1:"8///^S X=BARSPAR(.01)")  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S DIDEL=90050
  1.  ;D ^DIE  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  I $G(DR) D ^DIE  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  K DIDEL
  1.  ;
  1.  I BARSPAR(2,"I") D EOBSUB I 1 ;multiple 3P facilities
  1.  E  D INSSUB
  1.  D BARCLIT^BARCLU
  1.  D DISPLAY^BARCLU1
  1.  K BARQUIT
  1.  ; -------------------------------
  1.  ;
  1. ASK ;
  1.  K DIR
  1.  S DIR(0)="S^E:EDIT;D:DELETE;C:CONTINUE"
  1.  S DIR("B")="CONTINUE"
  1.  D ^DIR
  1.  G:Y="E" EOBEDIT
  1.  I Y="D" D
  1.  . K DA
  1.  . S DIK=$$DIC^XBDIQ1(90051.1101)
  1.  . S DA=BARITDA
  1.  . S DA(1)=BARCLDA
  1.  . D ^DIK
  1.  . S BARCL(7)=BARCL(7)-1
  1.  ; -------------------------------
  1.  ;
  1. EITEMEOB ;
  1.  ;
  1. FILE ;
  1.  ; file entry and check counter
  1.  K DIE,DR,DA
  1.  S DIE=$$DIC^XBDIQ1(90051.01)
  1.  S DR="7///"_BARCL(7)
  1.  S DA=BARCLDA
  1.  S BARLAST=BARCL(7)
  1.  S DIDEL=90050
  1.  D ^DIE
  1.  K DIDEL
  1.  ;D NEWITEM^BARCLU  ;M819*DEL*TMM*20100722--moved to ^BARCLU4 due to rtn size
  1.  D NEWITEM^BARCLU4 ;get new item to enter
  1.  G SAME
  1.  ; *********************************************************************
  1.  ;
  1. EOBSUB ;EP
  1.  ; enter data for sub EOB locations and amounts"
  1.  ;
  1. LOOP ;EP
  1.  ; loop subs for entries and amounts
  1.  K DIC,DR,DA,DIE
  1.  S DA(2)=BARCLDA
  1.  S DA(1)=BARITDA
  1.  S DIC="^BARCOL(DUZ(2),"_BARCLDA_",1,"_BARITDA_",6,"
  1.  S DIC(0)="EAQMLZ"
  1.  S DIC("P")=$P(^DD(90051.1101,601,0),U,2)
  1.  F  D BARCLIT^BARCLU,DSPSUB S DIC("A")="Cr="_BARCLIT(101)_" Bal=$"_BARCLIT(202.5)_"  Select Location ?",DIC(0)="AEQMLZ" D ^DIC Q:+Y'>0  D  Q:+BARCLIT(202.5)=0
  1.  .S DIE=DIC
  1.  .S DA=+Y
  1.  .S DR="2///^S X=BARCLIT(202.5)+$$VAL^XBDIQ1(DIE,.DA,2);2;S BARAMT=X"
  1.  .S DIDEL=90050
  1.  .D ^DIE
  1.  .K DIDEL,DIC("P")
  1.  .D BARCLIT^BARCLU
  1.  .I BARCLIT(202.5)<0 D
  1.  .. W *7,?40,"BALANCE : ",BARCLIT(202.5)
  1.  .. D KILLSUB
  1.  .. W !,"NEGATIVE BALANCE .. ENTRY REMOVED",!
  1.  D BARCLIT^BARCLU
  1.  I +BARCLIT(202.5)'=0 D  G LOOP
  1.  .W !!,"BALANCE OFF BY ",BARCLIT(202.5)
  1.  .W !!?10,"CREDITS CAN NO LONGER BE PLACED INTO THE UNDISTRIBUTED FUND ACCOUNT"
  1.  .W !?10,"PLEASE PLACE THE BALANCE INTO THE APPROPRIATE LOCATION(S)"
  1.  .H 2
  1.  ; -------------------------------
  1.  ;
  1. ENDEOB ;
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. SPAYOR ; EP
  1.  ; from BARCLU3
  1.  D ^XBNEW("SELPAYOR^BARCLU0:Y;BARPAYOR") ;get a payor
  1.  ; returns Y from a dic call
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. SELPAYOR ; EP
  1.  ; select A/R Account for Insurer only
  1.  K DIC
  1.  S DIC="^BARAC(DUZ(2),"
  1.  S DIC(0)="AEZQM"
  1.  S DIC("A")="PAYOR: "
  1.  S DIC("S")="I $P(^(0),U)[""AUTNINS"",$P(^(0),U,10)=$$VALI^XBDIQ1(200,DUZ,29)"
  1.  S DIC("B")=$G(BARPAYOR)
  1.  D ^DIC
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. INSSUB ; EP
  1.  ; insert single sub node
  1.  D DELSUBS ;delete existing subs
  1.  K DIC,DR,DA,DIE
  1.  S DA(2)=BARCLDA
  1.  S DA(1)=BARITDA
  1.  S DIC=$$DIC^XBDIQ1(90051.1101601)
  1.  S DIC(0)="=EL"
  1.  S DIC("P")=$P(^DD(90051.1101,601,0),U,2)
  1.  S BART=$E(DIC,1,$L(DIC)-1)_")" K @BART
  1.  N BART
  1.  D ENP^XBDIQ1(90051.1101,"BARCLDA,BARITDA","8;101","BART(")
  1.  S X=BART(8)
  1.  S DIC("DR")="2///^S X=BART(101)"
  1.  D ^DIC
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. KILLSUB ; EP
  1.  ; kill eob sub when the entry is 0
  1.  D ^XBNEW("KSUB^BARCLU0:DA*;DIE")
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. KSUB ; EP
  1.  ; kill eob sub
  1.  S DIK=DIE
  1.  D ^DIK
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. DSPSUB ;
  1.  D DSPSUB^BARCLU1
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. END ;
  1. DELSUBS ; EP
  1.  ; REMOVE EOBSUBS
  1.  N BART,DIE
  1.  S DIE=$$DIC^XBDIQ1(90051.1101601)
  1.  D ENPM^XBDIQ1(90051.1101601,"BARCLDA,BARITDA,0",".01","BART(")
  1.  S BART=0
  1.  F  S BART=$O(BART(BART)) Q:'BART  D
  1.  . S DA=BART
  1.  . D PARSE^XBDIQ1("BARCLDA,BARITDA,DA")
  1.  . D KILLSUB
  1.  Q
  1.  ;BAR*1.8*16 IHS/SD/TPF 1/21/2010
  1. CHECKDUP(CHK,LIST) ;EP - CHECK FOR DUPLICATE CHEACKS IN A/R COLLECTION BATCH
  1.  Q:CHK=""
  1.  N CHECNUM,CHECK,COLBAT,ITEM,AMOUNT,COLNAM
  1.  K LIST
  1.  S CNT=0
  1.  S COLBAT=""
  1.  F  S COLBAT=$O(^BARCOL(DUZ(2),"D",CHK,COLBAT)) Q:COLBAT=""  D
  1.  .Q:BARCLDA=COLBAT
  1.  .S ITEM=""
  1.  .F  S ITEM=$O(^BARCOL(DUZ(2),"D",CHK,COLBAT,ITEM)) Q:'ITEM  D
  1.  ..S CNT=CNT+1
  1.  ..S COLNAM=$$GET1^DIQ(90051.01,COLBAT_",",.01,"E")
  1.  ..S ACCOUNT=$$GET1^DIQ(90051.1101,ITEM_","_COLBAT_",",7,"E")
  1.  ..S AMOUNT=$$GET1^DIQ(90051.1101,ITEM_","_COLBAT_",",101,"E")
  1.  ..S LIST(CNT)=COLNAM_U_ITEM_U_ACCOUNT_U_AMOUNT
  1.  Q:'$D(LIST)
  1.  D DUPHDR(CNT)
  1.  D SHOLIST(.LIST)
  1.  Q
  1.  ;
  1. DUPHDR(CNT) ;EP - CHKDUP HEADER
  1.  W !!,"Potential duplicate"_$S(CNT>1:"s",1:"")_" found in the following batch"_$S(CNT>1:"es",1:"")_":"
  1.  Q
  1.  ;
  1. SHOLIST(LIST) ;EP - SHOW LIST OF DUPES
  1.  N CNT
  1.  S CNT=""
  1.  W !
  1.  F  S CNT=$O(LIST(CNT)) Q:'CNT  D
  1.  .W !,CNT,"."
  1.  .W ?3,$P(LIST(CNT),U)
  1.  .W ?34,$P(LIST(CNT),U,2)
  1.  .W ?37,$P(LIST(CNT),U,3)
  1.  .W ?65,$J($FN($P(LIST(CNT),U,4),",",2),15)
  1.  W !!
  1.  ;K DIR
  1.  ;S DIR(0)="E"
  1.  ;D ^DIR
  1.  Q