ACHSAJ ; IHS/ITSC/PMF - ADJUST A PAID DOCUMENT (1/2) ; [ 12/11/2003 1:09 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**1,5,14,19**;JUN 11, 2001
;;ACHS*3.1*1; Correct typo
;;ACHS*3.1*5 12/06/2002; set ACHSDOC0 in THIS routine, instead of
; depending on it being passed in
; ACHS*3.1*14 7/25/2008 IHS/OIT/FCJ Added ability to neg adj 3rd party payment
;
I $D(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0)),$P($G(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0)),U,2)=DT D Q
. W !!,*7," The Register Has Been CLOSED -- An adjustment cannot be done at this time!",!
. D ENDC^ACHSAJ1
. Q
;
A3 ; Select document, check for paid status.
D ^ACHSUD
;
I '$D(ACHSDIEN) D ENDC^ACHSAJ1 Q
;
I '$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) W !!,*7,?10,"NOT A PAID DOCUMENT -- ONLY PAID DOCUMENTS CAN BE ADJUSTED" G A3
S ACHSTIEN=1,ACHSIPA=0,ACHS3RDS=""
K ACHSSIG
;
D INIT^ACHSRP2 ;INITIALIZE DOCUMENT VARIABLES
D ^ACHSAV ;DOCUMENT DISPLAY
S ACHSADJ=""
D A0A^ACHSUSC ;DISPLAY DOCUMENT CANCEL/SUPPLEMENT INFO
;
A4 ;
I '$D(ACHSDIEN) D ENDC^ACHSAJ1 Q
;
I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") W !,"LOCK FAILED AT A4+2^ACHSAJ" D K^ACHSAJ1 Q
;
;THIS ENTRY CALLED BY ACHSEOB3 THREE DIFFERENT TIMES TO PROCESS
;ADJUSTMENT AMOUNTS -
;1)FIRST IF THERE ARE PAYMENT AMOUNTS
;I.E. I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) DO THIS
;2)
A4A ;EP - Automatic adjustment.
S ACHSX=+$$DOC^ACHS(0,14) ;GET FISCAL YEAR DIGIT
D FYCVT^ACHSFU ;COMPUTE FISCAL YEAR
S ACHSACFY=ACHSY,ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
;
;ACHS*3.1*5 12/06/2002 pmf make sure that ACHSDOC0 has the
;data from the CURRENT document. We BETTER have ACHSDIEN set
;by now, but I'm being careful with the $G
I $G(ACHSDIEN)'="" S ACHSDOC0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) ; ACHS*3.1*5 12/06/2002
;
;
S X=1 ;SKIP INITIAL TRANSACTION ASSUMES FIRST IS I='INITIAL'
F S X=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X)) Q:+X=0 D
.;IF 'TRANSACTION TYPE' EQUALS P=PAYMENT GET 'DATE OF SERVICE'
.;THIS WILL GET ONLY THE FIRST PAYMENT ENTRY.
.;IF THERE IS NO PAYMENT ENTRY THEN DATE OF SERVICE WILL BE UNDEFINED
.;OR THE LAST ONE FOUND. ALSO ACHSTIEN IS SET TO X WHEN DATE OF SERVICE
.;IS NOT DEFINED
.I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X,0)),U,2)="P" S ACHSSVDT=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X,0)),U,10) Q:ACHSSVDT>0 S ACHSTIEN=X
;
;
;
D CKB^ACHSUUP ;CHECK BALANCE
I $D(ACHSISAO),$D(ACHSCNC) D Q
.S ACHSERRE=13 ;REGISTERS OUT OF BALANCE
.S ACHSEDAT="" D ^ACHSEOBG D K^ACHSAJ1 S ACHSERRA=1 Q
;
I $D(ACHSCNC) D END^ACHSAJ1 Q
;
S (ACHSTADJ,ACHSNADJ)=0
;
;GET PAYMENT AMOUNT NODE
S ACHSAPA=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
I ACHSAPA="" D Q
.S ACHSERRE=12 ;ZERO DOCUMENT AMOUNT
.S ACHSEDAT=$G(S),ACHSERRA=1 D ^ACHSEOBG D K^ACHSAJ1 Q
;
;
S ACHS3PA=$P(ACHSAPA,U,5) ;PAYMENT AMOUNT THIRD PARTY
S ACHSAPA=$P(ACHSAPA,U) ;TOTAL PAYMENT AMOUNT
;
;IF THERE IS DATA IN ADJUSTMENT NODE REPLACE INFO FROM
;PA NODE WITH INFO FROM ZA NODE??????
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")) D
.;ADJUSTED PAYMENT AMT
.S ACHSAPA=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U)
.;TOTAL ADJUSTMENT AMT
.S ACHSTADJ=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,2)
.;NUMBER OF ADJUSTMENTS
.S ACHSNADJ=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,3)
.;ADJUSTED THIRD PARTY PAYMENT AMT
.S ACHS3PA=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,4)
;
I $D(ACHSISAO),$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"EB1",ACHSPDAT)) S ACHSERRE=29,ACHSEDAT="" D ^ACHSEOBG
B2 ;
I $D(ACHSISAO),$D(ACHSIPA) S Y=ACHSIPA,ACHSSIGN=1 S:$E(Y)="-" ACHSSIGN=-1,Y=$E(Y,2,99) G B3
I $D(ACHSISAO) S ACHSERRE=28,ACHSEDAT=ACHSIPA,ACHSERRA=1 D ^ACHSEOBG,K^ACHSAJ1 Q
B2Z ;
W !!,"Amount Of pay Adjustment: "
S ACHSSIGN=1
D READ^ACHSFU ;USER INPUT DOLLAR AMOUNT
I $D(DTOUT)!($D(DUOUT)) D ENDC^ACHSAJ1 Q
;
I Y?1"?".E W !," Enter Payment Adjustment Amount (e.g. + or - 150.00)." G B2
;ACHS*3.1*14 7/25/2008 IHS/OIT/FCJ CHNGED NXT LINE TO ALLOW 0 ON ADJ IN ORDER TO ADJ 3RD PARTY PAY AMT
;I Y=""!(+Y=0) W *7," NO AMOUNT ENTERED",!! D ENDC^ACHSAJ1 Q
I Y="" W *7," NO AMOUNT ENTERED",!! D ENDC^ACHSAJ1 Q
;
S ACHSADAM=Y ;ADJUSTMENT AMOUNT
;
;pmf 06/19/01 first, strip out the dollar sign, if there is one.
S ACHSADAM=$TR(ACHSADAM,"$")
S:$E(ACHSADAM)="+" ACHSADAM=$E(ACHSADAM,2,99)
S:$E(ACHSADAM)="-" ACHSSIGN=-1,ACHSADAM=$E(ACHSADAM,2,99)
;pmf 06/19/01 remove next line. this is now handle better above
;S:ACHSADAM?1"$".E ACHSADAM=$E(ACHSADAM,2,99)
;
F I=1:1 S F=$F(ACHSADAM,",") Q:'F S ACHSADAM=$E(ACHSADAM,1,F-2)_$E(ACHSADAM,F,99)
I '(ACHSADAM?1N.N1"."2N!(ACHSADAM?1N.N))!($L(ACHSADAM)>10) W *7," ??" G A4
B3 ;
D OBLM^ACHSFU ;CHECK OBLIGATION LIMIT FOR THIS TYPE OF DOCUMENT
G:$D(DUOUT)!($D(DTOUT)) B2
;
I $D(ACHSISAO),$D(ACHSERRE) S ACHSERRA=1,ACHSEDAT="" D ^ACHSEOBG,K^ACHSAJ1 Q
C ;
S ACHSADAM=$G(ACHSADAM)
I ACHSADAM="" S ACHSADAM=$G(Y)
;
;4/30/02 pmf just above, we make sure that we have a value
;for the adjustment amount. However, it is possible that ACHSADAM
;was floating around from a previous iteration and is set wrong.
;therefore, let's do one more line for auto EOBR processing
;if ACHSISAO exists, we are doing that, and the amount is in Y
I $D(ACHSISAO) S ACHSADAM=Y
;
;
S (S,X)=ACHSSIGN*ACHSADAM,X2="2$",X3=0
D COMMA^%DTC
W:'$D(ACHSISAO) " (",X,")"
S (ACHSESDO,ACHSAMT)=S
S ACHS("CHK")=1,ACHSUFLG=""
;
D SBAENT^ACHSUUP ;UPDATE CURRENT ADVICE OF ALLOWANCE
;
K ACHSUFLG
I S>0 G C0
;I -1*S>$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U) D NEGADJ
;G:'$D(ACHSISAO) B2
;Q
;ACHS*3.1*19 IHS.OIT.FCJ MODIFIED NEXT LINE TO TEST FOR ADJ PAYMENTS
;I -1*S>$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U) W:'$D(ACHSISAO) *7,!!,"NEG ADJ CANNOT BE > PAYMENT AMT" G:'$D(ACHSISAO) B2 I $D(ACHSISAO) S ACHSERRE=25,ACHSEDAT=S,ACHSERRA=1 D ^ACHSEOBG D K^ACHSAJ1 Q
I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")) S ACHSTP=$P(^("ZA"),U)
E S ACHSTP=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U)
I -1*S>ACHSTP W:'$D(ACHSISAO) *7,!!,"NEG ADJ CANNOT BE > PAYMENT AMT" G:'$D(ACHSISAO) B2 I $D(ACHSISAO) S ACHSERRE=25,ACHSEDAT=S,ACHSERRA=1 D ^ACHSEOBG D K^ACHSAJ1 Q
G C0
;
NEGADJ ;
W:'$D(ACHSISAO) *7,!!,"NEG ADJ CANNOT BE > PAYMENT AMT"
I $D(ACHSISAO) D
.S ACHSERRE=25 ;NEG ADJ > PAY AMOUNT;E
.S ACHSEDAT=S
.S ACHSERRA=1
.D ^ACHSEOBG ;PLACE ERROR IN ERROR GLOBAL
.D K^ACHSAJ1
Q
;
C0 ;
I $D(ACHSISAO) G C1
S Y=$$DIR^XBDIR("D^::E","Enter Date Document Paid","","","","",2)
G B2:$D(DUOUT)
I $D(DTOUT) D ENDC^ACHSAJ1 Q
S ACHSEOBD=Y,ACHSPDAT=ACHSEOBD
C01 ;
W !!
S ACHSJERR=0
;
;IF 'DOCUMENT DESTINATION' IS IHS THEN get a sequence number
I $$DOC^ACHS(0,17)="I" S ACHSPSQN=$G(^ACHSF(DUZ(2),"SEQN"))+1,^ACHSF(DUZ(2),"SEQN")=ACHSPSQN G C02
;
S Y=$$DIR^XBDIR("N","Enter Sequence Number From EOBR","","","","",2)
G C0:$D(DUOUT)
I $D(DTOUT) D ENDC^ACHSAJ1 Q
S ACHSPSQN=Y
C02 ;
;IF ENRTY IN EOBR DATE X-REF THEN THE TRANSACTION HAS BEEN PROCESSED
I '$D(ACHSISAO),$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"EB1",ACHSPDAT)) D I $G(ACHSJERR) D ENDC^ACHSAJ1 Q
. W !!,*7,*7,"A Transaction Has Been Processed For This Document On This Date.",!!?15,$$FMTE^XLFDT(ACHSPDAT),!!
. S Y=$$DIR^XBDIR("Y","Do You Wish To Continue","N")
. I ('Y)!$D(DUOUT)!$D(DTOUT) S ACHSJERR=1
;
S ACHSPIND="F"
;
;IF DOCUMENT DESTINATION IHS
I $$DOC^ACHS(0,17)="I" G C1
;
C03 ; EOBR Services billed.
D DIR("9002080.02,19^O",$$SET(9002080.02,19,$G(ACHSSV)))
I $D(DTOUT) D ENDC^ACHSAJ1 Q
G B2:$D(DUOUT)
S ACHSSV=Y
;
C04 ; EOBR Control Number.
D DIR("9002080.02,16^O",$G(ACHSCTL))
I $D(DTOUT) D ENDC^ACHSAJ1 Q
G C03:$D(DUOUT)
S ACHSCTL=Y
;
C05 ; EOBR Check number.
D DIR("9002080.02,17^O",$G(ACHSCHK))
I $D(DTOUT) D ENDC^ACHSAJ1 Q
G C04:$D(DUOUT)
S ACHSCHK=Y
;
C06 ; EOBR Remittance number.
D DIR("9002080.02,18^O",$G(ACHSREM))
I $D(DTOUT) D ENDC^ACHSAJ1 Q
G C05:$D(DUOUT)
S ACHSREM=Y
;
C07 ; EOBR Oblication type.
D DIR("9002080.02,20^O",$$SET(9002080.02,20,$G(ACHSOB)))
I $D(DTOUT) D ENDC^ACHSAJ1 Q
G C06:$D(DUOUT)
S ACHSOB=Y
;
C1 ; Adjustment to 3rd party payment.
I $D(ACHSISAO) S Y=$G(ACHS3RDP) G C1A
;ACHS*3.1*14 7/25/2008 IHS/OIT/FCJ BY CALLING DIR, IT DID NOT ALLOW FOR A NEG ADJUSTMENT, ADDED LINE W/DIRECT DIR CALL
;D DIR("9002080.02,7^0",$G(ACHS3TAJ))
S DIR("A")="THIRD PARTY PAY AMT",DIR(0)="N^"_-ACHS3PA_":99999:2",DIR("B")=$G(ACHS3TAJ) D ^DIR K DIR
I $D(DTOUT) D ENDC^ACHSAJ1 Q
G C07:$D(DUOUT)
S ACHS3TAJ=Y
C1A ;
S ACHS3AJ=ACHS3PA+Y,ACHS3TAJ=Y
OK ; Ask for confirmation.
G D1^ACHSAJ1:$D(ACHSISAO)
G D1^ACHSAJ1:$$DIR^XBDIR("Y","Is everything correct","NO","","","",2)
G B2
;
DIR(ACHS,ACHS1) ; ( <DIR(0)> , <DIR("B")> )
W !
K DIR,DUOUT,DTOUT,DIRUT
S DIR(0)=ACHS
I $L($G(ACHS1)) S DIR("B")=ACHS1
D ^DIR
K DIR
Q
;
;11/29/01 pmf replace this line ET(X,Y,Z) ; (File,Field,Internal) Return the external form of a set element. ACHS*3.1*1
SET(X,Y,Z) ; (File,Field,Internal) Return the external form of a set element. ; ACHS*3.1*1
S %=$P($G(^DD(X,Y,0)),U,3)
F X=1:1 S Y=$P(%,";",X) Q:Y="" I $P(Y,":")=Z S Y=$P(Y,":",2) Q
Q Y
;
ACHSAJ ; IHS/ITSC/PMF - ADJUST A PAID DOCUMENT (1/2) ; [ 12/11/2003 1:09 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**1,5,14,19**;JUN 11, 2001
+2 ;;ACHS*3.1*1; Correct typo
+3 ;;ACHS*3.1*5 12/06/2002; set ACHSDOC0 in THIS routine, instead of
+4 ; depending on it being passed in
+5 ; ACHS*3.1*14 7/25/2008 IHS/OIT/FCJ Added ability to neg adj 3rd party payment
+6 ;
+7 IF $DATA(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0))
IF $PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSCFY,"W",+ACHSFYWK(DUZ(2),ACHSCFY),0)),U,2)=DT
Begin DoDot:1
+8 WRITE !!,*7," The Register Has Been CLOSED -- An adjustment cannot be done at this time!",!
+9 DO ENDC^ACHSAJ1
+10 QUIT
End DoDot:1
QUIT
+11 ;
A3 ; Select document, check for paid status.
+1 DO ^ACHSUD
+2 ;
+3 IF '$DATA(ACHSDIEN)
DO ENDC^ACHSAJ1
QUIT
+4 ;
+5 IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
WRITE !!,*7,?10,"NOT A PAID DOCUMENT -- ONLY PAID DOCUMENTS CAN BE ADJUSTED"
GOTO A3
+6 SET ACHSTIEN=1
SET ACHSIPA=0
SET ACHS3RDS=""
+7 KILL ACHSSIG
+8 ;
+9 ;INITIALIZE DOCUMENT VARIABLES
DO INIT^ACHSRP2
+10 ;DOCUMENT DISPLAY
DO ^ACHSAV
+11 SET ACHSADJ=""
+12 ;DISPLAY DOCUMENT CANCEL/SUPPLEMENT INFO
DO A0A^ACHSUSC
+13 ;
A4 ;
+1 IF '$DATA(ACHSDIEN)
DO ENDC^ACHSAJ1
QUIT
+2 ;
+3 IF '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+")
WRITE !,"LOCK FAILED AT A4+2^ACHSAJ"
DO K^ACHSAJ1
QUIT
+4 ;
+5 ;THIS ENTRY CALLED BY ACHSEOB3 THREE DIFFERENT TIMES TO PROCESS
+6 ;ADJUSTMENT AMOUNTS -
+7 ;1)FIRST IF THERE ARE PAYMENT AMOUNTS
+8 ;I.E. I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) DO THIS
+9 ;2)
A4A ;EP - Automatic adjustment.
+1 ;GET FISCAL YEAR DIGIT
SET ACHSX=+$$DOC^ACHS(0,14)
+2 ;COMPUTE FISCAL YEAR
DO FYCVT^ACHSFU
+3 SET ACHSACFY=ACHSY
SET ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
+4 ;
+5 ;ACHS*3.1*5 12/06/2002 pmf make sure that ACHSDOC0 has the
+6 ;data from the CURRENT document. We BETTER have ACHSDIEN set
+7 ;by now, but I'm being careful with the $G
+8 ; ACHS*3.1*5 12/06/2002
IF $GET(ACHSDIEN)'=""
SET ACHSDOC0=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
+9 ;
+10 ;
+11 ;SKIP INITIAL TRANSACTION ASSUMES FIRST IS I='INITIAL'
SET X=1
+12 FOR
SET X=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X))
IF +X=0
QUIT
Begin DoDot:1
+13 ;IF 'TRANSACTION TYPE' EQUALS P=PAYMENT GET 'DATE OF SERVICE'
+14 ;THIS WILL GET ONLY THE FIRST PAYMENT ENTRY.
+15 ;IF THERE IS NO PAYMENT ENTRY THEN DATE OF SERVICE WILL BE UNDEFINED
+16 ;OR THE LAST ONE FOUND. ALSO ACHSTIEN IS SET TO X WHEN DATE OF SERVICE
+17 ;IS NOT DEFINED
+18 IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X,0)),U,2)="P"
SET ACHSSVDT=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",X,0)),U,10)
IF ACHSSVDT>0
QUIT
SET ACHSTIEN=X
End DoDot:1
+19 ;
+20 ;
+21 ;
+22 ;CHECK BALANCE
DO CKB^ACHSUUP
+23 IF $DATA(ACHSISAO)
IF $DATA(ACHSCNC)
Begin DoDot:1
+24 ;REGISTERS OUT OF BALANCE
SET ACHSERRE=13
+25 SET ACHSEDAT=""
DO ^ACHSEOBG
DO K^ACHSAJ1
SET ACHSERRA=1
QUIT
End DoDot:1
QUIT
+26 ;
+27 IF $DATA(ACHSCNC)
DO END^ACHSAJ1
QUIT
+28 ;
+29 SET (ACHSTADJ,ACHSNADJ)=0
+30 ;
+31 ;GET PAYMENT AMOUNT NODE
+32 SET ACHSAPA=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"))
+33 IF ACHSAPA=""
Begin DoDot:1
+34 ;ZERO DOCUMENT AMOUNT
SET ACHSERRE=12
+35 SET ACHSEDAT=$GET(S)
SET ACHSERRA=1
DO ^ACHSEOBG
DO K^ACHSAJ1
QUIT
End DoDot:1
QUIT
+36 ;
+37 ;
+38 ;PAYMENT AMOUNT THIRD PARTY
SET ACHS3PA=$PIECE(ACHSAPA,U,5)
+39 ;TOTAL PAYMENT AMOUNT
SET ACHSAPA=$PIECE(ACHSAPA,U)
+40 ;
+41 ;IF THERE IS DATA IN ADJUSTMENT NODE REPLACE INFO FROM
+42 ;PA NODE WITH INFO FROM ZA NODE??????
+43 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"))
Begin DoDot:1
+44 ;ADJUSTED PAYMENT AMT
+45 SET ACHSAPA=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U)
+46 ;TOTAL ADJUSTMENT AMT
+47 SET ACHSTADJ=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,2)
+48 ;NUMBER OF ADJUSTMENTS
+49 SET ACHSNADJ=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,3)
+50 ;ADJUSTED THIRD PARTY PAYMENT AMT
+51 SET ACHS3PA=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,4)
End DoDot:1
+52 ;
+53 IF $DATA(ACHSISAO)
IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"EB1",ACHSPDAT))
SET ACHSERRE=29
SET ACHSEDAT=""
DO ^ACHSEOBG
B2 ;
+1 IF $DATA(ACHSISAO)
IF $DATA(ACHSIPA)
SET Y=ACHSIPA
SET ACHSSIGN=1
IF $EXTRACT(Y)="-"
SET ACHSSIGN=-1
SET Y=$EXTRACT(Y,2,99)
GOTO B3
+2 IF $DATA(ACHSISAO)
SET ACHSERRE=28
SET ACHSEDAT=ACHSIPA
SET ACHSERRA=1
DO ^ACHSEOBG
DO K^ACHSAJ1
QUIT
B2Z ;
+1 WRITE !!,"Amount Of pay Adjustment: "
+2 SET ACHSSIGN=1
+3 ;USER INPUT DOLLAR AMOUNT
DO READ^ACHSFU
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
DO ENDC^ACHSAJ1
QUIT
+5 ;
+6 IF Y?1"?".E
WRITE !," Enter Payment Adjustment Amount (e.g. + or - 150.00)."
GOTO B2
+7 ;ACHS*3.1*14 7/25/2008 IHS/OIT/FCJ CHNGED NXT LINE TO ALLOW 0 ON ADJ IN ORDER TO ADJ 3RD PARTY PAY AMT
+8 ;I Y=""!(+Y=0) W *7," NO AMOUNT ENTERED",!! D ENDC^ACHSAJ1 Q
+9 IF Y=""
WRITE *7," NO AMOUNT ENTERED",!!
DO ENDC^ACHSAJ1
QUIT
+10 ;
+11 ;ADJUSTMENT AMOUNT
SET ACHSADAM=Y
+12 ;
+13 ;pmf 06/19/01 first, strip out the dollar sign, if there is one.
+14 SET ACHSADAM=$TRANSLATE(ACHSADAM,"$")
+15 IF $EXTRACT(ACHSADAM)="+"
SET ACHSADAM=$EXTRACT(ACHSADAM,2,99)
+16 IF $EXTRACT(ACHSADAM)="-"
SET ACHSSIGN=-1
SET ACHSADAM=$EXTRACT(ACHSADAM,2,99)
+17 ;pmf 06/19/01 remove next line. this is now handle better above
+18 ;S:ACHSADAM?1"$".E ACHSADAM=$E(ACHSADAM,2,99)
+19 ;
+20 FOR I=1:1
SET F=$FIND(ACHSADAM,",")
IF 'F
QUIT
SET ACHSADAM=$EXTRACT(ACHSADAM,1,F-2)_$EXTRACT(ACHSADAM,F,99)
+21 IF '(ACHSADAM?1N.N1"."2N!(ACHSADAM?1N.N))!($LENGTH(ACHSADAM)>10)
WRITE *7," ??"
GOTO A4
B3 ;
+1 ;CHECK OBLIGATION LIMIT FOR THIS TYPE OF DOCUMENT
DO OBLM^ACHSFU
+2 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO B2
+3 ;
+4 IF $DATA(ACHSISAO)
IF $DATA(ACHSERRE)
SET ACHSERRA=1
SET ACHSEDAT=""
DO ^ACHSEOBG
DO K^ACHSAJ1
QUIT
C ;
+1 SET ACHSADAM=$GET(ACHSADAM)
+2 IF ACHSADAM=""
SET ACHSADAM=$GET(Y)
+3 ;
+4 ;4/30/02 pmf just above, we make sure that we have a value
+5 ;for the adjustment amount. However, it is possible that ACHSADAM
+6 ;was floating around from a previous iteration and is set wrong.
+7 ;therefore, let's do one more line for auto EOBR processing
+8 ;if ACHSISAO exists, we are doing that, and the amount is in Y
+9 IF $DATA(ACHSISAO)
SET ACHSADAM=Y
+10 ;
+11 ;
+12 SET (S,X)=ACHSSIGN*ACHSADAM
SET X2="2$"
SET X3=0
+13 DO COMMA^%DTC
+14 IF '$DATA(ACHSISAO)
WRITE " (",X,")"
+15 SET (ACHSESDO,ACHSAMT)=S
+16 SET ACHS("CHK")=1
SET ACHSUFLG=""
+17 ;
+18 ;UPDATE CURRENT ADVICE OF ALLOWANCE
DO SBAENT^ACHSUUP
+19 ;
+20 KILL ACHSUFLG
+21 IF S>0
GOTO C0
+22 ;I -1*S>$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U) D NEGADJ
+23 ;G:'$D(ACHSISAO) B2
+24 ;Q
+25 ;ACHS*3.1*19 IHS.OIT.FCJ MODIFIED NEXT LINE TO TEST FOR ADJ PAYMENTS
+26 ;I -1*S>$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U) W:'$D(ACHSISAO) *7,!!,"NEG ADJ CANNOT BE > PAYMENT AMT" G:'$D(ACHSISAO) B2 I $D(ACHSISAO) S ACHSERRE=25,ACHSEDAT=S,ACHSERRA=1 D ^ACHSEOBG D K^ACHSAJ1 Q
+27 IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"))
SET ACHSTP=$PIECE(^("ZA"),U)
+28 IF '$TEST
SET ACHSTP=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U)
+29 IF -1*S>ACHSTP
IF '$DATA(ACHSISAO)
WRITE *7,!!,"NEG ADJ CANNOT BE > PAYMENT AMT"
IF '$DATA(ACHSISAO)
GOTO B2
IF $DATA(ACHSISAO)
SET ACHSERRE=25
SET ACHSEDAT=S
SET ACHSERRA=1
DO ^ACHSEOBG
DO K^ACHSAJ1
QUIT
+30 GOTO C0
+31 ;
NEGADJ ;
+1 IF '$DATA(ACHSISAO)
WRITE *7,!!,"NEG ADJ CANNOT BE > PAYMENT AMT"
+2 IF $DATA(ACHSISAO)
Begin DoDot:1
+3 ;NEG ADJ > PAY AMOUNT;E
SET ACHSERRE=25
+4 SET ACHSEDAT=S
+5 SET ACHSERRA=1
+6 ;PLACE ERROR IN ERROR GLOBAL
DO ^ACHSEOBG
+7 DO K^ACHSAJ1
End DoDot:1
+8 QUIT
+9 ;
C0 ;
+1 IF $DATA(ACHSISAO)
GOTO C1
+2 SET Y=$$DIR^XBDIR("D^::E","Enter Date Document Paid","","","","",2)
+3 IF $DATA(DUOUT)
GOTO B2
+4 IF $DATA(DTOUT)
DO ENDC^ACHSAJ1
QUIT
+5 SET ACHSEOBD=Y
SET ACHSPDAT=ACHSEOBD
C01 ;
+1 WRITE !!
+2 SET ACHSJERR=0
+3 ;
+4 ;IF 'DOCUMENT DESTINATION' IS IHS THEN get a sequence number
+5 IF $$DOC^ACHS(0,17)="I"
SET ACHSPSQN=$GET(^ACHSF(DUZ(2),"SEQN"))+1
SET ^ACHSF(DUZ(2),"SEQN")=ACHSPSQN
GOTO C02
+6 ;
+7 SET Y=$$DIR^XBDIR("N","Enter Sequence Number From EOBR","","","","",2)
+8 IF $DATA(DUOUT)
GOTO C0
+9 IF $DATA(DTOUT)
DO ENDC^ACHSAJ1
QUIT
+10 SET ACHSPSQN=Y
C02 ;
+1 ;IF ENRTY IN EOBR DATE X-REF THEN THE TRANSACTION HAS BEEN PROCESSED
+2 IF '$DATA(ACHSISAO)
IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,"EB1",ACHSPDAT))
Begin DoDot:1
+3 WRITE !!,*7,*7,"A Transaction Has Been Processed For This Document On This Date.",!!?15,$$FMTE^XLFDT(ACHSPDAT),!!
+4 SET Y=$$DIR^XBDIR("Y","Do You Wish To Continue","N")
+5 IF ('Y)!$DATA(DUOUT)!$DATA(DTOUT)
SET ACHSJERR=1
End DoDot:1
IF $GET(ACHSJERR)
DO ENDC^ACHSAJ1
QUIT
+6 ;
+7 SET ACHSPIND="F"
+8 ;
+9 ;IF DOCUMENT DESTINATION IHS
+10 IF $$DOC^ACHS(0,17)="I"
GOTO C1
+11 ;
C03 ; EOBR Services billed.
+1 DO DIR("9002080.02,19^O",$$SET(9002080.02,19,$GET(ACHSSV)))
+2 IF $DATA(DTOUT)
DO ENDC^ACHSAJ1
QUIT
+3 IF $DATA(DUOUT)
GOTO B2
+4 SET ACHSSV=Y
+5 ;
C04 ; EOBR Control Number.
+1 DO DIR("9002080.02,16^O",$GET(ACHSCTL))
+2 IF $DATA(DTOUT)
DO ENDC^ACHSAJ1
QUIT
+3 IF $DATA(DUOUT)
GOTO C03
+4 SET ACHSCTL=Y
+5 ;
C05 ; EOBR Check number.
+1 DO DIR("9002080.02,17^O",$GET(ACHSCHK))
+2 IF $DATA(DTOUT)
DO ENDC^ACHSAJ1
QUIT
+3 IF $DATA(DUOUT)
GOTO C04
+4 SET ACHSCHK=Y
+5 ;
C06 ; EOBR Remittance number.
+1 DO DIR("9002080.02,18^O",$GET(ACHSREM))
+2 IF $DATA(DTOUT)
DO ENDC^ACHSAJ1
QUIT
+3 IF $DATA(DUOUT)
GOTO C05
+4 SET ACHSREM=Y
+5 ;
C07 ; EOBR Oblication type.
+1 DO DIR("9002080.02,20^O",$$SET(9002080.02,20,$GET(ACHSOB)))
+2 IF $DATA(DTOUT)
DO ENDC^ACHSAJ1
QUIT
+3 IF $DATA(DUOUT)
GOTO C06
+4 SET ACHSOB=Y
+5 ;
C1 ; Adjustment to 3rd party payment.
+1 IF $DATA(ACHSISAO)
SET Y=$GET(ACHS3RDP)
GOTO C1A
+2 ;ACHS*3.1*14 7/25/2008 IHS/OIT/FCJ BY CALLING DIR, IT DID NOT ALLOW FOR A NEG ADJUSTMENT, ADDED LINE W/DIRECT DIR CALL
+3 ;D DIR("9002080.02,7^0",$G(ACHS3TAJ))
+4 SET DIR("A")="THIRD PARTY PAY AMT"
SET DIR(0)="N^"_-ACHS3PA_":99999:2"
SET DIR("B")=$GET(ACHS3TAJ)
DO ^DIR
KILL DIR
+5 IF $DATA(DTOUT)
DO ENDC^ACHSAJ1
QUIT
+6 IF $DATA(DUOUT)
GOTO C07
+7 SET ACHS3TAJ=Y
C1A ;
+1 SET ACHS3AJ=ACHS3PA+Y
SET ACHS3TAJ=Y
OK ; Ask for confirmation.
+1 IF $DATA(ACHSISAO)
GOTO D1^ACHSAJ1
+2 IF $$DIR^XBDIR("Y","Is everything correct","NO","","","",2)
GOTO D1^ACHSAJ1
+3 GOTO B2
+4 ;
DIR(ACHS,ACHS1) ; ( <DIR(0)> , <DIR("B")> )
+1 WRITE !
+2 KILL DIR,DUOUT,DTOUT,DIRUT
+3 SET DIR(0)=ACHS
+4 IF $LENGTH($GET(ACHS1))
SET DIR("B")=ACHS1
+5 DO ^DIR
+6 KILL DIR
+7 QUIT
+8 ;
+9 ;11/29/01 pmf replace this line ET(X,Y,Z) ; (File,Field,Internal) Return the external form of a set element. ACHS*3.1*1
SET(X,Y,Z) ; (File,Field,Internal) Return the external form of a set element. ; ACHS*3.1*1
+1 SET %=$PIECE($GET(^DD(X,Y,0)),U,3)
+2 FOR X=1:1
SET Y=$PIECE(%,";",X)
IF Y=""
QUIT
IF $PIECE(Y,":")=Z
SET Y=$PIECE(Y,":",2)
QUIT
+3 QUIT Y
+4 ;
