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

ACHSAJ1.m

Go to the documentation of this file. 
  1. ACHSAJ1 ; IHS/ITSC/PMF - ADJUST A PAID DOCUMENT ;    [ 10/15/2004  3:01 PM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6**;JUNE 11, 2001
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ WRONG VARIABLE SET IN "T" AND "ZA" NODE
  1.  ;
  1.  ;
  1. D1 ;EP
  1.  ;SET THE TRANSACTION 0 NODE
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ CHANGED ACHS3PA TO ACHS3TAJ
  1.  ;S T=DT_"^ZA^"_$G(DFN)_U_ACHSESDO_"^^^^"_ACHS3PA_"^^"_ACHSSVDT_U_DUZ_U_ACHS3RDS_U_ACHSPDAT_U_ACHSPSQN_U_ACHSPIND  ;ACHS*3.1*6
  1.  S T=DT_"^ZA^"_$G(DFN)_U_ACHSESDO_"^^^^"_ACHS3TAJ_"^^"_ACHSSVDT_U_DUZ_U_ACHS3RDS_U_ACHSPDAT_U_ACHSPSQN_U_ACHSPIND  ;ACHS*3.1*6
  1.  ;
  1.  ;IF 'DOCUMENT DESTINATION' NOT EQUAL TO IHS
  1.  I $P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,17)'="I" D
  1.  .S T=T_U_U_ACHSCTL_U_ACHSCHK_U_ACHSREM_U_ACHSSV_U_ACHSOB
  1.  ;
  1.  S ACHSDOC0=$G(ACHSDOC0)
  1.  I ACHSDOC0="" S ACHSDOC0=ACHSDOCR
  1.  ;
  1.  ;S X=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))                ;DOCUMENT 0 NODE
  1.  S ACHSDCR=$P(ACHSDOC0,U,19) ;DCR ACCOUNT #  ;ACHSDOC0 FROM INIT^ACHSRP2
  1.  ;
  1.  I ACHSDCR<1 W:'$D(ACHSISAO) !,"DCR ACCOUNT ERROR " G:'$D(ACHSISAO) ENDC I $D(ACHSISAO) S ACHSERRE=26,ACHSEDAT=ACHSDCR,ACHSERRA=1 D K Q
  1.  ;
  1.  ;IF AREA OFFICE AND 'INTEREST PAID'  OR  'INTEREST ADDTNL PENALTY PAID'
  1.  I $D(ACHSISAO),$G(ACHSEOBR("I",12))!$G(ACHSEOBR("I",13)) D
  1.  . N C,D,O
  1.  . ; Find the DCReg for the Interest payment
  1.  . S ACHSDCR=7                            ;MISC CHARGES CATEGORY
  1.  .;
  1.  .S C=""
  1.  .I $G(ACHSEOBR("I",8))'="" D
  1.  .. S C=$O(^ACHS(2,"B",ACHSEOBR("I",8),0)) ;USE 'INTEREST CAN'
  1.  .                                         ;IN "B" NAME X-REF TO GET
  1.  .                                         ;TO GET THE COST CENTER PTR
  1.  . Q:'C
  1.  .;
  1.  . S C=$P($G(^ACHS(2,C,0)),U,2)            ;'COST CENTER' 
  1.  . Q:'C
  1.  . S C=$P($G(^ACHS(1,C,0)),U)              ;COST CENTER 'CODE'
  1.  . Q:'C
  1.  .S O=""
  1.  .I $G(ACHSEOBR("I",9))'="" D
  1.  .. S O=$O(^ACHS(3,DUZ(2),1,"B",ACHSEOBR("I",9),0)) ;USE 'INTEREST OBJECT
  1.  .;
  1.  .                                                 ;CLASS CODE IN "B"
  1.  .                                                 ;X-REF TO GET 'OBJECT
  1.  .                                                 ;CLASSIFICATION' PTR
  1.  . Q:'O                                            ;TO
  1.  . S C=$O(^ACHS(3,DUZ(2),1,O,"CC","B",C,0))        ;GET 
  1.  . Q:'C                                            ;THE
  1.  . S D=$P($G(^ACHS(3,DUZ(2),1,O,"CC",C,0)),U,2)    ;DCR ACCOUNT #
  1.  . I D>0,D<8 S ACHSDCR=D                           ;IF DCR IS 1-7
  1.  .                                                 ;USE IT ELSE DCR=7
  1.  .Q
  1.  ;
  1.  K ACHSCNC                           ;CLEAR ERROR FLAG
  1.  D AJ1
  1.  ;
  1.  I '$D(ACHSISAO) D ENTER^ACHSPAM     ;ENTER/EDIT MEDICAL DATA
  1.  I $D(ACHSISAO) D K Q                ;KILL OFF VARIABLES AND QUIT
  1.  ;
  1. END ;EP
  1.  I '$D(ACHSCNC) D
  1.  .W !!," ***  Document Updated  ***"
  1.  .D ACT^ACHSACT(ACHSDIEN,$$NOW^XLFDT,"<ADJUSTMENT>") ;SET ACTION TAKEN
  1.  ;
  1.  ;
  1. ENDC ;EP
  1.  W !
  1.  D RTRN^ACHS                     ;PRESS RETURN TO CONT.
  1. K ;EP - Unlock, kill vars, quit.
  1.  I $D(ACHSDIEN),'$$LOCK^ACHS("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-")
  1.  K ACHSADJ,ACHSAPA,ACHSJERR,ACHSNADJ,ACHSSIGN,ACHSTADJ,DA,X2,X3
  1.  K ACHSSV,ACHSCTL,ACHSCHK,ACHSREM,ACHSOB,ACHS3RDP,ACHS3AJ,ACHS3PA,ACHS3TAJ
  1.  Q
  1.  ;
  1. AJ1 ;
  1.  ;S X=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))   ;DOCUMENT 0 NODE
  1.  S ACHSX=$P(ACHSDOC0,U,14)            ;FISCAL YEAR LAST DIGIT
  1.  ;
  1.  D FYCVT^ACHSFU                      ;COMPUTE FISCAL YEAR
  1.  ;
  1.  S R=$P(ACHSDOC0,U,19)                      ;DCR ACCOUNT NUMBER
  1.  S (ACHSACFY,F)=ACHSY
  1.  S ACHSACWK=+ACHSFYWK(DUZ(2),ACHSACFY)
  1.  S A=ACHSAMT                          ;WHERE IS ACHSAMT SET?????
  1.                                       ;COULD BE 'IHS PAYMENT AMOUNT'
  1.                                       ;OR 'THIRD PARTY PAY AMT' OR
  1.                                       ;'PAYMENT OBLIG ADJUST'
  1.  I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY)","+") D  Q
  1.  . W !,"LOCK FAILED AT AJ1+4^ACHSAJ1"
  1.  . S ACHSCNC=""                       ;SET CANCEL FLAG
  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 $D(ACHSISAO) G SBF5                ;IF AREA OFFICE
  1.  ;
  1.  ;IF 'NEG. UNOBLIGATED BAL. PRIOR FY' AND THIS FY < CURRENT FY?????
  1.  I $$PARM^ACHS(2,2)="Y",ACHSACFY<ACHSCFY G SBF5
  1.  ;
  1.  ;
  1.  I X2+A>X1 D  Q
  1.  . W *7,!,"Funds are not available for this adjustment",!,"Transanction Cancelled"
  1.  . W:ACHSACFY<ACHSCFY !!,"'",$P($G(^DD(9002080,14.02,0)),U),"' parameter = '",$$PARM^ACHS(2,2),"'.",!!
  1.  . S ACHSCNC=""
  1.  . I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY)","-")
  1.  ;
  1. SBF5 ;EP from ACHSAJ for auto updates
  1.  S ACHS("CHK")=0,ACHSUFLG=""
  1.  ;
  1.  D SBAENT^ACHSUUP           ;Update Current Advice of Allowance
  1.                             ;and Total Obligated FYTD
  1.  ;
  1.  K ACHSUFLG
  1.  ;
  1.  ;AGAIN HE BYPASSES FILEMAN AND SETS THE TRANSACTION INTO THE FILE
  1.  ;MANUALLY??????
  1.  ;SET ZERO NODE IF NOT THERE
  1.  S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=$$ZEROTH^ACHS(9002080,100,100)
  1.  ;
  1.  S Y=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0))   ;GET TRANSACTION ZERO NODE
  1.  S DA(1)=$P(Y,U,3)
  1.  ;
  1.  F  S DA(1)=DA(1)+1 Q:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",DA(1)))
  1.  ;
  1.  S $P(Y,U,3)=DA(1)
  1.  S $P(Y,U,4)=DA(1)
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",0)=Y
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,"T",DA(1),0)=T
  1.  S ^ACHSF(DUZ(2),"TB",DT,"ZA",ACHSDIEN,DA(1))=""
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"),U)=ACHSAPA+ACHSAMT
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"),U,2)=ACHSTADJ+ACHSAMT
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"),U,3)=ACHSNADJ+1
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ CHANGED ACHS3TAJ TO ACHS3AJ NXT LINE
  1.  ;S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"),U,4)=ACHS3TAJ  ;ACHS*3.1*6
  1.  S $P(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"),U,4)=ACHS3AJ ;ACHS*3.1*6
  1.  S ^ACHSF(DUZ(2),"D",ACHSDIEN,"EB1",ACHSPDAT,ACHSPSQN,DA(1))=""
  1.  S ^ACHSF(DUZ(2),"PDOS",ACHSSVDT,ACHSDIEN,DA(1))=""
  1.  ;
  1.  ;IF THIS IS AREA OFFICE
  1.  S:$D(ACHSISAO) ^ACHSF(DUZ(2),"EOBD",9999999-ACHSEOBD,ACHSDIEN,DA(1))=""
  1.  ;
  1.  S ^ACHSF(DUZ(2),"EOBR",ACHSDIEN,DA(1),9999999-ACHSEOBD)=""
  1.  S:$G(DFN) ^ACHSF(DUZ(2),"EOBP",DFN,ACHSDIEN,DA(1),9999999-ACHSEOBD)=""
  1.  S (ACHSTDA,ACHSTIEN)=DA(1)
  1.  I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSACFY)","-")
  1.  ;
  1.  I '$D(^AUTTVNDR(ACHSPROV)) W:'$D(ACHSISAO) *7,!!,"Vendor Amount Paid Not Updated" Q
  1.  ;
  1.  ;ERROR 36 = VENDOR MISMATCH;W
  1.  I $G(ACHSISAO)=0,$D(^ACHSEOBR("ER",ACHSZFPT,ACHSCTR(1),36)) Q
  1.  S ACHSDAP=ACHSAMT
  1.  ;
  1.  D ^ACHSVPT     ;UPDATE VENDOR PAYMENTS FILE
  1.  Q
  1.  ;