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