Routine: BARPUCU

BARPUCU ; IHS/SD/LSL - UNALLOCATED COMMAND PROCESSOR ; 06/09/2008

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4,6,19,21**;OCT 26, 2005

 ;** posting utilities

 ; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA

 ;     Don't allow updating of other files if Adjustment Category

 ;     is PENDING or GENERAL INFORMATION.

 ; IHS/SD/LSL - 11/27/02 - V1.7 - QAA-1200-130051

 ;     Added quit logic if error in creating a transaction

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

AMT(X,BARMIN,BARMAX) ;EP - ** number function

 ;** quits with "^" to exit

 ;** quits with "?" for incorrect entry

 I '$D(X) Q "^"

 I X["^"!('$L(X)) Q "^"

 S:X["$" X=$P(X,"$",2)

 I X'?."-".N.1".".2N Q "?"

 I $D(BARMIN),X<BARMIN Q "?"

 I $D(BARMAX),X>BARMAX Q "?"

Q X

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

COMHLP ;EP - help display

 N X,J

 W $$EN^BARVDF("IOF"),!!

 S X="Select Command Options"

 W ?IOM-$L(X)\2,X

 W !?IOM-$L(X)\2 F J=1:1:$L(X) W "-"

 W !!

 D:$D(BARHLP)<10 SETHLP

 S J=""

 F  S J=$O(BARHLP(J)) Q:J=""  W !?2,BARHLP(J)

 W !!

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

SETHLP ;EP - set help

 S BARHLP("A")="A = Adjustments (Write-Off, Deductible, Non-Covered, Non-Pay, Penalty)"

 S BARHLP("C")="C = Itemized Charges - allows posting by line item"

 S BARHLP("D")="D = Patient Demographics"

 S BARHLP("E")="E = Edit a transaction not yet posted to A/R"

 S BARHLP("I")="I = Insurer Demographics"

 S BARHLP("H")="H = History of Bill Transactions ($ only)"

 S BARHLP("M")="M = Message"

 S BARHLP("P")="P = Payments"

 S BARHLP("Q")="Q = Quit - Ends the data entry for this Patient and allows for posting to A/R"

 S BARHLP("R")="R = Rollover"

 S BARHLP("T")="T = Toggle Display - Current transaction list."

 ; IHS/SD/PKD 1.8*19 change spelling

 ;S BARHLP("B")="B = Bill Enquire"

 S BARHLP("B")="B = Bill Inquire"

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

POSTTX ;EP - poster

 ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490

 I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) Q  ;IS SESSION STILL OPEN

 W !!,"Please wait... Posting Transactions."

 K DD,DO,BARBLV

 N DA,DR,DIE,DIC,DIQ,BARTT,BARZZZZ

 S BARAC=BARTX(6,"I")

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

 S DIC(0)="L"

 S BARLIN=0

 F  S BARLIN=$O(BARTR(BARLIN)) Q:'BARLIN  D

 . S BARBDFN=$O(^BARTMP($J,"B",BARLIN,""))

 . S BARROLL(BARBDFN)=""

 . S BARBLV(15)=$$GET1^DIQ(90050.01,BARBDFN,15,"I")

 . S BARCOL=BARTX(14,"I")                 ;BAR*1.8*6 DD 4.2.5

 . S BARITM=BARTX(15)                     ;BAR*1.8*6 DD 4.2.5

 . S BARZZZZ=1     ;DON'T CHECK BATCH/ITEM;BAR*1.8*6 DD 4.2.5

 . D CKBAL^BARPSTU(BARLIN,BARBLV(15))     ;BAR*1.8*4 DD 4.1.7.2

 . Q:BARSTOP                              ;BAR*1.8*4 DD 4.1.7.2

 . S (BARBTOT,BARJ)=0

 . F  S BARJ=$O(BARTR(BARLIN,BARJ)) Q:'BARJ  D

 .. S BARREC=BARTR(BARLIN,BARJ)

 .. S BARTXT=$P(BARREC,U,1)

 .. S BARAMT=$P(BARREC,U,2)

 .. Q:+BARAMT=0

 .. S BARBTOT=BARBTOT+BARAMT

 .. S BARCAT=$P(BARREC,U,3)

 .. I BARTXT="P" D

 ... S BARTT=$O(^BARTBL("B","PAYMENT",""))

 ... S BARUCAC=$$GET1^DIQ(90050.03,+BARTX("ID"),6,"I")

 ... Q:'BARUCAC

 ... S BARBLV(304)=$$GET1^DIQ(90050.02,BARUCAC,304,"I")

 ... S DA=BARUCAC

 ... S DR="304////^S X=BARBLV(304)-BARAMT"

 ... S DIE="^BARAC(DUZ(2),"

 ... S DIDEL=90050

 ... D ^DIE

 ... K DIDEL

 .. S:BARTXT="A" BARTT=$O(^BARTBL("B","ADJUST ACCOUNT",""))

 .. S BARATYP=$P(BARREC,U,4)

 .. D P1

 .K ^BARTMP($J,BARBDFN)

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

FINISH ;

 Q:BARSTOP                            ;BAR*1.8*4 DD 4.1.7.2

 K DR,DIC

 I (+BARTX(2,"I"))-(+BARPMT)'=0 D  G CLOSE

 . D ENP^XBDIQ1("^BARTR(DUZ(2),",+BARTX("ID"),"6;8;10;11;14;15;101;104;105","BARSIB(","0I")

 . S BARREM=(+BARTX(2,"I"))-(+BARPMT)

 . S DIC="^BARTR(DUZ(2),"

 . S DIC(0)="L"

 . S DLAYGO=90050

 . L +^BARTR(DUZ(2)):2 F  D NOW^%DTC S X=% I '$D(^BARTR(DUZ(2),"B",X)) L -^BARTR(DUZ(2)) D ^DIC K DLAYGO Q

 . S BARSIB=+Y

 . I BARSIB<1 D  G FINISH

 . . W !,"Couldn't create a new UN-ALLOCATED transaction.  The system is trying again.",!

 . S DA=BARSIB

 . S DIE="^BARTR(DUZ(2),"

 . S DR="2////^S X=BARREM"

 . S DR=DR_";12////^S X=DT"

 . S DR=DR_";13////^S X=DUZ"

 . S DR=DR_";201////^S X=+BARTX(""ID"")"

 . S DR=DR_";6////^S X=BARSIB(6,""I"")"

 . S DR=DR_";8////^S X=BARSIB(8,""I"")"

 . S DR=DR_";10////^S X=BARSIB(10,""I"")"

 . S DR=DR_";11////^S X=BARSIB(11,""I"")"

 . S DR=DR_";14////^S X=BARSIB(14,""I"")"

 . S DR=DR_";15////^S X=BARSIB(15,""I"")"

 . S DR=DR_";101////^S X=BARSIB(101,""I"")"

 . S DR=DR_";104////^S X=BARSIB(104,""I"")"

 . S DR=DR_";105////^S X=BARSIB(105,""I"")"

 . S DIDEL=90050

 . D ^DIE

 . K DIDEL

 . S DIE="^BARTR(DUZ(2),"

 . S DR="2////^S X=BARPMT"

 . S DR=DR_";105////^S X=""R"""

 . S DR=DR_";202////^S X=+BARSIB"

 . S DA=+BARTX("ID")

 . S DIDEL=90050

 . D ^DIE

 . K DIDEL

. Q

 I (+BARTX(2,"I"))-(+BARPMT)=0 D

 . S DIE="^BARTR(DUZ(2),"

 . S DR="105////^S X=""R"""

 . S DA=+BARTX("ID")

 . S DIDEL=90050

 . D ^DIE

 . K DIDEL

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

CLOSE ;

 ;K ^BARTMP($J)

 K BARTX,BARREM,BARSIB,BARTR,BARPMT,BARADJ,BARCAT,BARATYP,BARBTOT,BARBLV

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

P1 ;

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

 S DIC(0)="L"

 S BARCR=$S(+BARAMT>0:BARAMT,1:"")

 S BARDB=$S(+BARAMT<0:BARAMT,1:"")

 S BARDB=-BARDB

 S BARPT=+BARPAT

 K BARCOL

 D ENP^XBDIQ1("^BARCOL(DUZ(2),",BARTX(14,"I"),"8;9;10","BARCOL(","0I")

 S BARPAR=BARCOL(8,"I")

 S BARASFAC=BARCOL(9,"I")

 S BARSECT=BARCOL(10,"I")

 S DA=BARTX(15,"I")

 S DA(1)=BARTX(14,"I")

 S BARSITE=$$GET1^DIQ(90051.1101,.DA,8,"I")

PX ;

 S X=$$NEW^BARTR

 S BARTRIEN=X

 I X<1 D MSG^BARTR(BARBDFN) Q

 S DA=X

 S DIE=90050.03

 S DR="2////^S X=BARCR"

 S DR=DR_";3////^S X=BARDB"

 S DR=DR_";4////^S X=BARBDFN"

 S DR=DR_";5////^S X=BARPT"

 S DR=DR_";6////^S X=BARAC"

 S DR=DR_";8////^S X=BARPAR"

 S DR=DR_";9////^S X=BARASFAC"

 S DR=DR_";10////^S X=BARSECT"

 S DR=DR_";11////^S X=BARSITE"

 S DR=DR_";12////^S X=DT"

 S DR=DR_";14////^S X=BARTX(14,""I"")"

 S DR=DR_";15////^S X=BARTX(15,""I"")"

 S DR=DR_";13////^S X=DUZ"

 S DR=DR_";101////^S X=BARTT"

 I BARTXT="A" D

 . S DR=DR_";102////^S X=BARCAT"

 . S DR=DR_";103////^S X=BARATYP"

 I BARTXT="P" S DR=DR_";201////^S X=+BARTX(""ID"")"

 S DR=DR_";10////^S X=$$VALI^XBDIQ1(200,DUZ,29)"

 S DIDEL=90050

 D ^DIE

 K DIDEL

 I ",21,22,"[(","_BARCAT_",") Q

 D TR^BARTDO(BARTRIEN)

 W "."

DONE ;

BARPUCU   ; IHS/SD/LSL - UNALLOCATED COMMAND PROCESSOR ; 06/09/2008

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

 +2       ;** posting utilities

 +3       ;

 +4       ; IHS/SD/LSL - 09/23/02 - V1.6 Patch 3 - HIPAA

 +5       ;     Don't allow updating of other files if Adjustment Category

 +6       ;     is PENDING or GENERAL INFORMATION.

 +7       ;

 +8       ; IHS/SD/LSL - 11/27/02 - V1.7 - QAA-1200-130051

 +9       ;     Added quit logic if error in creating a transaction

 +10      ;

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

 +12       QUIT

 +13      ;

AMT(X,BARMIN,BARMAX) ;EP - ** number function

 +1       ;** quits with "^" to exit

 +2       ;** quits with "?" for incorrect entry

 +3        IF '$DATA(X)

               QUIT "^"

 +4        IF X["^"!('$LENGTH(X))

               QUIT "^"

 +5        IF X["$"

               SET X=$PIECE(X,"$",2)

 +6        IF X'?."-".N.1".".2N

               QUIT "?"

 +7        IF $DATA(BARMIN)

               IF X<BARMIN

                   QUIT "?"

 +8        IF $DATA(BARMAX)

               IF X>BARMAX

                   QUIT "?"

 +9        QUIT X

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

 +11      ;

COMHLP    ;EP - help display

 +1        NEW X,J

 +2        WRITE $$EN^BARVDF("IOF"),!!

 +3        SET X="Select Command Options"

 +4        WRITE ?IOM-$LENGTH(X)\2,X

 +5        WRITE !?IOM-$LENGTH(X)\2

           FOR J=1:1:$LENGTH(X)

               WRITE "-"

 +6        WRITE !!

 +7        IF $DATA(BARHLP)<10

               DO SETHLP

 +8        SET J=""

 +9        FOR

               SET J=$ORDER(BARHLP(J))

               IF J=""

                   QUIT

               WRITE !?2,BARHLP(J)

 +10       WRITE !!

 +11       QUIT

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

 +13      ;

SETHLP    ;EP - set help

 +1        SET BARHLP("A")="A = Adjustments (Write-Off, Deductible, Non-Covered, Non-Pay, Penalty)"

 +2        SET BARHLP("C")="C = Itemized Charges - allows posting by line item"

 +3        SET BARHLP("D")="D = Patient Demographics"

 +4        SET BARHLP("E")="E = Edit a transaction not yet posted to A/R"

 +5        SET BARHLP("I")="I = Insurer Demographics"

 +6        SET BARHLP("H")="H = History of Bill Transactions ($ only)"

 +7        SET BARHLP("M")="M = Message"

 +8        SET BARHLP("P")="P = Payments"

 +9        SET BARHLP("Q")="Q = Quit - Ends the data entry for this Patient and allows for posting to A/R"

 +10       SET BARHLP("R")="R = Rollover"

 +11       SET BARHLP("T")="T = Toggle Display - Current transaction list."

 +12      ; IHS/SD/PKD 1.8*19 change spelling

 +13      ;S BARHLP("B")="B = Bill Enquire"

 +14       SET BARHLP("B")="B = Bill Inquire"

 +15       QUIT

 +16      ; *********************************************************************

 +17      ;

POSTTX    ;EP - poster

 +1       ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490

 +2       ;IS SESSION STILL OPEN

           IF $$NOTOPEN^BARUFUT(.DUZ,$GET(UFMSESID))

               QUIT

 +3        WRITE !!,"Please wait... Posting Transactions."

 +4        KILL DD,DO,BARBLV

 +5        NEW DA,DR,DIE,DIC,DIQ,BARTT,BARZZZZ

 +6        SET BARAC=BARTX(6,"I")

 +7        SET DIC="^BARTR(DUZ(2),"

 +8        SET DIC(0)="L"

 +9        SET BARLIN=0

 +10       FOR

               SET BARLIN=$ORDER(BARTR(BARLIN))

               IF 'BARLIN

                   QUIT

               Begin DoDot:1

 +11               SET BARBDFN=$ORDER(^BARTMP($JOB,"B",BARLIN,""))

 +12               SET BARROLL(BARBDFN)=""

 +13               SET BARBLV(15)=$$GET1^DIQ(90050.01,BARBDFN,15,"I")

 +14      ;BAR*1.8*6 DD 4.2.5

                   SET BARCOL=BARTX(14,"I")

 +15      ;BAR*1.8*6 DD 4.2.5

                   SET BARITM=BARTX(15)

 +16      ;DON'T CHECK BATCH/ITEM;BAR*1.8*6 DD 4.2.5

                   SET BARZZZZ=1

 +17      ;BAR*1.8*4 DD 4.1.7.2

                   DO CKBAL^BARPSTU(BARLIN,BARBLV(15))

 +18      ;BAR*1.8*4 DD 4.1.7.2

                   IF BARSTOP

                       QUIT

 +19               SET (BARBTOT,BARJ)=0

 +20               FOR

                       SET BARJ=$ORDER(BARTR(BARLIN,BARJ))

                       IF 'BARJ

                           QUIT

                       Begin DoDot:2

 +21                       SET BARREC=BARTR(BARLIN,BARJ)

 +22                       SET BARTXT=$PIECE(BARREC,U,1)

 +23                       SET BARAMT=$PIECE(BARREC,U,2)

 +24                       IF +BARAMT=0

                               QUIT

 +25                       SET BARBTOT=BARBTOT+BARAMT

 +26                       SET BARCAT=$PIECE(BARREC,U,3)

 +27                       IF BARTXT="P"

                               Begin DoDot:3

 +28                               SET BARTT=$ORDER(^BARTBL("B","PAYMENT",""))

 +29                               SET BARUCAC=$$GET1^DIQ(90050.03,+BARTX("ID"),6,"I")

 +30                               IF 'BARUCAC

                                       QUIT

 +31                               SET BARBLV(304)=$$GET1^DIQ(90050.02,BARUCAC,304,"I")

 +32                               SET DA=BARUCAC

 +33                               SET DR="304////^S X=BARBLV(304)-BARAMT"

 +34                               SET DIE="^BARAC(DUZ(2),"

 +35                               SET DIDEL=90050

 +36                               DO ^DIE

 +37                               KILL DIDEL

                               End DoDot:3

 +38                       IF BARTXT="A"

                               SET BARTT=$ORDER(^BARTBL("B","ADJUST ACCOUNT",""))

 +39                       SET BARATYP=$PIECE(BARREC,U,4)

 +40                       DO P1

                       End DoDot:2

 +41               KILL ^BARTMP($JOB,BARBDFN)

               End DoDot:1

 +42      ; -------------------------------

 +43      ;

FINISH    ;

 +1       ;BAR*1.8*4 DD 4.1.7.2

           IF BARSTOP

               QUIT

 +2        KILL DR,DIC

 +3        IF (+BARTX(2,"I"))-(+BARPMT)'=0

               Begin DoDot:1

 +4                DO ENP^XBDIQ1("^BARTR(DUZ(2),",+BARTX("ID"),"6;8;10;11;14;15;101;104;105","BARSIB(","0I")

 +5                SET BARREM=(+BARTX(2,"I"))-(+BARPMT)

 +6                SET DIC="^BARTR(DUZ(2),"

 +7                SET DIC(0)="L"

 +8                SET DLAYGO=90050

 +9                LOCK +^BARTR(DUZ(2)):2

FOR

                       DO NOW^%DTC

                       SET X=%

                       IF '$DATA(^BARTR(DUZ(2),"B",X))

                           LOCK -^BARTR(DUZ(2))

                           DO ^DIC

                           KILL DLAYGO

                           QUIT

 +10               SET BARSIB=+Y

 +11               IF BARSIB<1

                       Begin DoDot:2

 +12                       WRITE !,"Couldn't create a new UN-ALLOCATED transaction.  The system is trying again.",!

                       End DoDot:2

                       GOTO FINISH

 +13               SET DA=BARSIB

 +14               SET DIE="^BARTR(DUZ(2),"

 +15               SET DR="2////^S X=BARREM"

 +16               SET DR=DR_";12////^S X=DT"

 +17               SET DR=DR_";13////^S X=DUZ"

 +18               SET DR=DR_";201////^S X=+BARTX(""ID"")"

 +19               SET DR=DR_";6////^S X=BARSIB(6,""I"")"

 +20               SET DR=DR_";8////^S X=BARSIB(8,""I"")"

 +21               SET DR=DR_";10////^S X=BARSIB(10,""I"")"

 +22               SET DR=DR_";11////^S X=BARSIB(11,""I"")"

 +23               SET DR=DR_";14////^S X=BARSIB(14,""I"")"

 +24               SET DR=DR_";15////^S X=BARSIB(15,""I"")"

 +25               SET DR=DR_";101////^S X=BARSIB(101,""I"")"

 +26               SET DR=DR_";104////^S X=BARSIB(104,""I"")"

 +27               SET DR=DR_";105////^S X=BARSIB(105,""I"")"

 +28               SET DIDEL=90050

 +29               DO ^DIE

 +30               KILL DIDEL

 +31               SET DIE="^BARTR(DUZ(2),"

 +32               SET DR="2////^S X=BARPMT"

 +33               SET DR=DR_";105////^S X=""R"""

 +34               SET DR=DR_";202////^S X=+BARSIB"

 +35               SET DA=+BARTX("ID")

 +36               SET DIDEL=90050

 +37               DO ^DIE

 +38               KILL DIDEL

 +39               QUIT

               End DoDot:1

               GOTO CLOSE

 +40       IF (+BARTX(2,"I"))-(+BARPMT)=0

               Begin DoDot:1

 +41               SET DIE="^BARTR(DUZ(2),"

 +42               SET DR="105////^S X=""R"""

 +43               SET DA=+BARTX("ID")

 +44               SET DIDEL=90050

 +45               DO ^DIE

 +46               KILL DIDEL

               End DoDot:1

 +47      ; -------------------------------

 +48      ;

CLOSE     ;

 +1       ;K ^BARTMP($J)

 +2        KILL BARTX,BARREM,BARSIB,BARTR,BARPMT,BARADJ,BARCAT,BARATYP,BARBTOT,BARBLV

 +3        QUIT

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

 +5       ;

P1        ;

 +1        SET DIC="^BARTR(DUZ(2),"

 +2        SET DIC(0)="L"

 +3        SET BARCR=$SELECT(+BARAMT>0:BARAMT,1:"")

 +4        SET BARDB=$SELECT(+BARAMT<0:BARAMT,1:"")

 +5        SET BARDB=-BARDB

 +6        SET BARPT=+BARPAT

 +7        KILL BARCOL

 +8        DO ENP^XBDIQ1("^BARCOL(DUZ(2),",BARTX(14,"I"),"8;9;10","BARCOL(","0I")

 +9        SET BARPAR=BARCOL(8,"I")

 +10       SET BARASFAC=BARCOL(9,"I")

 +11       SET BARSECT=BARCOL(10,"I")

 +12       SET DA=BARTX(15,"I")

 +13       SET DA(1)=BARTX(14,"I")

 +14       SET BARSITE=$$GET1^DIQ(90051.1101,.DA,8,"I")

PX        ;

 +1        SET X=$$NEW^BARTR

 +2        SET BARTRIEN=X

 +3        IF X<1

               DO MSG^BARTR(BARBDFN)

               QUIT

 +4        SET DA=X

 +5        SET DIE=90050.03

 +6        SET DR="2////^S X=BARCR"

 +7        SET DR=DR_";3////^S X=BARDB"

 +8        SET DR=DR_";4////^S X=BARBDFN"

 +9        SET DR=DR_";5////^S X=BARPT"

 +10       SET DR=DR_";6////^S X=BARAC"

 +11       SET DR=DR_";8////^S X=BARPAR"

 +12       SET DR=DR_";9////^S X=BARASFAC"

 +13       SET DR=DR_";10////^S X=BARSECT"

 +14       SET DR=DR_";11////^S X=BARSITE"

 +15       SET DR=DR_";12////^S X=DT"

 +16       SET DR=DR_";14////^S X=BARTX(14,""I"")"

 +17       SET DR=DR_";15////^S X=BARTX(15,""I"")"

 +18       SET DR=DR_";13////^S X=DUZ"

 +19       SET DR=DR_";101////^S X=BARTT"

 +20       IF BARTXT="A"

               Begin DoDot:1

 +21               SET DR=DR_";102////^S X=BARCAT"

 +22               SET DR=DR_";103////^S X=BARATYP"

               End DoDot:1

 +23       IF BARTXT="P"

               SET DR=DR_";201////^S X=+BARTX(""ID"")"

 +24       SET DR=DR_";10////^S X=$$VALI^XBDIQ1(200,DUZ,29)"

 +25       SET DIDEL=90050

 +26       DO ^DIE

 +27       KILL DIDEL

 +28       IF ",21,22,"[(","_BARCAT_",")

               QUIT

 +29       DO TR^BARTDO(BARTRIEN)

 +30       WRITE "."

DONE      ;

 +1        QUIT

BARPUCU.m