Routine: BARUTL

BARUTL ; IHS/SD/LSL - UTILITY PROGRAM FOR FAC A/R ; 07/25/2010

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**13,19,21,23**;OCT 26, 2005

;;

 ; IHS/SD/LSL - 04/04/02 - V1.6 Patch 2 - NOIS XJG-0302-160095

 ;     Added FIND3PB function to find bill in 3P Bill file if given

 ;     A/R DUZ(2) and BILL IEN

 ; IHS/SD/SDR - 4/4/2002 - V1.6 Patch 2 - NOIS XXX-0202-200181

 ;     Added LWC line to to do converting to all lower case

 ; IHS/SD/LSL - 09/11/02 - V1.6 Patch 3 - HIPAA 276/277

 ;     Added INSIEN function to return the IEN of the INSURER FILE if

 ;     passed the DUZ(2) AND (A/R Bill IEN or the A/R Account IEN)

 ; IHS/SD/LSL - 09/11/02 - V1.6 Patch 3 - HIPAA 276/277

 ;     Added SBR function to return the Subscriber if passed the A/R

 ;     BILL IEN and DUZ(2)

 ; IHS/SD/LSL - 08/25/03 - V1.7 Patch 2

 ;      Modify INSIEN to quit with values outside of dot structure

 ; IHS/SD/SDR 5/26/09 HEAT4301 BAR*1.8*13

 ;      Modify patch number in filename so batches are formatted

 ;      correctly by the HUB

 ; TMM 07/25/2010 V1.8*19 - Modify A/R Statistical report to

 ;     include (Emloyer) Group Plan data.  requirement 4PMS10022.

 ; P.OTT 08/12/2013 FIXED $$SBR: QUIT WITH VALUE

 ;       Fixed BARPOLN (Policy Number reference to 702)

 ;       HEAT#131103 8/28/2013 FIXED <UNDEF> IF DUZ(2) IS NOT REGIONALLY SETUP

 ; *********************************************************************

 ;VARIOUS ENTRY POINTS

INIT ;EP Initialize Environment

 K DIR

 S IOP="HOME"

 D ^%ZIS

 I $G(DUZ(2))']"" D  Q

 . S BARQUIT=1

 . D EOP(1)

 ;HEAT#131101

 I '$D(^DIC(4,DUZ(2))) D  Q

 . W !,"USER / SITE IS NOT CORRECTLY SETUP"

 . W !,"CONTACT YOUR A/R MANAGER",*7

 . S BARQUIT=1

 . D EOP(1)

. Q

 I '$D(^BARBL(DUZ(2))) D  Q

 . W !,$P(^DIC(4,DUZ(2),0),U)," IS NOT REGIONALLY SETUP"

 . W !,"CONTACT YOUR A/R MANAGER",*7

 . S BARQUIT=1

 . D EOP(1)

 D CHKFILES

 D BARUSR^BARUTL0 ; user parameters

 D BARSITE^BARUTL0 ; site paramters

 D BARSPAR^BARUTL0 ; A/R site paramters

 D BARPSAT^BARUTL0 ;parent satellite

 ;S:'$D(CURDUZ2) CURDUZ2=DUZ(2)  ;IHS/SD/TPF BAR*1.8*21 HEAT43337 SET CURRENT DUZ(2) USED TO SEE IF CASHIER CHANGES FACILITY MIDSTREAM

 ; *********************************************************************

CLIDED ;EP COLLECTION ID file edit

 D BARUSR^BARUTL0

 K DIC

 S DIC="^BAR(90051.02,DUZ(2),"

 S DIC("S")="I $P(^(0),U,10)=BARUSR(29,""I"")"

 S DIC(0)="AEQML"

 D ^DIC

 I +Y'>0 K DIC Q

 S BARDA=+Y

 K DR

 ; if new stuff A/R section and location

 I +$P(Y,U,3) D

 . S DIE=DIC

 . S DA=+Y

 . S DR="8///^S X=DUZ(2);10////^S X=BARUSR(29,""I"")"

 . K DIC

 . S DIDEL=90050

 . D ^DIE

 . K DIDEL

 K DR,DIC,DIE,DA

 S DA=BARDA

 S DR="[BAR COLLECTION POINT EDIT]"

 S DDSFILE=90051.02

 D ^DDS

 G CLIDED

 ; *********************************************************************

NEWBILL ;EP

 ; file^dicn a new BIll with dic(dr)

 L +^BAR(90052.06,DUZ(2)):3 I '$T D

 .W !!,*7,"A/R Parameter file is locked by another user."

 .D EOP(1)

 D BARSPAR^BARUTL0

 I BARSPAR(6.5)=BARSPAR(6.07) S BARSPAR(7)=BARSPAR(7)+1

 E  S BARSPAR(6,"I")=DT,BARSPAR(7)=1

 K DIE,DR,DA

 S DIE=$$DIC^XBDIQ1(90052.06)

 S DA=+BARSPAR("ID")

 S DR="6////^S X=BARSPAR(6,""I"");7///^S X=BARSPAR(7)"

 S DIDEL=90050

 D ^DIE

 K DIDEL

 D BARSPAR^BARUTL0

 L -^BAR(90052.06)

 K DIC,DR,DA,DD,DO

 S X=BARSPAR(9)_"-"_BARSPAR(6.5)_"-"_BARSPAR(7)

 S DIC="^BARBL(DUZ(2),"

 S DIC(0)="XQMLZ"

 S DIC("DR")="8////^S X=DUZ(2);10///^S X=BARUSR(29);5///NOW;6////^S X=DUZ"

 S DLAYGO=90050

 K DD,DO

 D FILE^DICN

 K DLAYGO

 ; *********************************************************************

BARBL ;EP

 ; setup BARBL( array from the A/R bill file

 N DIC,DR,DIQ,XB

 S:$D(BARBL("ID")) DA=+BARBL("ID")

 S:$D(BARBLDA) DA=BARBLDA

 S DIC=90050.01

 S DR=".001:200"

 S DIQ="BARBL("

 S DIQ(0)="I"

 D EN^XBDIQ1

 ; *********************************************************************

ADDREGON ;EP

 ; add a regional site (needs DUZ(2))

 D ADDREGON^BARUTL0

 ; *********************************************************************

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 ;----------

CHKFILES ;EP

 ; CHECK FILES

 K BARQUIT

 F BARI=1:1 S BARFLNUM=$P($T(FNUM+BARI),";;",2) Q:'BARFLNUM  D

 . S BARGL=^DIC(BARFLNUM,0,"GL")_"0)"

 . S BARECNT=$P($G(@BARGL),"^",4)

 . I 'BARECNT,BARFLNUM'=90050.03,BARFLNUM'=90051.01 D

 . . S BARQUIT=1

 . . W !,$P(^DIC(BARFLNUM,0),U),"  Needs to have entries added !"

 I $G(BARQUIT) D EOP(1)

 ; *********************************************************************

KILLREG ;EP

 ; Kill off a complete region

 K DIQ

 S DIC=4

 S DIQ="BARTMP("

 S DR=".01"

 S DA=DUZ(2)

 D EN^XBDIQ1

 I '$D(^BARBL(DUZ(2))) D  Q

 . W !,?5,BARTMP(.01),"DOES NOT EXIT"

 . K DIR

 . D EOP^BARUTL(1)

 K DIR

 S DIR(0)="Y"

 S DIR("B")="NO"

 S DIR("A")=BARTMP(.01)_" to be DELETED as an A/R Regional Site?"

 D ^DIR

 Q:Y'>0

 F BARI=1:1 S BARFLNUM=$P($T(FNUM+BARI),";;",2) Q:'BARFLNUM  D

 . S BARGL=^DIC(BARFLNUM,0,"GL")_"0)"

 . W !,"DELETED: ",?10,$P(@BARGL,U)

 . K @($P(BARGL,",0)")_")")

 W !!,BARTMP(.01)," Has been DELETED",!

 K DIR

 D EOP^BARUTL(1)

 ; *********************************************************************

SPEDIT ;EP - Site Parameter edit

 S DIC=90052.06

 S DIC(0)="AEQMLZ"

 D ^DIC

 Q:Y'>0

 S DIE=DIC

 S DA=+Y

 S DR="8////^S X=DUZ(2);2;3"

 S DIDEL=90050

 D ^DIE

 K DIDEL

 G SPEDIT

 ; *********************************************************************

PSHLP ;EP list par/sat and hot keys

N Y

 S Y=0

 F  S Y=$O(BARPSAT(Y)) Q:Y'>0  W !,BARPSAT(Y,2),?5,BARPSAT(Y,.01)

 ; *********************************************************************

BAL(X,Y) ;EP

 ; balance at end of FM DATE y FOR ACCOUNT x

 N BARTOT,I

 S BARTOT=0,I=0

 S Y=$P(Y,".",1)+.9999

 F  S I=$O(^BARTR(DUZ(2),"AE",X,I)) Q:'I!(I>Y)  D

 .S BARTOT=BARTOT+$P(^BARTR(DUZ(2),I,0),"^",2)-$P(^(0),"^",3)

 S BARTOT=BARTOT*-1

 Q BARTOT

 ; *********************************************************************

EOP(X) ;EP

 ; end of page

 ;X=0, 1, or 2

 Q:$G(IOT)'["TRM"

 Q:$E($G(IOST))'="C"

 Q:$D(IO("S"))

 Q:$D(ZTQUEUED)

 F  W ! Q:$Y+4>IOSL

 Q:X=2

 K DIR

 S DIR(0)="E"

 S:X=1 DIR("A")="Enter RETURN to continue"

 D ^DIR

 K DIR

 ; *********************************************************************

UPC(X) ;EP - convert x to upper case

N Y

 S Y=$TR($G(X),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

Q Y

 ; *********************************************************************

LWC(X) ;EP - convert x to lower case

N Y

 S Y=$TR($G(X),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")

Q Y

 ; *********************************************************************

FIND3PB(DUZO2,BARBLDA)       ; EP

 ; Given DUZ(2) and A/R Bill IEN

 ; Find 3P Bill

 ; If no 3P Bill return null

 ; otherwise return DUZ(2),3P BILL IEN

 I '+DUZO2 Q ""

 I '+BARBLDA Q ""

 N BARDOS,BARPAT,BAR

 S BAR("3P NAME")=$P($G(^BARBL(DUZO2,BARBLDA,0)),U)

 S BAR("3P NAME")=$P(BAR("3P NAME"),"-")

 S BARPAT=$P($G(^BARBL(DUZO2,BARBLDA,1)),U)

 S BARDOS=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,2)

 K DIC

 N DA

 S DIC="^ABMDBILL(DUZ(2),"

 S DIC(0)="XM"

 S X=BAR("3P NAME")

 S BARHOLD=DUZ(2)

 S DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,0)),U,22)   ; 3P DUZ(2)

 I DUZ(2)'="" D ^DIC I +Y>0 D FIND3PB2 I BAR3PLOC]"" S DUZ(2)=BARHOLD Q BAR3PLOC

 S DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,1)),U,8)    ; Visit location

 I DUZ(2)'="" D ^DIC I +Y>0 D FIND3PB2 I BAR3PLOC]"" S DUZ(2)=BARHOLD Q BAR3PLOC

 S DUZ(2)=$P($G(^BARBL(DUZO2,BARBLDA,0)),U,8)    ; Parent location

 I DUZ(2)'="" D ^DIC I +Y>0 D FIND3PB2 I BAR3PLOC]"" S DUZ(2)=BARHOLD Q BAR3PLOC

 S DUZ(2)=BARHOLD

 Q ""

 ; *********************************************************************

FIND3PB2 ;

 N BAR3PPAT,BAR3PDOS

 S BAR3PLOC=""

 S BAR3PPAT=$P($G(^ABMDBILL(DUZ(2),+Y,0)),U,5)

 S BAR3PDOS=$P($G(^ABMDBILL(DUZ(2),+Y,7)),U,1)

 I BAR3PPAT=BARPAT,BAR3PDOS=BARDOS S BAR3PLOC=DUZ(2)_","_+Y

 S DUZ(2)=BARHOLD

 ; ********************************************************************

INSIEN(BAR1,BAR2,BAR3) ; EP

 ; Find IEN to Insurer file

 ; BAR1 = "BILL"/"ACCOUNT"

 ; BAR2 = BILL IEN/ACCOUNT IEN based on BAR1

 ; BAR3 = DUZ(2)

 S BARINS=""

 I '$D(BAR1),'$D(BAR2),'$D(BAR3) Q ""   ; Correct data not passed in

 I BAR1'="BILL",BAR1'="ACCOUNT" Q ""    ; BAR1 must be BILL or ACCOUNT

 I '+BAR2,'+BAR3 Q ""                   ; BAR2 and BAR3 must be numeric

 I BAR1="BILL" S BAR2=$$GET1^DIQ(90050.01,BAR2,3,"I")

 I +BAR2 D

 . S BARINS=$$GET1^DIQ(90050.02,BAR2,.01,"I")

 . S:$P(BARINS,";",2)'="AUTNINS(" BARINS=""  ; Account on bill is not Insurer

 . S BARINS=$P(BARINS,";")

 Q BARINS

 ; ********************************************************************

SBR(BARDUZ,BARBL) ; EP CALLED AS FUNCTION FROM BARRAOI

 ; Find Insurance Subscriber given Bill IEN and DUZ(2)

 ; BARBL = A/R BILL IEN

 ; BARDUZ = A/R DUZ(2)

 I '$D(BARBL),'$D(BARDUZ) Q ""          ; Correct data not passed in

 I '+BARBL,'+BARDUZ Q ""                ; Values must be numeric

 N BAR3PLOC,BAR3PIEN,BAR3DUZ            ; Preserve tmp vars

 S BAR3PLOC=$$FIND3PB^BARUTL(BARDUZ,BARBL)   ; Find 3P bill

 S BAR3DUZ=$P(BAR3PLOC,",")                  ; 3P DUZ(2)

 S BAR3PIEN=$P(BAR3PLOC,",",2)               ; 3P BILL IEN

 I '+BAR3DUZ Q ""

 I 'BAR3PIEN Q ""

 ; The call below will also set up ABMP array

 S BARSBR=$$SBR^ABMUTLP(BAR3PIEN,BAR3DUZ)    ; Subscriber

 S BARREL=ABMP("REL")                       ; Relationship

 Q BARSBR                                   ; fix: added ret value P.OTT

 ;start new code IHS/SD/SDR 5/26/09 HEAT4301 BAR*1.8*13

PATCH(PKG,VER) ;EP - returns last patch applied for a Package, PATCH^DATE

 ;        Patch includes Seq # if Released

 N PKGIEN,VERIEN,LATEST,PATCH,SUBIEN

 I $G(VER)="" S VER=$$VERSION^XPDUTL(PKG) Q:'VER -1

 S PKGIEN=$O(^DIC(9.4,"B",PKG,"")) Q:'PKGIEN -1

 S VERIEN=$O(^DIC(9.4,PKGIEN,22,"B",VER,"")) Q:'VERIEN -1

 S LATEST=-1,PATCH=-1,SUBIEN=0

 F  S SUBIEN=$O(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN)) Q:SUBIEN'>0  D

 . I $P(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)>LATEST S LATEST=$P(^(0),U,2),PATCH=$P(^(0),U)

 . I $P(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)=LATEST,$P(^(0),U)>PATCH S PATCH=$P(^(0),U)

 Q PATCH_U_LATEST

 ;end new code HEAT4301 BAR*1.8*13

 ;New GROUPLAN tag   ;M819*ADD*TMM*20100720

GROUPLAN(BARBL) ;  Return Group Plan (from Employer Group Insurance file)

 ; BARBL = A/B Bill IEN

 ;---A/R Bill file data

 N BARACIEN,BARFIND,BARBLINS,BARGPIEN,BARGPNAM,BARGPNUM,BARINSE,BARINSI

 N BARLINE,BARPH,BARPHIEN,BARPOLH,BARPOLN,BARTMP,BARTMPBL,BARTMPEG,BARTMPPH

 S $P(BARLINE,"-",40)=""

 S BARACIEN=$$GET1^DIQ(90050.01,BARBL_",",3,"I")        ;A/R Bill - A/R Account IEN

 S BARBLINS=$$GET1^DIQ(90050.02,BARACIEN_",",.01,"I")

 I BARBLINS'["AUTNINS" Q 0_U_"NOT AUTNINS"_U_BARBL      ;not insurance company

 S BARINSI=$P(BARBLINS,";",1)

 S BARINSE=$$GET1^DIQ(9999999.18,BARINSI_",",.01,"E")

 S BARPAT=$$GET1^DIQ(90050.01,BARBL_",",101,"I")        ;Patient IEN

 I BARPAT="" S BARTMP=0_U_"BARPAT"_U_BARBL D  Q BARTMP

 . I $G(DEBUG) D

 .. W !,"BARBL=",BARBL," Patient (Policy Holder lookup) is null"

 .. S BARTMP=$G(^TMP($J,"BARDRST",BARBL))+1

 .. S ^TMP($J,"BARDRST",BARBL,BARTMP)="GRPPLAN_BARUTL^BARBL="_BARBL_"^0|BARPAT is null"_"|"_BARBL

 ;---Policy Holder file data

 S BARPOLH=$$GET1^DIQ(90050.01,BARBL_",",701,"I")       ;Policy Holder Name

 S BARPOLN=$$GET1^DIQ(90050.01,BARBL_",",702,"I")       ;Policy Number FIXED: P.OTT

 S BARFIND=0

 S BARGPIEN=""

 S BARPH="" F  S BARPH=$O(^AUPN3PPH("C",BARPAT,BARPH)) Q:BARPH=""!BARFIND=1  D

 . S BARPHINS=$$GET1^DIQ(9000003.1,BARPH_",",.03,"I")   ;Insurance company from Policy Holder file

 . I BARPHINS'=BARINSI Q

 . S BARFIND=1

 . S BARPHIEN=BARPH

 . S BARGPIEN=$$GET1^DIQ(9000003.1,BARPHIEN_",",.06,"I")    ;group IEN

 I 'BARFIND Q 0_U_"BARFIND"_U_BARBL

 ;---Employer Insurance Group data for this A/R bill

 I 'BARFIND D  Q 0_U_"BARFIND^"_BARBL

 I BARGPIEN="" Q 0_U_"BARGPIEN"_U_BARBL

 S BARGPNAM=$$GET1^DIQ(9999999.77,BARGPIEN_",",.01,"E")  ;group plan name

 S BARGPNUM=$$GET1^DIQ(9999999.77,BARGPIEN_",",.02,"E")  ;group plan number

 S BARTMPEG=BARGPIEN_"|"_BARGPNUM_"|"_BARGPNAM   ;Employer Group data

 S BARTMPPH=BARPHIEN_"|"_BARPOLH_"|"_BARPHINS_"|"_BARPAT    ;Policy Holder data

 S BARTMPBL=BARACIEN_"|"_BARINSI_"|"_BARINSE     ;A/R Bill data

 Q 1_U_BARTMPEG_U_BARTMPPH_U_BARTMPBL

 ;-----------------EOR------------

BARUTL    ; IHS/SD/LSL - UTILITY PROGRAM FOR FAC A/R ; 07/25/2010

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**13,19,21,23**;OCT 26, 2005

 +2       ;;

 +3       ; IHS/SD/LSL - 04/04/02 - V1.6 Patch 2 - NOIS XJG-0302-160095

 +4       ;     Added FIND3PB function to find bill in 3P Bill file if given

 +5       ;     A/R DUZ(2) and BILL IEN

 +6       ;

 +7       ; IHS/SD/SDR - 4/4/2002 - V1.6 Patch 2 - NOIS XXX-0202-200181

 +8       ;     Added LWC line to to do converting to all lower case

 +9       ;

 +10      ; IHS/SD/LSL - 09/11/02 - V1.6 Patch 3 - HIPAA 276/277

 +11      ;     Added INSIEN function to return the IEN of the INSURER FILE if

 +12      ;     passed the DUZ(2) AND (A/R Bill IEN or the A/R Account IEN)

 +13      ;

 +14      ; IHS/SD/LSL - 09/11/02 - V1.6 Patch 3 - HIPAA 276/277

 +15      ;     Added SBR function to return the Subscriber if passed the A/R

 +16      ;     BILL IEN and DUZ(2)

 +17      ;

 +18      ; IHS/SD/LSL - 08/25/03 - V1.7 Patch 2

 +19      ;      Modify INSIEN to quit with values outside of dot structure

 +20      ;

 +21      ; IHS/SD/SDR 5/26/09 HEAT4301 BAR*1.8*13

 +22      ;      Modify patch number in filename so batches are formatted

 +23      ;      correctly by the HUB

 +24      ; TMM 07/25/2010 V1.8*19 - Modify A/R Statistical report to

 +25      ;     include (Emloyer) Group Plan data.  requirement 4PMS10022.

 +26      ; P.OTT 08/12/2013 FIXED $$SBR: QUIT WITH VALUE

 +27      ;       Fixed BARPOLN (Policy Number reference to 702)

 +28      ;       HEAT#131103 8/28/2013 FIXED <UNDEF> IF DUZ(2) IS NOT REGIONALLY SETUP

 +29      ; *********************************************************************

 +30      ;

 +31      ;VARIOUS ENTRY POINTS

INIT      ;EP Initialize Environment

 +1        KILL DIR

 +2        SET IOP="HOME"

 +3        DO ^%ZIS

 +4        IF $GET(DUZ(2))']""

               Begin DoDot:1

 +5                SET BARQUIT=1

 +6                DO EOP(1)

               End DoDot:1

               QUIT

 +7       ;

 +8       ;HEAT#131101

 +9        IF '$DATA(^DIC(4,DUZ(2)))

               Begin DoDot:1

 +10               WRITE !,"USER / SITE IS NOT CORRECTLY SETUP"

 +11               WRITE !,"CONTACT YOUR A/R MANAGER",*7

 +12               SET BARQUIT=1

 +13               DO EOP(1)

 +14               QUIT

               End DoDot:1

               QUIT

 +15      ;

 +16       IF '$DATA(^BARBL(DUZ(2)))

               Begin DoDot:1

 +17               WRITE !,$PIECE(^DIC(4,DUZ(2),0),U)," IS NOT REGIONALLY SETUP"

 +18               WRITE !,"CONTACT YOUR A/R MANAGER",*7

 +19               SET BARQUIT=1

 +20               DO EOP(1)

               End DoDot:1

               QUIT

 +21      ;

 +22      ;

 +23       DO CHKFILES

 +24      ; user parameters

           DO BARUSR^BARUTL0

 +25      ; site paramters

           DO BARSITE^BARUTL0

 +26      ; A/R site paramters

           DO BARSPAR^BARUTL0

 +27      ;parent satellite

           DO BARPSAT^BARUTL0

 +28      ;

 +29      ;S:'$D(CURDUZ2) CURDUZ2=DUZ(2)  ;IHS/SD/TPF BAR*1.8*21 HEAT43337 SET CURRENT DUZ(2) USED TO SEE IF CASHIER CHANGES FACILITY MIDSTREAM

 +30      ;

 +31       QUIT

 +32      ; *********************************************************************

 +33      ;

CLIDED    ;EP COLLECTION ID file edit

 +1        DO BARUSR^BARUTL0

 +2        KILL DIC

 +3        SET DIC="^BAR(90051.02,DUZ(2),"

 +4        SET DIC("S")="I $P(^(0),U,10)=BARUSR(29,""I"")"

 +5        SET DIC(0)="AEQML"

 +6        DO ^DIC

 +7        IF +Y'>0

               KILL DIC

               QUIT

 +8        SET BARDA=+Y

 +9        KILL DR

 +10      ; if new stuff A/R section and location

 +11       IF +$PIECE(Y,U,3)

               Begin DoDot:1

 +12               SET DIE=DIC

 +13               SET DA=+Y

 +14               SET DR="8///^S X=DUZ(2);10////^S X=BARUSR(29,""I"")"

 +15               KILL DIC

 +16               SET DIDEL=90050

 +17               DO ^DIE

 +18               KILL DIDEL

               End DoDot:1

 +19       KILL DR,DIC,DIE,DA

 +20       SET DA=BARDA

 +21       SET DR="[BAR COLLECTION POINT EDIT]"

 +22       SET DDSFILE=90051.02

 +23       DO ^DDS

 +24       GOTO CLIDED

 +25      ; *********************************************************************

 +26      ;

NEWBILL   ;EP

 +1       ; file^dicn a new BIll with dic(dr)

 +2        LOCK +^BAR(90052.06,DUZ(2)):3

           IF '$TEST

               Begin DoDot:1

 +3                WRITE !!,*7,"A/R Parameter file is locked by another user."

 +4                DO EOP(1)

               End DoDot:1

 +5        DO BARSPAR^BARUTL0

 +6        IF BARSPAR(6.5)=BARSPAR(6.07)

               SET BARSPAR(7)=BARSPAR(7)+1

 +7       IF '$TEST

               SET BARSPAR(6,"I")=DT

               SET BARSPAR(7)=1

 +8        KILL DIE,DR,DA

 +9        SET DIE=$$DIC^XBDIQ1(90052.06)

 +10       SET DA=+BARSPAR("ID")

 +11       SET DR="6////^S X=BARSPAR(6,""I"");7///^S X=BARSPAR(7)"

 +12       SET DIDEL=90050

 +13       DO ^DIE

 +14       KILL DIDEL

 +15       DO BARSPAR^BARUTL0

 +16       LOCK -^BAR(90052.06)

 +17       KILL DIC,DR,DA,DD,DO

 +18       SET X=BARSPAR(9)_"-"_BARSPAR(6.5)_"-"_BARSPAR(7)

 +19       SET DIC="^BARBL(DUZ(2),"

 +20       SET DIC(0)="XQMLZ"

 +21       SET DIC("DR")="8////^S X=DUZ(2);10///^S X=BARUSR(29);5///NOW;6////^S X=DUZ"

 +22       SET DLAYGO=90050

 +23       KILL DD,DO

 +24       DO FILE^DICN

 +25       KILL DLAYGO

 +26       QUIT

 +27      ; *********************************************************************

 +28      ;

BARBL     ;EP

 +1       ; setup BARBL( array from the A/R bill file

 +2        NEW DIC,DR,DIQ,XB

 +3        IF $DATA(BARBL("ID"))

               SET DA=+BARBL("ID")

 +4        IF $DATA(BARBLDA)

               SET DA=BARBLDA

 +5        SET DIC=90050.01

 +6        SET DR=".001:200"

 +7        SET DIQ="BARBL("

 +8        SET DIQ(0)="I"

 +9        DO EN^XBDIQ1

 +10       QUIT

 +11      ; *********************************************************************

 +12      ;

ADDREGON  ;EP

 +1       ; add a regional site (needs DUZ(2))

 +2        DO ADDREGON^BARUTL0

 +3        QUIT

 +4       ; *********************************************************************

 +5       ;

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       ;

CHKFILES  ;EP

 +1       ; CHECK FILES

 +2        KILL BARQUIT

 +3        QUIT

 +4        FOR BARI=1:1

               SET BARFLNUM=$PIECE($TEXT(FNUM+BARI),";;",2)

               IF 'BARFLNUM

                   QUIT

               Begin DoDot:1

 +5                SET BARGL=^DIC(BARFLNUM,0,"GL")_"0)"

 +6                SET BARECNT=$PIECE($GET(@BARGL),"^",4)

 +7                IF 'BARECNT

                       IF BARFLNUM'=90050.03

                           IF BARFLNUM'=90051.01

                               Begin DoDot:2

 +8                                SET BARQUIT=1

 +9                                WRITE !,$PIECE(^DIC(BARFLNUM,0),U),"  Needs to have entries added !"

                               End DoDot:2

               End DoDot:1

 +10       IF $GET(BARQUIT)

               DO EOP(1)

 +11       QUIT

 +12      ; *********************************************************************

 +13      ;

KILLREG   ;EP

 +1       ; Kill off a complete region

 +2        KILL DIQ

 +3        SET DIC=4

 +4        SET DIQ="BARTMP("

 +5        SET DR=".01"

 +6        SET DA=DUZ(2)

 +7        DO EN^XBDIQ1

 +8        IF '$DATA(^BARBL(DUZ(2)))

               Begin DoDot:1

 +9                WRITE !,?5,BARTMP(.01),"DOES NOT EXIT"

 +10               KILL DIR

 +11               DO EOP^BARUTL(1)

               End DoDot:1

               QUIT

 +12      ;

 +13       KILL DIR

 +14       SET DIR(0)="Y"

 +15       SET DIR("B")="NO"

 +16       SET DIR("A")=BARTMP(.01)_" to be DELETED as an A/R Regional Site?"

 +17       DO ^DIR

 +18       IF Y'>0

               QUIT

 +19       FOR BARI=1:1

               SET BARFLNUM=$PIECE($TEXT(FNUM+BARI),";;",2)

               IF 'BARFLNUM

                   QUIT

               Begin DoDot:1

 +20               SET BARGL=^DIC(BARFLNUM,0,"GL")_"0)"

 +21               WRITE !,"DELETED: ",?10,$PIECE(@BARGL,U)

 +22               KILL @($PIECE(BARGL,",0)")_")")

               End DoDot:1

 +23       WRITE !!,BARTMP(.01)," Has been DELETED",!

 +24       KILL DIR

 +25       DO EOP^BARUTL(1)

 +26       QUIT

 +27      ; *********************************************************************

 +28      ;

SPEDIT    ;EP - Site Parameter edit

 +1        SET DIC=90052.06

 +2        SET DIC(0)="AEQMLZ"

 +3        DO ^DIC

 +4        IF Y'>0

               QUIT

 +5        SET DIE=DIC

 +6        SET DA=+Y

 +7        SET DR="8////^S X=DUZ(2);2;3"

 +8        SET DIDEL=90050

 +9        DO ^DIE

 +10       KILL DIDEL

 +11       GOTO SPEDIT

 +12      ; *********************************************************************

 +13      ;

PSHLP     ;EP list par/sat and hot keys

 +1        NEW Y

 +2        SET Y=0

 +3        FOR

               SET Y=$ORDER(BARPSAT(Y))

               IF Y'>0

                   QUIT

               WRITE !,BARPSAT(Y,2),?5,BARPSAT(Y,.01)

 +4        QUIT

 +5       ; *********************************************************************

 +6       ;

BAL(X,Y)  ;EP

 +1       ; balance at end of FM DATE y FOR ACCOUNT x

 +2        NEW BARTOT,I

 +3        SET BARTOT=0

           SET I=0

 +4        SET Y=$PIECE(Y,".",1)+.9999

 +5        FOR

               SET I=$ORDER(^BARTR(DUZ(2),"AE",X,I))

               IF 'I!(I>Y)

                   QUIT

               Begin DoDot:1

 +6                SET BARTOT=BARTOT+$PIECE(^BARTR(DUZ(2),I,0),"^",2)-$PIECE(^(0),"^",3)

               End DoDot:1

 +7        SET BARTOT=BARTOT*-1

 +8        QUIT BARTOT

 +9       ; *********************************************************************

 +10      ;

EOP(X)    ;EP

 +1       ; end of page

 +2       ;X=0, 1, or 2

 +3        IF $GET(IOT)'["TRM"

               QUIT

 +4        IF $EXTRACT($GET(IOST))'="C"

               QUIT

 +5        IF $DATA(IO("S"))

               QUIT

 +6        IF $DATA(ZTQUEUED)

               QUIT

 +7        FOR

               WRITE !

               IF $Y+4>IOSL

                   QUIT

 +8        IF X=2

               QUIT

 +9        KILL DIR

 +10       SET DIR(0)="E"

 +11       IF X=1

               SET DIR("A")="Enter RETURN to continue"

 +12       DO ^DIR

 +13       KILL DIR

 +14       QUIT

 +15      ; *********************************************************************

 +16      ;

UPC(X)    ;EP - convert x to upper case

 +1        NEW Y

 +2        SET Y=$TRANSLATE($GET(X),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

 +3        QUIT Y

 +4       ; *********************************************************************

 +5       ;

LWC(X)    ;EP - convert x to lower case

 +1        NEW Y

 +2        SET Y=$TRANSLATE($GET(X),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")

 +3        QUIT Y

 +4       ; *********************************************************************

 +5       ;

FIND3PB(DUZO2,BARBLDA) ; EP

 +1       ;

 +2       ; Given DUZ(2) and A/R Bill IEN

 +3       ; Find 3P Bill

 +4       ; If no 3P Bill return null

 +5       ; otherwise return DUZ(2),3P BILL IEN

 +6       ;

 +7        IF '+DUZO2

               QUIT ""

 +8        IF '+BARBLDA

               QUIT ""

 +9        NEW BARDOS,BARPAT,BAR

 +10       SET BAR("3P NAME")=$PIECE($GET(^BARBL(DUZO2,BARBLDA,0)),U)

 +11       SET BAR("3P NAME")=$PIECE(BAR("3P NAME"),"-")

 +12       SET BARPAT=$PIECE($GET(^BARBL(DUZO2,BARBLDA,1)),U)

 +13       SET BARDOS=$PIECE($GET(^BARBL(DUZO2,BARBLDA,1)),U,2)

 +14       KILL DIC

 +15       NEW DA

 +16       SET DIC="^ABMDBILL(DUZ(2),"

 +17       SET DIC(0)="XM"

 +18       SET X=BAR("3P NAME")

 +19       SET BARHOLD=DUZ(2)

 +20      ; 3P DUZ(2)

           SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,0)),U,22)

 +21       IF DUZ(2)'=""

               DO ^DIC

               IF +Y>0

                   DO FIND3PB2

                   IF BAR3PLOC]""

                       SET DUZ(2)=BARHOLD

                       QUIT BAR3PLOC

 +22      ; Visit location

           SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,1)),U,8)

 +23       IF DUZ(2)'=""

               DO ^DIC

               IF +Y>0

                   DO FIND3PB2

                   IF BAR3PLOC]""

                       SET DUZ(2)=BARHOLD

                       QUIT BAR3PLOC

 +24      ; Parent location

           SET DUZ(2)=$PIECE($GET(^BARBL(DUZO2,BARBLDA,0)),U,8)

 +25       IF DUZ(2)'=""

               DO ^DIC

               IF +Y>0

                   DO FIND3PB2

                   IF BAR3PLOC]""

                       SET DUZ(2)=BARHOLD

                       QUIT BAR3PLOC

 +26       SET DUZ(2)=BARHOLD

 +27       QUIT ""

 +28      ; *********************************************************************

 +29      ;

FIND3PB2  ;

 +1        NEW BAR3PPAT,BAR3PDOS

 +2        SET BAR3PLOC=""

 +3        SET BAR3PPAT=$PIECE($GET(^ABMDBILL(DUZ(2),+Y,0)),U,5)

 +4        SET BAR3PDOS=$PIECE($GET(^ABMDBILL(DUZ(2),+Y,7)),U,1)

 +5        IF BAR3PPAT=BARPAT

               IF BAR3PDOS=BARDOS

                   SET BAR3PLOC=DUZ(2)_","_+Y

 +6        SET DUZ(2)=BARHOLD

 +7        QUIT

 +8       ; ********************************************************************

 +9       ;

INSIEN(BAR1,BAR2,BAR3) ; EP

 +1       ;

 +2       ; Find IEN to Insurer file

 +3       ; BAR1 = "BILL"/"ACCOUNT"

 +4       ; BAR2 = BILL IEN/ACCOUNT IEN based on BAR1

 +5       ; BAR3 = DUZ(2)

 +6       ;

 +7        SET BARINS=""

 +8       ; Correct data not passed in

           IF '$DATA(BAR1)

               IF '$DATA(BAR2)

                   IF '$DATA(BAR3)

                       QUIT ""

 +9       ; BAR1 must be BILL or ACCOUNT

           IF BAR1'="BILL"

               IF BAR1'="ACCOUNT"

                   QUIT ""

 +10      ; BAR2 and BAR3 must be numeric

           IF '+BAR2

               IF '+BAR3

                   QUIT ""

 +11       IF BAR1="BILL"

               SET BAR2=$$GET1^DIQ(90050.01,BAR2,3,"I")

 +12       IF +BAR2

               Begin DoDot:1

 +13               SET BARINS=$$GET1^DIQ(90050.02,BAR2,.01,"I")

 +14      ; Account on bill is not Insurer

                   IF $PIECE(BARINS,";",2)'="AUTNINS("

                       SET BARINS=""

 +15               SET BARINS=$PIECE(BARINS,";")

               End DoDot:1

 +16       QUIT BARINS

 +17      ; ********************************************************************

 +18      ;

SBR(BARDUZ,BARBL) ; EP CALLED AS FUNCTION FROM BARRAOI

 +1       ;

 +2       ; Find Insurance Subscriber given Bill IEN and DUZ(2)

 +3       ; BARBL = A/R BILL IEN

 +4       ; BARDUZ = A/R DUZ(2)

 +5       ;

 +6       ; Correct data not passed in

           IF '$DATA(BARBL)

               IF '$DATA(BARDUZ)

                   QUIT ""

 +7       ; Values must be numeric

           IF '+BARBL

               IF '+BARDUZ

                   QUIT ""

 +8       ; Preserve tmp vars

           NEW BAR3PLOC,BAR3PIEN,BAR3DUZ

 +9       ; Find 3P bill

           SET BAR3PLOC=$$FIND3PB^BARUTL(BARDUZ,BARBL)

 +10      ; 3P DUZ(2)

           SET BAR3DUZ=$PIECE(BAR3PLOC,",")

 +11      ; 3P BILL IEN

           SET BAR3PIEN=$PIECE(BAR3PLOC,",",2)

 +12       IF '+BAR3DUZ

               QUIT ""

 +13       IF 'BAR3PIEN

               QUIT ""

 +14      ; The call below will also set up ABMP array

 +15      ; Subscriber

           SET BARSBR=$$SBR^ABMUTLP(BAR3PIEN,BAR3DUZ)

 +16      ; Relationship

           SET BARREL=ABMP("REL")

 +17      ; fix: added ret value P.OTT

           QUIT BARSBR

 +18      ;start new code IHS/SD/SDR 5/26/09 HEAT4301 BAR*1.8*13

PATCH(PKG,VER) ;EP - returns last patch applied for a Package, PATCH^DATE

 +1       ;        Patch includes Seq # if Released

 +2        NEW PKGIEN,VERIEN,LATEST,PATCH,SUBIEN

 +3        IF $GET(VER)=""

               SET VER=$$VERSION^XPDUTL(PKG)

               IF 'VER

                   QUIT -1

 +4        SET PKGIEN=$ORDER(^DIC(9.4,"B",PKG,""))

           IF 'PKGIEN

               QUIT -1

 +5        SET VERIEN=$ORDER(^DIC(9.4,PKGIEN,22,"B",VER,""))

           IF 'VERIEN

               QUIT -1

 +6        SET LATEST=-1

           SET PATCH=-1

           SET SUBIEN=0

 +7        FOR

               SET SUBIEN=$ORDER(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN))

               IF SUBIEN'>0

                   QUIT

               Begin DoDot:1

 +8                IF $PIECE(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)>LATEST

                       SET LATEST=$PIECE(^(0),U,2)

                       SET PATCH=$PIECE(^(0),U)

 +9                IF $PIECE(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)=LATEST

                       IF $PIECE(^(0),U)>PATCH

                           SET PATCH=$PIECE(^(0),U)

               End DoDot:1

 +10       QUIT PATCH_U_LATEST

 +11      ;end new code HEAT4301 BAR*1.8*13

 +12      ;

 +13      ;New GROUPLAN tag   ;M819*ADD*TMM*20100720

GROUPLAN(BARBL) ;  Return Group Plan (from Employer Group Insurance file)

 +1       ; BARBL = A/B Bill IEN

 +2       ;---A/R Bill file data

 +3        NEW BARACIEN,BARFIND,BARBLINS,BARGPIEN,BARGPNAM,BARGPNUM,BARINSE,BARINSI

 +4        NEW BARLINE,BARPH,BARPHIEN,BARPOLH,BARPOLN,BARTMP,BARTMPBL,BARTMPEG,BARTMPPH

 +5        SET $PIECE(BARLINE,"-",40)=""

 +6       ;A/R Bill - A/R Account IEN

           SET BARACIEN=$$GET1^DIQ(90050.01,BARBL_",",3,"I")

 +7        SET BARBLINS=$$GET1^DIQ(90050.02,BARACIEN_",",.01,"I")

 +8       ;not insurance company

           IF BARBLINS'["AUTNINS"

               QUIT 0_U_"NOT AUTNINS"_U_BARBL

 +9        SET BARINSI=$PIECE(BARBLINS,";",1)

 +10       SET BARINSE=$$GET1^DIQ(9999999.18,BARINSI_",",.01,"E")

 +11      ;Patient IEN

           SET BARPAT=$$GET1^DIQ(90050.01,BARBL_",",101,"I")

 +12       IF BARPAT=""

               SET BARTMP=0_U_"BARPAT"_U_BARBL

               Begin DoDot:1

 +13               IF $GET(DEBUG)

                       Begin DoDot:2

 +14                       WRITE !,"BARBL=",BARBL," Patient (Policy Holder lookup) is null"

 +15                       SET BARTMP=$GET(^TMP($JOB,"BARDRST",BARBL))+1

 +16                       SET ^TMP($JOB,"BARDRST",BARBL,BARTMP)="GRPPLAN_BARUTL^BARBL="_BARBL_"^0|BARPAT is null"_"|"_BARBL

                       End DoDot:2

               End DoDot:1

               QUIT BARTMP

 +17      ;---Policy Holder file data

 +18      ;Policy Holder Name

           SET BARPOLH=$$GET1^DIQ(90050.01,BARBL_",",701,"I")

 +19      ;Policy Number FIXED: P.OTT

           SET BARPOLN=$$GET1^DIQ(90050.01,BARBL_",",702,"I")

 +20       SET BARFIND=0

 +21       SET BARGPIEN=""

 +22       SET BARPH=""

FOR

               SET BARPH=$ORDER(^AUPN3PPH("C",BARPAT,BARPH))

               IF BARPH=""!BARFIND=1

                   QUIT

               Begin DoDot:1

 +23      ;Insurance company from Policy Holder file

                   SET BARPHINS=$$GET1^DIQ(9000003.1,BARPH_",",.03,"I")

 +24               IF BARPHINS'=BARINSI

                       QUIT

 +25               SET BARFIND=1

 +26               SET BARPHIEN=BARPH

 +27      ;group IEN

                   SET BARGPIEN=$$GET1^DIQ(9000003.1,BARPHIEN_",",.06,"I")

               End DoDot:1

 +28       IF 'BARFIND

               QUIT 0_U_"BARFIND"_U_BARBL

 +29      ;---Employer Insurance Group data for this A/R bill

 +30       IF 'BARFIND

               Begin DoDot:1

               End DoDot:1

               QUIT 0_U_"BARFIND^"_BARBL

 +31       IF BARGPIEN=""

               QUIT 0_U_"BARGPIEN"_U_BARBL

 +32      ;group plan name

           SET BARGPNAM=$$GET1^DIQ(9999999.77,BARGPIEN_",",.01,"E")

 +33      ;group plan number

           SET BARGPNUM=$$GET1^DIQ(9999999.77,BARGPIEN_",",.02,"E")

 +34      ;Employer Group data

           SET BARTMPEG=BARGPIEN_"|"_BARGPNUM_"|"_BARGPNAM

 +35      ;Policy Holder data

           SET BARTMPPH=BARPHIEN_"|"_BARPOLH_"|"_BARPHINS_"|"_BARPAT

 +36      ;A/R Bill data

           SET BARTMPBL=BARACIEN_"|"_BARINSI_"|"_BARINSE

 +37       QUIT 1_U_BARTMPEG_U_BARTMPPH_U_BARTMPBL

 +38      ;-----------------EOR------------

BARUTL.m