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