Routine: BARPNPU

BARPNPU ; IHS/SD/LSL - POSTING TRANSACTIONS ; 04/30/2008

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**4**;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/26/02 - V1.7 - QAA-1200-130051

 ;     Modified to q if error in creating a new transaction.

 ; IHS/SD/LSL- 02/20/04 - V1.7 Patch 5 - IM12695

 ;     Resolve <UNDEF>*XECUTE*F+2^DIED

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

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 driver

 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 or 2 = Adjustments (Write-Off, Deductible, Non-Covered, Non-Pay, Penalty)"

 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("Q")="Q or 3 = Quit - Ends the data entry for this Patient and allows for posting to A/R"

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

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

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

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

POSTTX ;EP - poster  ;NO LONGER USED, CALL IS TO POSTTX^BARPSTU ;BAR*1.8*4 DD 4.1.7.2

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

 K DD,DO,BARBLV

 N DA,DR,DIE,DIC,DIQ

 S BARLIN=0

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

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

 . S BARROLL(BARBDFN)=""

 . S BARAC=$$GET1^DIQ(90050.01,BARBDFN,3,"I")

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

 . 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  DO

 .. S BARREC=BARTR(BARLIN,BARJ)

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

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

 .. S BARBTOT=BARBTOT+BARAMT

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

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

 .. S:BARTXT="R" BARTT=$O(^BARTBL("B","REFUND",""))

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

 .. D P1

 .K ^BARTMP($J,BARDA)             ;BAR*1.8*4 DD 4.1.7.2

 .K BARTR(BARLIN),BARPMT,BARADJ,BARCAT,BARATYP,BARBTOT,BARBLV  ;BAR*1.8*4 DD 4.1.7.2

 ;K ^BARTMP($J)                   ;BAR*1.8*4 DD 4.1.7.2

 ;K BARTR,BARPMT,BARADJ,BARCAT,BARATYP,BARBTOT,BARBLV   ;BAR*1.8*4 DD 4.1.7.2

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

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

 S BARPAR=""

 S BARASFAC=""

 S BARSECT=""

 S BARSITE=""

PX ;

 S X=$$NEW^BARTR

 S BARTRIEN=X

 I X<0 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_";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"

 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 ;

BARPNPU   ; IHS/SD/LSL - POSTING TRANSACTIONS ; 04/30/2008

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**4**;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 is

 +6       ;     PENDING or GENERAL INFORMATION

 +7       ;

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

 +9       ;     Modified to q if error in creating a new transaction.

 +10      ;

 +11      ; IHS/SD/LSL- 02/20/04 - V1.7 Patch 5 - IM12695

 +12      ;     Resolve <UNDEF>*XECUTE*F+2^DIED

 +13      ;

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

 +15       QUIT

 +16      ;

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 driver

 +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 or 2 = Adjustments (Write-Off, Deductible, Non-Covered, Non-Pay, Penalty)"

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

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

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

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

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

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

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

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

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

 +3        QUIT

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

 +5       ;

POSTTX    ;EP - poster  ;NO LONGER USED, CALL IS TO POSTTX^BARPSTU ;BAR*1.8*4 DD 4.1.7.2

 +1        QUIT

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

 +3        KILL DD,DO,BARBLV

 +4        NEW DA,DR,DIE,DIC,DIQ

 +5        SET BARLIN=0

 +6        FOR

               SET BARLIN=$ORDER(BARTR(BARLIN))

               IF 'BARLIN

                   QUIT

               Begin DoDot:1

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

 +8                SET BARROLL(BARBDFN)=""

 +9                SET BARAC=$$GET1^DIQ(90050.01,BARBDFN,3,"I")

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

 +11      ;BAR*1.8*4 DD 4.1.7.2

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

 +12      ;BAR*1.8*4 DD 4.1.7.2

                   IF BARSTOP

                       QUIT

 +13               SET (BARBTOT,BARJ)=0

 +14               FOR

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

                       IF 'BARJ

                           QUIT

                       Begin DoDot:2

 +15                       SET BARREC=BARTR(BARLIN,BARJ)

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

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

 +18                       SET BARBTOT=BARBTOT+BARAMT

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

 +20                       IF BARTXT="A"

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

 +21                       IF BARTXT="R"

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

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

 +23                       DO P1

                       End DoDot:2

 +24      ;BAR*1.8*4 DD 4.1.7.2

                   KILL ^BARTMP($JOB,BARDA)

 +25      ;BAR*1.8*4 DD 4.1.7.2

                   KILL BARTR(BARLIN),BARPMT,BARADJ,BARCAT,BARATYP,BARBTOT,BARBLV

               End DoDot:1

 +26      ;K ^BARTMP($J)                   ;BAR*1.8*4 DD 4.1.7.2

 +27      ;K BARTR,BARPMT,BARADJ,BARCAT,BARATYP,BARBTOT,BARBLV   ;BAR*1.8*4 DD 4.1.7.2

 +28       QUIT

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

 +30      ;

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        SET BARPAR=""

 +8        SET BARASFAC=""

 +9        SET BARSECT=""

 +10       SET BARSITE=""

PX        ;

 +1        SET X=$$NEW^BARTR

 +2        SET BARTRIEN=X

 +3        IF X<0

               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_";13////^S X=DUZ"

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

 +18       IF BARTXT="A"

               Begin DoDot:1

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

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

               End DoDot:1

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

 +22       SET DIDEL=90050

 +23       DO ^DIE

 +24       KILL DIDEL

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

               QUIT

 +26       DO TR^BARTDO(BARTRIEN)

 +27       WRITE "."

DONE      ;

 +1        QUIT

BARPNPU.m