Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSAJ

ACHSAJ.m

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