Routine: BARCLU2

BARCLU2 ; IHS/SD/LSL - ASK MORE QUESTIONS ON A COLLECTION ITEM ;

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4**;OCT 26, 2005

;;

 ;select item

 W $$EN^BARVDF("IOF")

 W !,"MORE FUNCTION - add items that were not asked"

 K DIC

 ; -------------------------------

ITEM ; EP

 D ^XBSFGBL(90051.1101,.DIC)

 S DIC=$P(DIC,"DA,")

 S DIC("W")="D DICW^BARCLU2"

 S DIC("A")="ITEM: "

 S DA(1)=BARCLDA

 S DIC(0)="SMA"

 S DIC("S")="I ""E""[$P(^(0),U,17)"

 S DIC(0)="AEQMZ"

 D ^DIC

 Q:Y'>0

 S BARITDA=+Y

 D BARCLIT^BARCLU

 S BARX=BARCLIT(2,"I")

 D DISPLAY

 S DR=""

 ; -------------------------------

EDITEM ; EP

 ; edit collection item

 K DIE,BARBL

 S DA=BARITDA

 S DA(1)=BARCLDA

 S DIE=BARDIC_BARCLDA_",1,"

 D:BARX=51 EOB

 D:BARX=52 CASH

 D:BARX=53 CC

 D:BARX=55 REFUND

 D:BARX=81 CHECK

 D:BARX=99 GL

 D DISPLAY

 G ITEM

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

CHECK ; EP

 ; for checks

 S:'+BARCLID(12,"I") DR=DR_"12;" ;bk num

 ; -------------------------------

CACC ; EP

 ; for other types

 I BARX=52 S:'+BARCLID(15,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CA

 I BARX=53 S:'+BARCLID(14,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CC

 I BARX=81 S:'+BARCLID(16,"I") DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;" ;bill CK

 K BARBL

 S DIDEL=90050

 D ^DIE

 K DIDEL

 S DR=""

 I '$D(BARBL) D

 .I BARX=52 S:'+BARCLID(18,"I") DR=DR_"5;" ;pat CA

 .I BARX=53 S:'+BARCLID(17,"I") DR=DR_"5;" ;pat CC

 .I BARX=81 S:'+BARCLID(19,"I") DR=DR_"5;" ;pat CK

 I '$D(BARCLIT(301)) S DR=DR_"301;"

 S DIDEL=90050

 D ^DIE

 K DIDEL

 W:DR="" !,"ALL QUESTIONS ALREADY ASKED"

H 5

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

CC ; EP

 ; credit card

 S DR=""

 D CACC

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

GL ; EP

 ; general ledger

 S DR=203

 D CACC

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

REFUND ; EP

 ; refund

 S DR="102;Q;6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;6;5;7;8;Q;"

 S:+BARSPAR(3,"I") DR=DR_"10;"

 S DR=DR_"201//^S X=$G(BARBL(3));301;16//^S X=BARCLID(3)"

 S DIDEL=90050

 D ^DIE

 K DIDEL

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

CASH ; EP

 ; cash col

 S DR=""

 D CACC

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

EOB ; EP

 ; EOB entry

 D PAYOR

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

PAYOR ; EP

 ; ask PAYOR (A/R Account with DISV(screen)

 S DR=""

 S DIE=DIC

 S:'+BARCLID(12,"I") DR=DR_"12;" ;bnk num

 S DR=DR_"10;16;301;" ;i/o pat,auto print,comment

 S DIDEL=90050

 D ^DIE

 K DIDEL

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

DISPLAY ; EP

 ; display item elements

 D BARCLIT^BARCLU

 ;IHS/SD/AML 11/26/07 - Print treasury dep number

FLDS ;;203;GENERAL LEDGER^11;CHECK NUMBER^12;BANK NUMBER^13;CC NUMBER^14;CC VER NUMBER^101;AMOUNT PAID^102;REFUND^7;A/R ACCOUNT^201;PAYOR^8;LOCATION OF SERVICE^10;INPAT/OUTPAT^5;PATIENT^6;BILL^16;AUTO PRINT^20;TREASURY DEPOSIT/IPAC #

 S BARY=$P($T(FLDS),";;",2)

 W $$EN^BARVDF("IOF")

 W !,BARCL(.01)

 W ?22,"ITEM: ",BARITDA

 W "    TYPE: ",BARCLIT(2)

 W ?54,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15)

W !

 F BARI=1:1:70 W "="

 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)

 W ! F BARI=1:1:70 W "="

W !

 K BARY,BARI,BARNM,BARFLD

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

END ;

DICW ; EP

 ; help display on Item lookup

 D ^XBNEW("DICW1^BARCLU2:Y;BARCL*")

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

DICW1  ;EP

 K BARCLIT

 N DIC,DA,DR,DIQ

 Q:'+Y

 S DA=+Y

N Y

 S DIQ="BARCLIT("

 S DIQ(0)="I"

 S DIC=90051.1101

 S DA(1)=BARCLDA

 S DR="2;2.5;7;11;101"

 D EN^XBDIQ1

 W ?7,$J($E(BARCLIT(11),1,9),10)

 W:$L(BARCLIT(11))>9 "*"

 W ?18,$J(BARCLIT(101),8,2),?28,BARCLIT(7),?58,$E(BARCLIT(2.5),1,2)

EDICW ;

BARCLU2   ; IHS/SD/LSL - ASK MORE QUESTIONS ON A COLLECTION ITEM ;

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**4**;OCT 26, 2005

 +2       ;;

 +3       ;select item

 +4        WRITE $$EN^BARVDF("IOF")

 +5        WRITE !,"MORE FUNCTION - add items that were not asked"

 +6        KILL DIC

 +7       ; -------------------------------

 +8       ;

ITEM      ; EP

 +1        DO ^XBSFGBL(90051.1101,.DIC)

 +2        SET DIC=$PIECE(DIC,"DA,")

 +3        SET DIC("W")="D DICW^BARCLU2"

 +4        SET DIC("A")="ITEM: "

 +5        SET DA(1)=BARCLDA

 +6        SET DIC(0)="SMA"

 +7        SET DIC("S")="I ""E""[$P(^(0),U,17)"

 +8        SET DIC(0)="AEQMZ"

 +9        DO ^DIC

 +10       IF Y'>0

               QUIT

 +11       SET BARITDA=+Y

 +12       DO BARCLIT^BARCLU

 +13       SET BARX=BARCLIT(2,"I")

 +14       DO DISPLAY

 +15       SET DR=""

 +16      ; -------------------------------

 +17      ;

EDITEM    ; EP

 +1       ; edit collection item

 +2        KILL DIE,BARBL

 +3        SET DA=BARITDA

 +4        SET DA(1)=BARCLDA

 +5        SET DIE=BARDIC_BARCLDA_",1,"

 +6        IF BARX=51

               DO EOB

 +7        IF BARX=52

               DO CASH

 +8        IF BARX=53

               DO CC

 +9        IF BARX=55

               DO REFUND

 +10       IF BARX=81

               DO CHECK

 +11       IF BARX=99

               DO GL

 +12       DO DISPLAY

 +13       GOTO ITEM

 +14      ; *********************************************************************

 +15      ;

CHECK     ; EP

 +1       ; for checks

 +2       ;bk num

           IF '+BARCLID(12,"I")

               SET DR=DR_"12;"

 +3       ; -------------------------------

 +4       ;

CACC      ; EP

 +1       ; for other types

 +2       ;bill CA

           IF BARX=52

               IF '+BARCLID(15,"I")

                   SET DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;"

 +3       ;bill CC

           IF BARX=53

               IF '+BARCLID(14,"I")

                   SET DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;"

 +4       ;bill CK

           IF BARX=81

               IF '+BARCLID(16,"I")

                   SET DR=DR_"6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;"

 +5        KILL BARBL

 +6        SET DIDEL=90050

 +7        DO ^DIE

 +8        KILL DIDEL

 +9        SET DR=""

 +10       IF '$DATA(BARBL)

               Begin DoDot:1

 +11      ;pat CA

                   IF BARX=52

                       IF '+BARCLID(18,"I")

                           SET DR=DR_"5;"

 +12      ;pat CC

                   IF BARX=53

                       IF '+BARCLID(17,"I")

                           SET DR=DR_"5;"

 +13      ;pat CK

                   IF BARX=81

                       IF '+BARCLID(19,"I")

                           SET DR=DR_"5;"

               End DoDot:1

 +14       IF '$DATA(BARCLIT(301))

               SET DR=DR_"301;"

 +15       SET DIDEL=90050

 +16       DO ^DIE

 +17       KILL DIDEL

 +18       IF DR=""

               WRITE !,"ALL QUESTIONS ALREADY ASKED"

 +19       HANG 5

 +20       QUIT

 +21      ; *********************************************************************

 +22      ;

CC        ; EP

 +1       ; credit card

 +2        SET DR=""

 +3        DO CACC

 +4        QUIT

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

 +6       ;

GL        ; EP

 +1       ; general ledger

 +2        SET DR=203

 +3        DO CACC

 +4        QUIT

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

 +6       ;

REFUND    ; EP

 +1       ; refund

 +2        SET DR="102;Q;6///^S X="""" D ^BARBLLK S:$D(BARBL)>1 X=BARBL(.01);Q;6;5;7;8;Q;"

 +3        IF +BARSPAR(3,"I")

               SET DR=DR_"10;"

 +4        SET DR=DR_"201//^S X=$G(BARBL(3));301;16//^S X=BARCLID(3)"

 +5        SET DIDEL=90050

 +6        DO ^DIE

 +7        KILL DIDEL

 +8        QUIT

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

 +10      ;

CASH      ; EP

 +1       ; cash col

 +2        SET DR=""

 +3        DO CACC

 +4        QUIT

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

 +6       ;

EOB       ; EP

 +1       ; EOB entry

 +2        DO PAYOR

 +3        QUIT

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

 +5       ;

PAYOR     ; EP

 +1       ; ask PAYOR (A/R Account with DISV(screen)

 +2        SET DR=""

 +3        SET DIE=DIC

 +4       ;bnk num

           IF '+BARCLID(12,"I")

               SET DR=DR_"12;"

 +5       ;i/o pat,auto print,comment

           SET DR=DR_"10;16;301;"

 +6        SET DIDEL=90050

 +7        DO ^DIE

 +8        KILL DIDEL

 +9        QUIT

 +10      ; *********************************************************************

 +11      ;

DISPLAY   ; EP

 +1       ; display item elements

 +2        DO BARCLIT^BARCLU

 +3       ;IHS/SD/AML 11/26/07 - Print treasury dep number

FLDS      ;;203;GENERAL LEDGER^11;CHECK NUMBER^12;BANK NUMBER^13;CC NUMBER^14;CC VER NUMBER^101;AMOUNT PAID^102;REFUND^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       ;

 +2        SET BARY=$PIECE($TEXT(FLDS),";;",2)

 +3        WRITE $$EN^BARVDF("IOF")

 +4        WRITE !,BARCL(.01)

 +5        WRITE ?22,"ITEM: ",BARITDA

 +6        WRITE "    TYPE: ",BARCLIT(2)

 +7        WRITE ?54,"BATCH TOTAL: ",$$GET1^DIQ(90051.01,BARCLDA,15)

 +8        WRITE !

 +9        FOR BARI=1:1:70

               WRITE "="

 +10       FOR BARI=1:1

               SET BARE=$PIECE(BARY,U,BARI)

               IF BARE=""

                   QUIT

               Begin DoDot:1

 +11               SET BARFLD=+BARE

 +12               SET BARNM=$PIECE(BARE,";",2)

 +13               IF $GET(BARCLIT(BARFLD))]""

                       WRITE !?5,BARNM,?30,BARCLIT(BARFLD)

               End DoDot:1

 +14       IF $DATA(BARCLIT(301))

               Begin DoDot:1

 +15               WRITE !,"COMMENTS"

 +16               FOR BARI=1:1

                       IF '$DATA(BARCLIT(301,BARI))

                           QUIT

                       WRITE !,?3,BARCLIT(301,BARI)

               End DoDot:1

 +17       WRITE !

           FOR BARI=1:1:70

               WRITE "="

 +18       WRITE !

 +19       KILL BARY,BARI,BARNM,BARFLD

 +20       QUIT

 +21      ; *********************************************************************

 +22      ;

END       ;

DICW      ; EP

 +1       ; help display on Item lookup

 +2        DO ^XBNEW("DICW1^BARCLU2:Y;BARCL*")

 +3        QUIT

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

 +5       ;

DICW1     ;EP

 +1        KILL BARCLIT

 +2        NEW DIC,DA,DR,DIQ

 +3        IF '+Y

               QUIT

 +4        SET DA=+Y

 +5        NEW Y

 +6        SET DIQ="BARCLIT("

 +7        SET DIQ(0)="I"

 +8        SET DIC=90051.1101

 +9        SET DA(1)=BARCLDA

 +10       SET DR="2;2.5;7;11;101"

 +11       DO EN^XBDIQ1

 +12       WRITE ?7,$JUSTIFY($EXTRACT(BARCLIT(11),1,9),10)

 +13       IF $LENGTH(BARCLIT(11))>9

               WRITE "*"

 +14       WRITE ?18,$JUSTIFY(BARCLIT(101),8,2),?28,BARCLIT(7),?58,$EXTRACT(BARCLIT(2.5),1,2)

 +15      ;

EDICW     ;

 +1        QUIT

BARCLU2.m