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

ACHSPA0.m

Go to the documentation of this file. 
  1. ACHSPA0 ; IHS/ITSC/PMF - DOCUMENT PAYMENT ;
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**11,12,13**;JUN 11,2001
  1.  ;ACHS*3.1*11 8.27.04 IHS/OIT/FCJ SET DUOUT IF DOC NODE FAILS LOCK
  1.  ;ACHS*3.1*13 ITSC/SET/JVK 3/31/05 ACHSPACC VAR NOT SET
  1.  ;
  1.  ;SET THE TRANSACTION 0 NODE
  1.  S T=DT_"^P^"_DFN_U_$G(ACHSIPA)_U_$G(ACHSFULP)_"^^^"_$G(ACHS3RDP)_U_$G(ACHSWKLD)_U_$G(ACHSSVDT)_U_DUZ_U_$G(ACHS3RDS)
  1.  ;
  1.  S:'$D(ACHSEOBD) ACHSEOBD=ACHSPDAT
  1.  ;
  1.  ;ADD SOME MORE STUFF TO TRANSACTION 0 NODE
  1.  S T=T_U_ACHSPDAT_U_$G(ACHSPSQN)_U_ACHSPIND_U_U_ACHSCTL_U_ACHSCHK_U_ACHSREM_U_ACHSSV_U_ACHSOB
  1.  ;ACHS*3.1*13 ITSC/SET/JVK 3/31/05 ACHSPACC VAR NOT SET
  1.  S ACHSF638=$P($G(^ACHSF(DUZ(2),0)),U,8) I '$D(ACHSPACC) S ACHSPACC=""
  1.  ;ITSC/SET/JVK ACHS*3.1*12
  1.  I ACHSF638="Y",ACHSPACC'="" S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,1),U,3)=ACHSPACC
  1.  ;
  1.  S X=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))           ;GET DOCUMENT 0 NODE
  1.  S N=$P(X,U,6)                               ;COMMON ACCT #
  1.  S O=$P(X,U,7)                               ;OBJECT CLASSIFICATION
  1.  S ACHSX=$P(X,U,14)                          ;FISCAL YEAR
  1.  ;
  1.  D FYCVT^ACHSFU                              ;COMPUTE FISCAL YEAR
  1.  ;
  1.  S R=$P(X,U,19)                              ;DCR ACCT. #
  1.  S (ACHSACFY,F)=ACHSY
  1.  S ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
  1.  S A=ACHSPAMT-ACHSTAO                        ;
  1.  I $D(ACHSISAO) G A1
  1. LOC1 ;
  1.  I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,0)","+") W !,"LOCK on '^ACHS(9,",DUZ(2),"""FY"",",ACHSACFY,",0)' at LOC1^ACHSPA0 failed.",!,"Someone else is using it. Try again later." D RTRN^ACHS Q
  1.  ;
  1.  S X=$G(^ACHS(9,DUZ(2),"FY",ACHSACFY,0))    ;FISCAL YEAR 0 NODE
  1.  S X1=$P(X,U,2)                      ;CURRENT ADVICE OF ALLOWANCE
  1.  S X2=$P(X,U,3)                      ;TOTAL OBLIGATED FYTD
  1.  I $$PARM^ACHS(2,2)="Y",ACHSACFY<ACHSCFY G A1 ;NEG. UNOBLIGATED BAL. PRIOR FY?
  1.  I (X2+A)'>X1 G A1                     ;IF WE STILL HAVE MONEY 
  1.  ;
  1.  W:'$D(ACHSISAO) *7,!,"Funds are not available for this overpayment",!,"Transaction Cancelled"
  1.  I ACHSACFY<ACHSCFY,'$D(ACHSISAO) W !!,"'",$P(^DD(9002080,14.02,0),U),"' parameter = '",$$PARM^ACHS(2,2),"'.",!!
  1.  I $$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,0)","-")
  1.  Q
  1.  ;
  1. A1 ;
  1.  I ACHSPIND="I" S $P(T,U,2)="IP"         ;TRANSACTION TYPE
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA,0)=T
  1.  ;
  1.  S ^ACHSF(DUZ(2),"TB",DT,$S(ACHSPIND="I":"IP",ACHSPIND="F":"P"),ACHSDIEN,ACHSTDA)=""
  1.  S:+DFN ^ACHSF("AC",DFN,DUZ(2),ACHSDIEN,ACHSTDA)=""
  1.  ;
  1.  ;ACHSPIND = 'EOBR PAY TYPE'
  1.  I ACHSPIND="F" D FINAL G EOBRCX ; Reset obligation at final payment.
  1.  I ACHSPIND="I" D INTRM^ACHSPA0A ; Don't reset obligation at Interim.
  1.  ;
  1. EOBRCX ;
  1.  I $$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY,0)","-")
  1.  ;;SET CROSS REFERENCES FOR EOBR HERE
  1.  ;
  1.  ;AGAIN HERE WE SET ALL THE CRAP THAT SHOULD BE SET BY FILEMAN
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA,0),U,13)=ACHSPDAT,$P(^(0),U,14)=ACHSPSQN,$P(^(0),U,15)=ACHSPIND
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,"EB1",ACHSPDAT,ACHSPSQN,ACHSTDA)=""
  1.  S ^ACHSF(DUZ(2),"PDOS",ACHSSVDT,ACHSDIEN,ACHSTDA)=""
  1.  S:$D(ACHSISAO) ^ACHSF(DUZ(2),"EOBD",9999999-ACHSPDAT,ACHSDIEN,ACHSTDA)=""
  1.  S ^ACHSF(DUZ(2),"EOBR",ACHSDIEN,ACHSTDA,9999999-ACHSPDAT)=""
  1.  S:$G(DFN) ^ACHSF(DUZ(2),"EOBP",DFN,ACHSDIEN,ACHSTDA,9999999-ACHSPDAT)=""
  1.  ;
  1.  ; Following 2 lines for auto EOBR processing after all 4
  1.  ; fields are available.  Presently, only DRG comes from
  1.  ; the auto EOBR.  Other items are entered manually after
  1.  ; document is paid, or from menu pick.
  1. C1 S Y="ACHSDRG^ACHSADDT^ACHSDIDT^ACHSDITY"
  1.  F %=1:1:4 I $G(@($P(Y,U,%))) D        ;SET ALL PIECES FOR 8 NODE
  1.  .S X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,8)),U,%),$P(^(8),U,%)=$S(X:X,1:@($P(Y,U,%)))
  1.  ;
  1.  I ACHSPROV,'$D(^AUTTVNDR(ACHSPROV)) W:'$D(ACHSISAO) *7,!!,"Vendor Amount Paid Not Updated:  Vendor not found.",! G END
  1.  I $G(ACHSISAO)=0,$D(^ACHSEOBR("ER",ACHSZFPT,ACHSCTR(1),36)) D END Q
  1.  ;
  1.  ;ACHSIPA='IHS PAYMENT AMOUNT"
  1.  S ACHSDAP=ACHSIPA
  1.  ;
  1.  D ^ACHSVPT      ;UPDATE VENDOR PAYMENT FILE  ^ACHSVPMT
  1.                  ;CHS VENDOR PAYMENTS^9002075
  1.  D END
  1.  Q
  1. END ;
  1.  S ACHSTIEN=ACHSTDA
  1.  Q
  1.  ;
  1. FINAL ; Adjust obligated FYTD at Final
  1.  S ACHSADJ=0
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U,6)=ACHSPAMT  ;FINAL PAY AMT.
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U)=ACHSPAMT     ;TOT PAY AMT
  1.  ;
  1.  ;IF WE HAVE BLANKET FORM PUT 'COMMENTS (OPTIONAL) INTO 'STATUS'
  1.  ;OTHERWISE PUT 3 = "PAID"
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12)=$S($D(ACHSISAO)&$D(ACHSBLKF):$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,12),1:3)
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U,2)=A       ;PAYMENT OBLIG. ADJ.
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U,3)=ACHSPDAT ;FINAL PAY. DATE 
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U,4)=ACHSPIND ;LAST PAYMENT TYPE
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U,5)=ACHS3RDP ;PAY. AMT 3RD PARTY
  1.  S ACHSDOCT=ACHSPAMT
  1.  ;
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP")) D
  1.  .S ACHSDOCT=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"IP"),U)+ACHSPAMT  ;INTERIM PAYMENT TOTAL
  1.  .S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U)=ACHSDOCT   ;TOT PAY AMT
  1.  S ACHSADJ=ACHSDOCT-($P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,9))  ;PRIOR PAY. POSTING DATE
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U,2)=ACHSADJ   ;PAY OBLIG ADJ
  1.  ;
  1.  S ACHSOBL=$P(^ACHS(9,DUZ(2),"FY",ACHSACFY,0),U,3)      ;TOT OBLIG FYTD
  1.  S ACHSREG=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,19)       ;DCR ACCT #
  1.  ;
  1.  S ACHSACWK=$P(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",0),U,3) ;LAST ENTRY 
  1.  S $P(^ACHS(9,DUZ(2),"FY",ACHSACFY,0),U,3)=ACHSOBL+ACHSADJ  ;TOT OBLIG AMT
  1.  S Y=$P(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1),U,ACHSREG) ;GET REGISTER BALANCE
  1.  S $P(^ACHS(9,DUZ(2),"FY",ACHSACFY,"W",ACHSACWK,1),U,ACHSREG)=Y+ACHSADJ
  1.  ;
  1.  I '$D(ACHSISAO) W !,"*** OBLIGATION REGISTER UPDATED ***",! Q
  1.  Q:ACHSISAO
  1.  ;
  1.  I '$D(ACHSSUM(ACHSY)) S ACHSSUM(ACHSY)="0^0^0^0^0^0^0"
  1.  S $P(ACHSSUM(ACHSY),U,ACHSREG)=$P(ACHSSUM(ACHSY),U,ACHSREG)+ACHSADJ
  1.  I '$D(ACHSSUM(ACHSY,"-")) S ACHSSUM(ACHSY,"-")=0
  1.  I $E(ACHSADJ,1)="-",ACHSADJ<O S $P(ACHSSUM(ACHSY,"-"),U,ACHSREG)=$P(ACHSSUM(ACHSY,"-"),U,ACHSREG)+ACHSADJ G TOT
  1.  I '$D(ACHSSUM(ACHSY,"+")) S ACHSSUM(ACHSY,"+")=0
  1.  I ACHSADJ>0 S $P(ACHSSUM(ACHSY,"+"),U,ACHSREG)=$P(ACHSSUM(ACHSY,"+"),U,ACHSREG)+ACHSADJ
  1. TOT ;
  1.  I '$D(ACHSTOT(ACHSY,"PAYMENTS")) S ACHSTOT(ACHSY,"PAYMENTS")="0^0"
  1.  S $P(ACHSTOT(ACHSY,"PAYMENTS"),U)=$P(ACHSTOT(ACHSY,"PAYMENTS"),U)+ACHSADJ
  1.  S $P(ACHSTOT(ACHSY,"PAYMENTS"),U,2)=$P(ACHSTOT(ACHSY,"PAYMENTS"),U,2)+1
  1.  Q
  1.  ;
  1.  ;INITIALIZE NEW TRANSACTION ENTRY
  1. SBTRN ;EP
  1.  ;TRY AND LOCK THE DOCUMENT
  1.  ;ACHS*3.1*11 8.27.04 IHS/OIT/FCJ SPLIT LINE AND ADDED SET OF ACHSQUIT
  1.  ;I '$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") W !,"LOCK on '^ACHSF(",DUZ(2),"""D"",",ACHSDIEN,")' at SBTRN^ACHSPA0 failed.",!,"Someone else is using it.  Try again later." D RTRN^ACHS Q
  1.  I $$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+")
  1.  E  W !,"LOCK on '^ACHSF(",DUZ(2),"""D"",",ACHSDIEN,")' at SBTRN^ACHSPA0 failed.",!,"Someone else is using it.  Try again later." D RTRN^ACHS S DUOUT=1 Q
  1.  ;ACHS*3.1*11 8.27.04 IHS/OIT/FCJ END OF CHANGES
  1.  ;
  1.  ;SET THE SUB FILE 0 NODE IF NOT THERE THEN DO ALL THE STUFF FILEMAN
  1.  ;WOULD DO FOR YOU IF YOU HAD PROGRAMMED IT RIGHT
  1.  S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)="^9002080.02D"
  1.  S ACHS=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))
  1.  S ACHSTDA=$P(ACHS,U,3)
  1.  ;
  1.  ;GET OPEN TRANSACTION ENTRY NUMBER
  1. SBTRN1 ;
  1.  S ACHSTDA=ACHSTDA+1
  1.  G SBTRN1:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTDA))
  1.  ;
  1.  S $P(ACHS,U,3)=ACHSTDA
  1.  S $P(ACHS,U,4)=$P(ACHS,U,4)+1
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=ACHS
  1.  ;ACHS*3.1*11 8.27.04 IHS/OIT/FCJ COMMENT NXT LNE, UNLOCKING DOC BEFORE ALL DATA ENTRY WAS COMPLETED
  1.  ;I $$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-")   ;UNLOCK DOCUMENT
  1.  ;
  1.  S ACHSOPAY=$P($G(^ACHSF(DUZ(2),"O",ACHSTYP,0)),U,2,3)  ;GET OVERPAYMENT
  1.                                                         ;AND MAX OVERPAY
  1.                                                         ;ALLOWED
  1.  ;
  1.  S ACHSTAO=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)),U,9)    ;TOT. OBLIGATED
  1.                                                         ;AMOUNT
  1.  I $D(ACHSISAO) S ACHSPAMT=+$G(ACHSIPA) Q
  1.  S ACHSPAMT=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U,6) ;FINAL PAYMENT
  1.                                                          ;AMOUNT
  1.  S ACHSIPA=0
  1.  Q
  1.  ;