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
;
; ********************************************************************
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 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 !!
Q
; *********************************************************************
;
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"
Q
; *********************************************************************
;
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
Q
; *********************************************************************
;
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 ;
Q
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
