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