BARUTL0 ; IHS/SD/LSL - Utility programs for user/fac ;
;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
;;
; IHS/SD/LSL - 09/24/02 - V1.7 - NOIS HQW-0902-100094
; Set BARUSR(29 [service section] to be BUSINESS OFFICE
; if it is something othe than BUSINESS OFFICE or
; FISCAL SERVICE"
;
; ********************************************************************
;
BARUSR ;EP setup BARUSR( user array from DUZ:200
N XB,DIQ,DIC,DA
K BARUSR
S DIQ="BARUSR("
S DIQ(0)="I"
S DIC=200
S DR=".01;29"
S DA=DUZ
D EN^XBDIQ1
Q:BARUSR(29)="BUSINESS OFFICE"
Q:BARUSR(29)="FISCAL SERVICE"
S DIC="^DIC(49," ; Service/Section file
S DIC(0)="ZEX"
S X="BUSINESS OFFICE"
K DD,DO
D ^DIC
Q:Y'>0
S BARUSR(29)=$P(Y,U,2)
S BARUSR(29,"I")=+Y
Q
; *********************************************************************
;
BARSPAR ;EP setup BARSPAR( A/R Site Parameter array
N XB,DIC,DIQ,DA,DR
K BARSPAR
S DIC=90052.06
S DR=".01:99"
S DA=DUZ(2)
S DIQ="BARSPAR("
S DIQ(0)="I"
D EN^XBDIQ1
Q
; *********************************************************************
;
BARSITE ;EP setup BARSITE( site array
N XB,DIC,DA,DR
S DIC="^AUTTSITE("
S DIQ="BARSITE("
S DIQ(0)="I"
S DA=1
S DR=".01"
D EN^XBDIQ1
Q
; *********************************************************************
;
BARPSAT ;EP built BARPS arrary with Parent Satellite
N DA,DIC,DR,BARGL,Y
K BARPSAT
S DIC=90052.05
S DIQ="BARPSAT("
S DIQ(0)="I"
S DR=".01;2"
S DIQ(0)="1E"
S DA=0
D ENM^XBDIQ1
Q
; *********************************************************************
;
ADDREGON ;EP add a regional site (needs DUZ(2))
K DIQ
S DIC=4
S DIQ="BARTMP("
S DR=".01"
S DA=DUZ(2)
D EN^XBDIQ1
I $D(^BARBL(DUZ(2))) D
. W !,?5,BARTMP(.01)," EXISTS"
. D EOP^BARUTL(0)
K DIR
S DIR(0)="Y"
S DIR("B")="NO"
S DIR("A")=BARTMP(.01)_" to be added/updated as an A/R Regional Site?"
D ^DIR
I 'Y D Q
. W !,"You can change your Default A/R Facility and return here if necessary!",!
. K DIR,BARTMP
. D EOP^BARUTL(1)
; -------------------------------
;
; set files 0 nodes
F BARI=1:1 S BARFLNUM=$P($T(FNUM+BARI),";;",2) Q:'BARFLNUM D
. S BARGL=^DIC(BARFLNUM,0,"GL")_"0)"
. I '$D(@BARGL) D
. . S $P(@BARGL,"^",1,2)=$P(^DIC(BARFLNUM,0),"^",1,2)
. . W !,"ADDED: ",?10,$P(@BARGL,U)
W !!,BARTMP(.01)," Has been added",!
;--------------------------------
;
ARSPAC ;set up two special A/R accounts
K DIC
S DIC=$$DIC^XBDIQ1(90052.07)
S DIC(0)="L"
I '$D(@(DIC_"""B"",""UN-ALLOCATED"")")) D
. S X="UN-ALLOCATED"
. K DD,DO
. D ^DIC
. I Y'>0 D
. . S BARQUIT=1
. . W !,"ERROR IN SETUP OF UN-ALLOCATED"
;--------------------------------
;
HOSPSRVC ;
S DIC=49 ;hospital service
S DIC(0)="L"
S DLAYGO=49
I '$D(^DIC(49,"B","BUSINESS OFFICE")) D
. S X="BUSINESS OFFICE"
. K DD,DO
. D ^DIC
. I Y'>0 D
. . S BARQUIT=1
. . W !,"ERROR IN SETUP OF BUSINESS OFFICE",!
I '$D(^DIC(49,"B","FISCAL SERVICE")) D
. S X="FISCAL SERVICE"
. K DD,DO
. D ^DIC
. I Y'>0 D
. . S BARQUIT=1
. . W !,"ERROR IN SETUP OF FISCAL SERVICE",!
I $G(BARQUIT) D EOP^BARUTL(0)
;
EADD ;
Q
FNUM ;;$T filenumber to be regionally added/deleted
;;90051.01
;;90051.02
;;90050.02
;;90050.01
;;90052.05
;;90052.06
;;90052.07
;;90050.03
;;end of list
EFNUM ;----------
;
SRVSEC ;EP switch Service Section
K DIC,DR,DIE,DA
S DIC="^BARTBL("
S DIC(0)="AEQM"
S DIC("S")="I $P(^(0),U,3)=""SRVSEC"""
K DD,DO
D ^DIC
Q:Y'>0
S Y=+Y
S DIE="^VA(200,"
S DA=DUZ
S DR="29///"_$$VAL^XBDIQ1("^BARTBL(",+Y,.01)
S DIDEL=90050
D ^DIE
K DIDEL
Q
BARUTL0 ; IHS/SD/LSL - Utility programs for user/fac ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
+2 ;;
+3 ; IHS/SD/LSL - 09/24/02 - V1.7 - NOIS HQW-0902-100094
+4 ; Set BARUSR(29 [service section] to be BUSINESS OFFICE
+5 ; if it is something othe than BUSINESS OFFICE or
+6 ; FISCAL SERVICE"
+7 ;
+8 ; ********************************************************************
+9 ;
BARUSR ;EP setup BARUSR( user array from DUZ:200
+1 NEW XB,DIQ,DIC,DA
+2 KILL BARUSR
+3 SET DIQ="BARUSR("
+4 SET DIQ(0)="I"
+5 SET DIC=200
+6 SET DR=".01;29"
+7 SET DA=DUZ
+8 DO EN^XBDIQ1
+9 IF BARUSR(29)="BUSINESS OFFICE"
QUIT
+10 IF BARUSR(29)="FISCAL SERVICE"
QUIT
+11 ; Service/Section file
SET DIC="^DIC(49,"
+12 SET DIC(0)="ZEX"
+13 SET X="BUSINESS OFFICE"
+14 KILL DD,DO
+15 DO ^DIC
+16 IF Y'>0
QUIT
+17 SET BARUSR(29)=$PIECE(Y,U,2)
+18 SET BARUSR(29,"I")=+Y
+19 QUIT
+20 ; *********************************************************************
+21 ;
BARSPAR ;EP setup BARSPAR( A/R Site Parameter array
+1 NEW XB,DIC,DIQ,DA,DR
+2 KILL BARSPAR
+3 SET DIC=90052.06
+4 SET DR=".01:99"
+5 SET DA=DUZ(2)
+6 SET DIQ="BARSPAR("
+7 SET DIQ(0)="I"
+8 DO EN^XBDIQ1
+9 QUIT
+10 ; *********************************************************************
+11 ;
BARSITE ;EP setup BARSITE( site array
+1 NEW XB,DIC,DA,DR
+2 SET DIC="^AUTTSITE("
+3 SET DIQ="BARSITE("
+4 SET DIQ(0)="I"
+5 SET DA=1
+6 SET DR=".01"
+7 DO EN^XBDIQ1
+8 QUIT
+9 ; *********************************************************************
+10 ;
BARPSAT ;EP built BARPS arrary with Parent Satellite
+1 NEW DA,DIC,DR,BARGL,Y
+2 KILL BARPSAT
+3 SET DIC=90052.05
+4 SET DIQ="BARPSAT("
+5 SET DIQ(0)="I"
+6 SET DR=".01;2"
+7 SET DIQ(0)="1E"
+8 SET DA=0
+9 DO ENM^XBDIQ1
+10 QUIT
+11 ; *********************************************************************
+12 ;
ADDREGON ;EP add a regional site (needs DUZ(2))
+1 KILL DIQ
+2 SET DIC=4
+3 SET DIQ="BARTMP("
+4 SET DR=".01"
+5 SET DA=DUZ(2)
+6 DO EN^XBDIQ1
+7 IF $DATA(^BARBL(DUZ(2)))
Begin DoDot:1
+8 WRITE !,?5,BARTMP(.01)," EXISTS"
+9 DO EOP^BARUTL(0)
End DoDot:1
+10 KILL DIR
+11 SET DIR(0)="Y"
+12 SET DIR("B")="NO"
+13 SET DIR("A")=BARTMP(.01)_" to be added/updated as an A/R Regional Site?"
+14 DO ^DIR
+15 IF 'Y
Begin DoDot:1
+16 WRITE !,"You can change your Default A/R Facility and return here if necessary!",!
+17 KILL DIR,BARTMP
+18 DO EOP^BARUTL(1)
End DoDot:1
QUIT
+19 ; -------------------------------
+20 ;
+21 ; set files 0 nodes
+22 FOR BARI=1:1
SET BARFLNUM=$PIECE($TEXT(FNUM+BARI),";;",2)
IF 'BARFLNUM
QUIT
Begin DoDot:1
+23 SET BARGL=^DIC(BARFLNUM,0,"GL")_"0)"
+24 IF '$DATA(@BARGL)
Begin DoDot:2
+25 SET $PIECE(@BARGL,"^",1,2)=$PIECE(^DIC(BARFLNUM,0),"^",1,2)
+26 WRITE !,"ADDED: ",?10,$PIECE(@BARGL,U)
End DoDot:2
End DoDot:1
+27 WRITE !!,BARTMP(.01)," Has been added",!
+28 ;--------------------------------
+29 ;
ARSPAC ;set up two special A/R accounts
+1 KILL DIC
+2 SET DIC=$$DIC^XBDIQ1(90052.07)
+3 SET DIC(0)="L"
+4 IF '$DATA(@(DIC_"""B"",""UN-ALLOCATED"")"))
Begin DoDot:1
+5 SET X="UN-ALLOCATED"
+6 KILL DD,DO
+7 DO ^DIC
+8 IF Y'>0
Begin DoDot:2
+9 SET BARQUIT=1
+10 WRITE !,"ERROR IN SETUP OF UN-ALLOCATED"
End DoDot:2
End DoDot:1
+11 ;--------------------------------
+12 ;
HOSPSRVC ;
+1 ;hospital service
SET DIC=49
+2 SET DIC(0)="L"
+3 SET DLAYGO=49
+4 IF '$DATA(^DIC(49,"B","BUSINESS OFFICE"))
Begin DoDot:1
+5 SET X="BUSINESS OFFICE"
+6 KILL DD,DO
+7 DO ^DIC
+8 IF Y'>0
Begin DoDot:2
+9 SET BARQUIT=1
+10 WRITE !,"ERROR IN SETUP OF BUSINESS OFFICE",!
End DoDot:2
End DoDot:1
+11 IF '$DATA(^DIC(49,"B","FISCAL SERVICE"))
Begin DoDot:1
+12 SET X="FISCAL SERVICE"
+13 KILL DD,DO
+14 DO ^DIC
+15 IF Y'>0
Begin DoDot:2
+16 SET BARQUIT=1
+17 WRITE !,"ERROR IN SETUP OF FISCAL SERVICE",!
End DoDot:2
End DoDot:1
+18 IF $GET(BARQUIT)
DO EOP^BARUTL(0)
+19 ;
EADD ;
+1 QUIT
FNUM ;;$T filenumber to be regionally added/deleted
+1 ;;90051.01
+2 ;;90051.02
+3 ;;90050.02
+4 ;;90050.01
+5 ;;90052.05
+6 ;;90052.06
+7 ;;90052.07
+8 ;;90050.03
+9 ;;end of list
EFNUM ;----------
+1 ;
SRVSEC ;EP switch Service Section
+1 KILL DIC,DR,DIE,DA
+2 SET DIC="^BARTBL("
+3 SET DIC(0)="AEQM"
+4 SET DIC("S")="I $P(^(0),U,3)=""SRVSEC"""
+5 KILL DD,DO
+6 DO ^DIC
+7 IF Y'>0
QUIT
+8 SET Y=+Y
+9 SET DIE="^VA(200,"
+10 SET DA=DUZ
+11 SET DR="29///"_$$VAL^XBDIQ1("^BARTBL(",+Y,.01)
+12 SET DIDEL=90050
+13 DO ^DIE
+14 KILL DIDEL
+15 QUIT
