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

BARCLU1.m

Go to the documentation of this file. 
  1. BARCLU1 ; IHS/SD/LSL - UTILITY CALLS FROM BARCLU ; 07/09/2010
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,19,23**;OCT 26, 2005
  1.  ;;
  1.  ; IHS/SD/TMM 06/18/2010 1.8*19 Add Prepayment functionality.
  1.  ;      See work order 3PMS10001
  1.  ;      ------------------------
  1.  ;      819_1. Display prepayments not assigned to a batch (^BARCLU)
  1.  ;      819_2. Remove prompt: AUTO PRINT RECEIPT (^BARCLU01)
  1.  ;      819_3. Prepayment entry ^BARPPY01 (new routine),^BARCLU1,^BARPUTL
  1.  ;      819_4. Display prepayments matching payment type selected (^BARCLU)
  1.  ;      819_5. Allow user to assign prepayment to batch (^BARCLU,^BARCLU01,^BARPUTL,^BARPST1,^BARBLLK)
  1.  ;      819_6. Print Prepayment Receipt (^BARPPY02) (new routine)
  1.  ; *********************************************************************
  1.  ; OCT 2012 HEAT #88320 P.OTT SET DEFAULT FACILITY TO BARLCIT(8) WHEN NIL
  1. NEW ; EP
  1.  ; open a new batch
  1.  K DA
  1.  ;----  update Date / Sequence in BARCLID
  1.  I DT=BARCLID(4,"I") S BARCLID(5)=BARCLID(5)+1
  1.  E  S BARCLID(4,"I")=DT,BARCLID(5)=1
  1.  K DIE,DR,DA
  1.  S DIE=$$DIC^XBDIQ1(90051.02)
  1.  S DA=+BARCLID("ID")
  1.  S DR="4////"_BARCLID(4,"I")_";5///"_BARCLID(5)
  1.  S DIDEL=90050
  1.  D ^DIE
  1.  K DIDEL
  1.  D BARCLID
  1.  ;
  1.  ;---- setup new collection batch
  1.  S X=BARCLID(.01)_"-"_BARCLID(4.5)_"-"_BARCLID(5)
  1.  S BARCLID(6)=X ;set new current into BARCLID
  1.  K DIC,DR,DA
  1.  S DIC="^BARCOL(DUZ(2),"
  1.  S DIC(0)="XEQML"
  1.  S DIC("DR")="2////^S X=+BARCLID(""ID"")"
  1.  S DIC("DR")=DIC("DR")_";3////O"
  1.  S DIC("DR")=DIC("DR")_";4///NOW"
  1.  S DIC("DR")=DIC("DR")_";5////^S X=DUZ"
  1.  S DIC("DR")=DIC("DR")_";7///0"
  1.  S DIC("DR")=DIC("DR")_";8////^S X=DUZ(2)"
  1.  S DIC("DR")=DIC("DR")_";10////^S X=BARCLID(10,""I"")"
  1.  S DLAYGO=90050
  1.  K DD,DO
  1.  D FILE^DICN
  1.  K DLAYGO ;setup new batch
  1.  I Y'>0 W !,"error in setting up new collection batch" H 5 Q
  1.  S BARCLDA=+Y
  1.  S BARDA=+Y D
  1.  . D BARCL
  1.  . K BARDA
  1.  K DR,DA,DIE
  1.  S DIE=$$DIC^XBDIQ1(90051.02)
  1.  S DA=+BARCLID("ID")
  1.  S DR="6///"_BARCLID(6)
  1.  S DIDEL=90050
  1.  D ^DIE
  1.  K DIDEL
  1.  D BARCLID
  1.  ;
  1. ENEW ;
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. BARCLID ; EP
  1.  ; build BARCLID array:uses current da in array or BARDA if no array
  1.  N XB,DIC,DR,DA,DIQ
  1.  I $D(BARCLID) S DA=+BARCLID("ID")
  1.  I $D(BARDA) S DA=BARDA K BARDA
  1.  I '$G(DA) W !!,"NO DA FOR BARCLID",*7,!! H 5 Q
  1.  K BARCLID
  1.  S DR=".001:99"
  1.  S DIQ="BARCLID("
  1.  S DIQ(0)="I"
  1.  S DIC=90051.02
  1.  D EN^XBDIQ1
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. BARCL ; EP
  1.  ; build BARCL array:uses current da in array of DA if no array
  1.  N XB,DIC,DR,DA,DIQ
  1.  S:$D(BARCL) DA=+BARCL("ID")
  1.  I $D(BARDA) S DA=BARDA K BARDA
  1.  I '$G(DA) W !!,"NO DA FOR BARCL",*7,!! H 5 Q
  1.  K BARCL
  1.  S DR=".001:99"
  1.  S DIQ="BARCL("
  1.  S DIQ(0)="I"
  1.  S DIC=90051.01
  1.  D EN^XBDIQ1
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. BARCLIT ; EP
  1.  ; build the BARCLIT array
  1.  ;needs +BARCL("ID") for DA and BARITDA for item
  1.  N DIC,DA,DR,DIQ,XB
  1.  K BARCLIT
  1.  K DIQ
  1.  S DA=BARITDA
  1.  S DIQ="BARCLIT("
  1.  S DIQ(0)="I"
  1.  S DIC=90051.1101
  1.  S DA(1)=BARCLDA
  1.  S DR="^.01:203;301;401:405;501"
  1.  ;S DR="^.01:203;301;401:405;501;20"  ;BAR*1.8*3 UFMS MAKE TREASURY NUMBER REQUIRED  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  ;S DR=".01:203;301;401:405;501;20"  ;BAR*1.8*4 SCHEDULE NUMBERING NOT DISPLAYING ON USE OF 'Edit w Audit' option IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  S DR=".01:203;301;401:405;501;20////"_$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)_";W !,TDN/IPAC: "_$P($G(^BARCOL(DUZ(2),BARCLDA,0)),U,28)  ;IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  D EN^XBDIQ1
  1.  ;BAR*1.8*4 ASK TREASURY NUMBER
  1.  I BARCLIT("20")="" D
  1.  .S BARCLIT("20")=$P($G(^BARCOL(DUZ(2),BARCLDA,1,BARITDA,0)),U,20)
  1.  .S BARCLIT("20","I")=$P($G(^BARCOL(DUZ(2),BARCLDA,1,BARITDA,0)),U,20)
  1.  ;END
  1.  I BARCLIT(8)="" S BARCLIT(8)=$G(BARSPAR(8)) ;P.OTT
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. DISPLAY ; EP
  1.  ; display item elements
  1.  W $$EN^BARVDF("IOF")
  1.  W !,BARCL(.01)
  1.  W ?22,"ITEM: ",BARITDA,"    TYPE: ",BARCLIT(2)
  1.  W ?48,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15)
  1.  ;start new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  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.  ;end new code IHS/SD/SDR bar*1.8*4 DD item 4.1.5.1
  1.  W !
  1.  F BARI=1:1:IOM-4 W "="
  1.  F BARLAB="FLD1","FLD2" D
  1.  . S BARY=$P($T(@BARLAB),";;",2)
  1.  . F BARI=1:1 S BARE=$P(BARY,U,BARI) Q:BARE=""  D
  1.  . . S BARFLD=+BARE
  1.  . . S BARNM=$P(BARE,";",2)
  1.  . . I $G(BARCLIT(BARFLD))]"" W !,?5,BARNM,?30,BARCLIT(BARFLD)
  1.  I $D(BARCLIT(301)) D
  1.  . W !,"COMMENTS"
  1.  . F BARI=1:1 Q:'$D(BARCLIT(301,BARI))  W !?3,BARCLIT(301,BARI)
  1.  I $D(BARCLIT(501)) D
  1.  . W !,"ERROR COMMENTS"
  1.  . F BARI=1:1 Q:'$D(BARCLIT(501,BARI))  W !,?3,BARCLIT(501,BARI)
  1.  ;
  1. EDSP ;
  1.  W !
  1.  F BARI=1:1:IOM-4 W "="
  1.  D DSPSUB
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. DSPSUB ; EP
  1.  ; Display subs
  1.  W !
  1.  N DR,BARY,BARI,BARNM,BARFLD,BARESUB
  1.  S DIQ="BARESUB("
  1.  S DIQ(0)=1
  1.  S DIC=90051.1101601
  1.  S DA(1)=BARITDA
  1.  S DR=".01;.5;2"
  1.  S DA(2)=BARCLDA
  1.  S DA=0
  1.  D ENM^XBDIQ1
  1.  S BARS=0
  1.  F BARI=1:1 S BARS=$O(BARESUB(BARS)) Q:BARS'>0  D
  1.  . W BARESUB(BARS,.5)
  1.  . W ?5,BARESUB(BARS,.01)
  1.  . W ?30,"$",$J(BARESUB(BARS,2),8,2),!
  1.  W !
  1.  ;
  1. EDSPSUB ;
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1.  ; $T LINES ;IHS/SD/AML 11/26/07 - Print treasury dep number
  1. FLD1 ;;203;GENERAL LEDGER^11;CHECK NUMBER^12;CHECK BANK NUMBER^13;CC NUMBER^14;CC VER NUMBER^101;AMOUNT PAID^102;REFUND^
  1. FLD2 ;;7;A/R ACCOUNT^201;PAYOR^8;LOCATION OF SERVICE^10;INPAT/OUTPAT^5;PATIENT^6;BILL^16;AUTO PRINT^20;TREASURY DEPOSIT/IPAC # 
  1.  ;----------------------------
  1. EDISPLAY ;
  1.  Q
  1.  ;
  1.  ;---BEGIN ADD(1)---> NEW TAG 'BARPPAY'   ;M819*ADD*TMM*20100709 (M819_3)
  1. BARPPAY(BARPPIEN) ; EP
  1.  ; build BARPPAY array:uses current da in existing array or BARPPIEN if no array
  1.  N XB,DIC,DR,DA,DIQ
  1.  ;I $D(BARPPAY) S DA=+BARPPAY("ID")        ;M819*DEL*TMM*20100709
  1.  ;I $D(BARPPIEN) S DA=BARPPIEN K BARPPIEN  ;M819*DEL*TMM*20100709
  1.  I $D(BARPPIEN) S DA=BARPPIEN              ;M819*ADD*TMM*20100709
  1.  I '$G(DA) W !!,"NO DA FOR BARPPAY",*7,!! H 5 Q
  1.  K BARPPAY
  1.  S DR=".01:201"
  1.  S DIQ="BARPPAY("
  1.  S DIQ(0)="I"
  1.  S DIC=90050.06
  1.  D EN^XBDIQ1
  1.  Q
  1.  ;-----END ADD(1)---> NEW TAG 'BARPPAY'   ;M819*ADD*TMM*20100709