BARUTL0.m

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