BARBADU.m

BARBADU ; IHS/SD/LSL - PAYMENT TRANSACTION EXECUTION ; 06/09/2008

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

 ;** posting utilities

 ;

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

 ;     Don't update files if Adjustment Category is PENDING or

 ;     GENERAL INFORMATION

 ;

 ; IHS/SD/LSL - 10/17/02 - V1.7 - QAA-1200-130051

 ;      Provide Q conditions if failed getting a new A/R transaction

 ; IHS/SD/PKD 3/21/11 1.8*21 Patch 19 copied BARBAD* from BARPST* and modified

 ;      BARBAD* will be merged back at some point, but not all comments

 ;      apply to BARBAD since comments weren't updated w/ Patch 19 changes

 ;

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

 Q

 ;

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 processor

 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 SETHLP

 S J=0

 F  S J=$O(BARHLP(J)) Q:'J  D

 . W !?2,BARHLP(J)

 W !!

 Q

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

 ;

SETHLP ;EP - sethelp

 S BARHLP(1)="S = Set all or a portion of the current balance as ""Sent to Collections."""

 S BARHLP(2)="V = Reverse from ""Sent to Collections"" back into the current balance."

 S BARHLP(3)="Q or 3 = Quit"

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

 S BARHLP(5)="M = Message"

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

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

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

 Q

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

 ;

POSTTX ;EP - poster  ;Heavily modified for BAR*1.8*4 DD 4.1.7.2

 ;CALLED BY PAY/ADJ/REF POSTING OPTIONS ;BAR*1.8*4 DD 4.1.7.2

 ;

 ;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

 S BARLIN=0

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

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

 .; IHS/SD/AR 1.8*19 Added following 2 lines which will set up ^BARTMP($J

 .;  if they were not there.  comments added 3/21/11

 .I BARBDFN="" S BARCNT=$$EN^BARBAD2(BARPASS)

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

 . ; end 1.8*19

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

 .S BARROLL(BARBDFN)=""

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

 .D CKBAL(BARLIN,BARBLV(15))

 .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(BARTR(BARLIN,BARJ),U,2)  ;CHG'D LINE

 ..S BARBTOT=BARBTOT+BARAMT

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

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

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

 ..D P1

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

 Q

CKBAL(BARL,BARB) ;EP; CHECK IF TX'S WILL CREATE NEGATIVE BALANCE

 ;ENTERS WITH BARL = LINE  = BILL

 ;            BARB = BILL BALANCE

 S BARSTOP=0

 N BARTOT,BARJ,BARDIF,BARTAMT,BARCAT

 S (BARTOT,BARJ)=0

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

 .S BARREC=BARTR(BARLIN,BARJ)

 .S BARTYP=$P(BARREC,U)

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

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

 .S BARCOM1=$P(BARREC,U,5)

 .I BARCAT'=21&(BARCAT'=22) D

 ..S BARTOT=BARTOT+BARTAMT

 Q

 ;

P1 ;

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

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

 S BARDB=$S(BARCOM1="V":BARAMT,1:0)

 ; IHS/SD/PKD 1.8*20 3/11/11  Piece 3 is Debit

 ; Putting it negative causes it to be positive.

 ;S BARDB=-BARDB 

 S BARPT=+BARPAT

 S:$G(BARITM(0)) BARAC=$P(BARITM(0),U,7)

 S BARPAR=$P($G(BARCOL(0)),U,8)

 S BARASFAC=$P($G(BARCOL(0)),U,9)

 S BARSECT=$P($G(BARCOL(0)),U,10)

 S BARSITE=$P($G(BARITM(0)),U,8)

 S:$G(BAREOB) BARSITE=BAREOB

 ;End changes for BAR*1.8*4 DD 4.1.7.2

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

PX ;

 S X=$$NEW^BARTR

 S BARTRIEN=X

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

 K DIE,DIC,DR,DA

 S DA=X,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:$G(BARCOL) DR=DR_";14////^S X=BARCOL"    ;BAR*1.8*4 DD 4.1.7.2

 S:$G(BARITM(0)) DR=DR_";15////^S X=$P(BARITM(0),U,1)" ;BAR*1.8*4 DD 4.1.7.2

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

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

SETCOLL ;EP

 ; Create COLLECTION STATUS multiple for A/R Bill

 N DR,DA,DIC,J,I,BARTOTO,BARTOTSC,BARTEXT,BARCUR,BARCURSC,BARSCIEN,BARTOTM

 S BARTOTO=0,BARTOTSC=0,BARTEXT="",BARCUR=0,BARCURSC=0,BARTOTM=0

 S BARCUR=$$GET1^DIQ(90050.01,BARBDFN,15)

 S BARSCIEN=0

 F  S BARSCIEN=$O(^BARBL(DUZ(2),BARBDFN,9,BARSCIEN)) D  Q:'BARSCIEN

 . S:BARSCIEN BARCURSC=$P(^BARBL(DUZ(2),BARBDFN,9,BARSCIEN,0),U,4)

 I BARCOM1="V" D

 . S BARTOTO=BARCUR+BARAMT

 . S BARTOTSC=BARCURSC-BARAMT

 . S BARTEXT="SENT TO COLLECTIONS-REVERSAL"

 I BARCOM1="S" D

 . S BARTOTO=BARCUR-BARAMT

 . S BARTOTSC=BARCURSC+BARAMT

 . S BARTEXT="SENT TO COLLECTIONS"

 S BARTOTM=BARAMT

 K DIE,DA,DIDEL

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

 S DA=BARBDFN

 S DR=""

 S DR=DR_"15////^S X=BARTOTO"

 S DIDEL=90050

 D ^DIE

 K DIE,DA,DIDEL

 S DA(1)=BARBDFN

 S DIC="^BARBL(DUZ(2),"_DA(1)_",9,"

 S DIC(0)="LX"

 S DIC("P")=$P(^DD(90050.01,901,0),U,2)

 S DIC("DR")=""

 S X=DT_U_BARTOTM_U_BARTEXT_U_BARTOTSC

 K DD,DO

 D FILE^DICN

 K DLAYGO

DONE ;

 Q

BARBADU   ; IHS/SD/LSL - PAYMENT TRANSACTION EXECUTION ; 06/09/2008

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

 +2       ;** posting utilities

 +3       ;

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

 +5       ;     Don't update files if Adjustment Category is PENDING or

 +6       ;     GENERAL INFORMATION

 +7       ;

 +8       ; IHS/SD/LSL - 10/17/02 - V1.7 - QAA-1200-130051

 +9       ;      Provide Q conditions if failed getting a new A/R transaction

 +10      ; IHS/SD/PKD 3/21/11 1.8*21 Patch 19 copied BARBAD* from BARPST* and modified

 +11      ;      BARBAD* will be merged back at some point, but not all comments

 +12      ;      apply to BARBAD since comments weren't updated w/ Patch 19 changes

 +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 processor

 +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        DO SETHLP

 +8        SET J=0

 +9        FOR 

               SET J=$ORDER(BARHLP(J))

               IF 'J

                   QUIT 

               Begin DoDot:1

 +10               WRITE !?2,BARHLP(J)

               End DoDot:1

 +11       WRITE !!

 +12       QUIT 

 +13      ; *********************************************************************

 +14      ;

SETHLP    ;EP - sethelp

 +1        SET BARHLP(1)="S = Set all or a portion of the current balance as ""Sent to Collections."""

 +2        SET BARHLP(2)="V = Reverse from ""Sent to Collections"" back into the current balance."

 +3        SET BARHLP(3)="Q or 3 = Quit"

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

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

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

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

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

 +9        QUIT 

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

 +11      ;

POSTTX    ;EP - poster  ;Heavily modified for BAR*1.8*4 DD 4.1.7.2

 +1       ;CALLED BY PAY/ADJ/REF POSTING OPTIONS ;BAR*1.8*4 DD 4.1.7.2

 +2       ;

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

 +4       ;IS SESSION STILL OPEN

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

               QUIT 

 +5       ; 

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

 +7        KILL DD,DO,BARBLV

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

 +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      ; IHS/SD/AR 1.8*19 Added following 2 lines which will set up ^BARTMP($J

 +13      ;  if they were not there.  comments added 3/21/11

 +14               IF BARBDFN=""

                       SET BARCNT=$$EN^BARBAD2(BARPASS)

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

 +16      ; end 1.8*19

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

 +18               SET BARROLL(BARBDFN)=""

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

 +20               DO CKBAL(BARLIN,BARBLV(15))

 +21      ;BAR*1.8*4 DD 4.1.7.2

                   IF BARSTOP

                       QUIT 

 +22               SET (BARBTOT,BARJ)=0

 +23               FOR 

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

                       IF 'BARJ

                           QUIT 

                       Begin DoDot:2

 +24                       SET BARREC=BARTR(BARLIN,BARJ)

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

 +26      ;CHG'D LINE

                           SET BARAMT=$PIECE(BARTR(BARLIN,BARJ),U,2)

 +27                       SET BARBTOT=BARBTOT+BARAMT

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

 +29                       SET BARTT=$ORDER(^BARTBL("B","STATUS CHANGE",""))

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

 +31                       DO P1

                       End DoDot:2

 +32      ;BAR*1.8*4 DD 4.1.7.2

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

               End DoDot:1

 +33       QUIT 

CKBAL(BARL,BARB) ;EP; CHECK IF TX'S WILL CREATE NEGATIVE BALANCE

 +1       ;ENTERS WITH BARL = LINE  = BILL

 +2       ;            BARB = BILL BALANCE

 +3        SET BARSTOP=0

 +4        NEW BARTOT,BARJ,BARDIF,BARTAMT,BARCAT

 +5        SET (BARTOT,BARJ)=0

 +6        FOR 

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

               IF 'BARJ

                   QUIT 

               Begin DoDot:1

 +7                SET BARREC=BARTR(BARLIN,BARJ)

 +8                SET BARTYP=$PIECE(BARREC,U)

 +9                SET BARTAMT=$PIECE(BARREC,U,2)

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

 +11               SET BARCOM1=$PIECE(BARREC,U,5)

 +12               IF BARCAT'=21&(BARCAT'=22)

                       Begin DoDot:2

 +13                       SET BARTOT=BARTOT+BARTAMT

                       End DoDot:2

               End DoDot:1

 +14       QUIT 

 +15      ;

P1        ;

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

 +2        SET BARCR=$SELECT(BARCOM1="S":BARAMT,1:0)

 +3        SET BARDB=$SELECT(BARCOM1="V":BARAMT,1:0)

 +4       ; IHS/SD/PKD 1.8*20 3/11/11  Piece 3 is Debit

 +5       ; Putting it negative causes it to be positive.

 +6       ;S BARDB=-BARDB 

 +7        SET BARPT=+BARPAT

 +8        IF $GET(BARITM(0))

               SET BARAC=$PIECE(BARITM(0),U,7)

 +9        SET BARPAR=$PIECE($GET(BARCOL(0)),U,8)

 +10       SET BARASFAC=$PIECE($GET(BARCOL(0)),U,9)

 +11       SET BARSECT=$PIECE($GET(BARCOL(0)),U,10)

 +12       SET BARSITE=$PIECE($GET(BARITM(0)),U,8)

 +13       IF $GET(BAREOB)

               SET BARSITE=BAREOB

 +14      ;End changes for BAR*1.8*4 DD 4.1.7.2

 +15      ; -------------------------------

PX        ;

 +1        SET X=$$NEW^BARTR

 +2        SET BARTRIEN=X

 +3        IF X<1

               DO MSG^BARTR(BARBDFN)

               QUIT 

 +4        KILL DIE,DIC,DR,DA

 +5        SET DA=X

           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      ;BAR*1.8*4 DD 4.1.7.2

           IF $GET(BARCOL)

               SET DR=DR_";14////^S X=BARCOL"

 +18      ;BAR*1.8*4 DD 4.1.7.2

           IF $GET(BARITM(0))

               SET DR=DR_";15////^S X=$P(BARITM(0),U,1)"

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

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

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

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

 +23       SET DIDEL=90050

 +24       DO ^DIE

 +25       KILL DIDEL

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

               QUIT 

 +27       DO TR^BARTDO(BARTRIEN)

 +28       WRITE "."

SETCOLL   ;EP

 +1       ; Create COLLECTION STATUS multiple for A/R Bill

 +2        NEW DR,DA,DIC,J,I,BARTOTO,BARTOTSC,BARTEXT,BARCUR,BARCURSC,BARSCIEN,BARTOTM

 +3        SET BARTOTO=0

           SET BARTOTSC=0

           SET BARTEXT=""

           SET BARCUR=0

           SET BARCURSC=0

           SET BARTOTM=0

 +4        SET BARCUR=$$GET1^DIQ(90050.01,BARBDFN,15)

 +5        SET BARSCIEN=0

 +6        FOR 

               SET BARSCIEN=$ORDER(^BARBL(DUZ(2),BARBDFN,9,BARSCIEN))

               Begin DoDot:1

 +7                IF BARSCIEN

                       SET BARCURSC=$PIECE(^BARBL(DUZ(2),BARBDFN,9,BARSCIEN,0),U,4)

               End DoDot:1

               IF 'BARSCIEN

                   QUIT 

 +8        IF BARCOM1="V"

               Begin DoDot:1

 +9                SET BARTOTO=BARCUR+BARAMT

 +10               SET BARTOTSC=BARCURSC-BARAMT

 +11               SET BARTEXT="SENT TO COLLECTIONS-REVERSAL"

               End DoDot:1

 +12       IF BARCOM1="S"

               Begin DoDot:1

 +13               SET BARTOTO=BARCUR-BARAMT

 +14               SET BARTOTSC=BARCURSC+BARAMT

 +15               SET BARTEXT="SENT TO COLLECTIONS"

               End DoDot:1

 +16       SET BARTOTM=BARAMT

 +17       KILL DIE,DA,DIDEL

 +18       SET DIE="^BARBL(DUZ(2),"

 +19       SET DA=BARBDFN

 +20       SET DR=""

 +21       SET DR=DR_"15////^S X=BARTOTO"

 +22       SET DIDEL=90050

 +23       DO ^DIE

 +24       KILL DIE,DA,DIDEL

 +25       SET DA(1)=BARBDFN

 +26       SET DIC="^BARBL(DUZ(2),"_DA(1)_",9,"

 +27       SET DIC(0)="LX"

 +28       SET DIC("P")=$PIECE(^DD(90050.01,901,0),U,2)

 +29       SET DIC("DR")=""

 +30       SET X=DT_U_BARTOTM_U_BARTEXT_U_BARTOTSC

 +31       KILL DD,DO

 +32       DO FILE^DICN

 +33       KILL DLAYGO

DONE      ;

 +1        QUIT