ACHSBRF ; IHS/ITSC/TPF/PMF - FIX CHS REGISTER BALANCES ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22**;JUN 11, 2001;Build 43
;
; Prompt user for FY and register number.
; Check to see if the register balances are correct.
; If not, calculate and fix.
;
; THANKS TO FONDA JACKSON OF PORTLAND FOR THE ORIGINAL ROUTINE.
;
START ;
; ----- Initialize vars.
I $G(ACHSFLG) G VARS
N ACHSFY,ACHSREG
VARS ;
N ACHSDOCR,ACHSDIEN,ACHSTYPE,ACHSAMT,ACHSDCR,ACHSMAX,ACHSMIN,ACHSTOTL,ACHSBDT,ACHSEDT,ACHSTIEN,ACHSROUT,ACHSRPRV,ACHSRCOR
;
F %=1:1:7 S ACHSDCR(%)=0 ;INITIALIZE
;
I $G(ACHSFLG) G DATES
;
F %=0:0 S %=$O(ACHSFYWK(DUZ(2),%)) Q:'% S ACHSMIN=$S('$D(ACHSMIN):%,1:ACHSMIN),ACHSMAX=%
;
FY ; ----- Display FYs, ask FY.
;
;
D SB1^ACHSFU ;DISPLAY VALID FISCAL YEARS
;
S ACHSFY=$$DIR^XBDIR("N^"_ACHSMIN_":"_ACHSMAX_":0","ENTER FISCAL YEAR",ACHSMAX,"","ENTER FISCAL YEAR WITH ALL FOUR DIGITS","^D SB1^ACHSFU",1)
Q:$D(DUOUT)!$D(DTOUT)
I '$D(ACHSFYWK(DUZ(2),ACHSFY)) W !,"FY DOES NOT EXIST." G FY
;
REG ; ----- Ask Register.
S ACHSREG=$$DIR^XBDIR("N^1:"_$P($G(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",0)),U,3)_":0","ENTER THE REGISTER NUMBER","","","","",1)
Q:$D(DUOUT)!$D(DTOUT)
I '$L($G(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,0))) W !!,"REGISTER DOES NOT EXIST." G REG
;
DATES ;
S ACHSBDT=$$BDT(ACHSFY,ACHSREG)
S ACHSEDT=$$EDT(ACHSFY,ACHSREG)
;
;
; ----- Total up the Transactions.
W !,"Checking transactions for FY ",ACHSFY,", Register ",ACHSREG,"."
;
D WAIT^DICD ;DISPLAY FILEMAN WAIT MESSAGE
;
;
F S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT)) Q:(ACHSBDT>ACHSEDT)!(ACHSBDT'?1N.N) S ACHSTYPE="" D
. F S ACHSTYPE=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE)) Q:ACHSTYPE'?1A.A S ACHSDIEN=0 D
..Q:ACHSTYPE="IP" ;Q IF INTERM PAY ;ACHS*3.1*22
..F S ACHSDIEN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,ACHSDIEN)) Q:ACHSDIEN'?1N.N W "." S ACHSTIEN=0 D
... F S ACHSTIEN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,ACHSDIEN,ACHSTIEN)) Q:ACHSTIEN'?1N.N D
.... S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) ;GET DOCUMENT 0 NODE
....;
.... Q:$P(ACHSDOCR,U,14)'=$E(ACHSFY,4) ;USE ONLY CHOSEN FY
....;
....;'IHS PAYMENT AMOUNT'
.... S ACHSAMT=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,4)
....;IF TYPE = "PAYMENT" OVERWRITE 'IHS PAYMENT AMOUNT' WITH
....;'PAYMENT OBLIG ADJUST' ?????
.... S:ACHSTYPE="P" ACHSAMT=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U,2)
....;
....;IF TYPE = "ADJUSTMENT" OVERWRITE 'IHS PAYMENT AMOUNT' WITH
....;'PAYMENT OBLIG ADJUST'
.... S:ACHSTYPE="ZA" ACHSAMT=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,2)
....;
....;IF TYPE = "CANCELATION" OVERWRITE 'IHS PAYMENT AMOUNT' THEN NEGATE
.... S:ACHSTYPE="C" ACHSAMT=-ACHSAMT
....;
....;ADD TO ACCOUNT
.... S %=$P(ACHSDOCR,U,19) ;'DCR ACCOUNT NUMBER'
.... S ACHSDCR(%)=ACHSDCR(%)+ACHSAMT
....Q
...Q
..Q
.Q
;
;
; ----- Compare Transactions to Global
S (ACHSDOCR,ACHSTOTL,ACHSRPRV,ACHSRCOR)=0
;
;GET DCR BALANCES NODE 1 ;WHY -1 OFF ACHSREG??????
I ACHSREG>1 S ACHSRPRV=$G(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG-1,1))
;
F %=1:1:7 S $P(ACHSRCOR,U,%)=$P(ACHSRPRV,U,%)+ACHSDCR(%)
;
;GET DCR BALANCES NODE 1 ;NO -1 OFF ACHSREG?????
S ACHSROUT=$G(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,1))
;
;
F %=1:1:7 S ACHSDCR(%)=$P(ACHSRCOR,U,%)-$P(ACHSROUT,U,%) D
.I ACHSDCR(%)'=0 D
..S ACHSTOTL=ACHSDCR(%)+ACHSTOTL
..W !!,"Balance for Account ",%
..W " (",$P($G(^ACHS(9,DUZ(2),"RN")),U,%) ;R-% NAME
..W ") is off by ",$FN(ACHSDCR(%),",",2),"." ;
;
I ACHSTOTL=0 W !!,"Account Balances are correct." I '$O(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG)) D
. S ACHS=0
. F %=1:1:7 S ACHS=ACHS+$P(ACHSRCOR,U,%)
. I $P($G(^ACHS(9,DUZ(2),"FY",ACHSFY,0)),U,3)'=ACHS W !,"YTD Amount is ",$FN($P($G(^ACHS(9,DUZ(2),ACHSFY,0)),U,3),",",2)," and should be ",$FN(ACHS,",",2),"."
.Q
;
; ----- Check Totals, Update Global.
I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFY)","+") W !!,"FILE IN USE BY ANOTHER USER, TRY LATER.........." G EXIT
W !!,"UPDATING ACCOUNT BALANCES FOR THE REGISTERS."
S ^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,1)=ACHSRCOR
I '$O(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG)) D
. S ACHS=0
. F %=1:1:7 S ACHS=ACHS+$P(ACHSRCOR,U,%)
. W !,"UPDATING YTD OBLIGATED."
. S $P(^ACHS(9,DUZ(2),"FY",ACHSFY,0),U,3)=ACHS
.Q
I $$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFY)","-")
W !,"Done."
EXIT ;
Q
;
BDT(F,R) ; Given FY and Reg #, return the Beginning date of the Register.
I R>1 Q $P($G(^ACHS(9,DUZ(2),"FY",F,"W",R-1,0)),U,2)
Q ((F-1700)_$P($G(^ACHSF(DUZ(2),0)),U,6))-1
;
EDT(F,R) ; Given FY and Reg #, return the Ending date of the Register.
S X=$P($G(^ACHS(9,DUZ(2),"FY",F,"W",R,0)),U,2)
I X Q X
Q DT
;
FIX(ACHSFY,ACHSREG) ;EP - Fix the Acct Balances and YTD obligated.
N ACHSFLG
S ACHSFLG=1
G START
;
ACHSBRF ; IHS/ITSC/TPF/PMF - FIX CHS REGISTER BALANCES ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22**;JUN 11, 2001;Build 43
+2 ;
+3 ; Prompt user for FY and register number.
+4 ; Check to see if the register balances are correct.
+5 ; If not, calculate and fix.
+6 ;
+7 ; THANKS TO FONDA JACKSON OF PORTLAND FOR THE ORIGINAL ROUTINE.
+8 ;
START ;
+1 ; ----- Initialize vars.
+2 IF $GET(ACHSFLG)
GOTO VARS
+3 NEW ACHSFY,ACHSREG
VARS ;
+1 NEW ACHSDOCR,ACHSDIEN,ACHSTYPE,ACHSAMT,ACHSDCR,ACHSMAX,ACHSMIN,ACHSTOTL,ACHSBDT,ACHSEDT,ACHSTIEN,ACHSROUT,ACHSRPRV,ACHSRCOR
+2 ;
+3 ;INITIALIZE
FOR %=1:1:7
SET ACHSDCR(%)=0
+4 ;
+5 IF $GET(ACHSFLG)
GOTO DATES
+6 ;
+7 FOR %=0:0
SET %=$ORDER(ACHSFYWK(DUZ(2),%))
IF '%
QUIT
SET ACHSMIN=$SELECT('$DATA(ACHSMIN):%,1:ACHSMIN)
SET ACHSMAX=%
+8 ;
FY ; ----- Display FYs, ask FY.
+1 ;
+2 ;
+3 ;DISPLAY VALID FISCAL YEARS
DO SB1^ACHSFU
+4 ;
+5 SET ACHSFY=$$DIR^XBDIR("N^"_ACHSMIN_":"_ACHSMAX_":0","ENTER FISCAL YEAR",ACHSMAX,"","ENTER FISCAL YEAR WITH ALL FOUR DIGITS","^D SB1^ACHSFU",1)
+6 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+7 IF '$DATA(ACHSFYWK(DUZ(2),ACHSFY))
WRITE !,"FY DOES NOT EXIST."
GOTO FY
+8 ;
REG ; ----- Ask Register.
+1 SET ACHSREG=$$DIR^XBDIR("N^1:"_$PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",0)),U,3)_":0","ENTER THE REGISTER NUMBER","","","","",1)
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+3 IF '$LENGTH($GET(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,0)))
WRITE !!,"REGISTER DOES NOT EXIST."
GOTO REG
+4 ;
DATES ;
+1 SET ACHSBDT=$$BDT(ACHSFY,ACHSREG)
+2 SET ACHSEDT=$$EDT(ACHSFY,ACHSREG)
+3 ;
+4 ;
+5 ; ----- Total up the Transactions.
+6 WRITE !,"Checking transactions for FY ",ACHSFY,", Register ",ACHSREG,"."
+7 ;
+8 ;DISPLAY FILEMAN WAIT MESSAGE
DO WAIT^DICD
+9 ;
+10 ;
+11 FOR
SET ACHSBDT=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT))
IF (ACHSBDT>ACHSEDT)!(ACHSBDT'?1N.N)
QUIT
SET ACHSTYPE=""
Begin DoDot:1
+12 FOR
SET ACHSTYPE=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE))
IF ACHSTYPE'?1A.A
QUIT
SET ACHSDIEN=0
Begin DoDot:2
+13 ;Q IF INTERM PAY ;ACHS*3.1*22
IF ACHSTYPE="IP"
QUIT
+14 FOR
SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,ACHSDIEN))
IF ACHSDIEN'?1N.N
QUIT
WRITE "."
SET ACHSTIEN=0
Begin DoDot:3
+15 FOR
SET ACHSTIEN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,ACHSDIEN,ACHSTIEN))
IF ACHSTIEN'?1N.N
QUIT
Begin DoDot:4
+16 ;GET DOCUMENT 0 NODE
SET ACHSDOCR=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
+17 ;
+18 ;USE ONLY CHOSEN FY
IF $PIECE(ACHSDOCR,U,14)'=$EXTRACT(ACHSFY,4)
QUIT
+19 ;
+20 ;'IHS PAYMENT AMOUNT'
+21 SET ACHSAMT=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,4)
+22 ;IF TYPE = "PAYMENT" OVERWRITE 'IHS PAYMENT AMOUNT' WITH
+23 ;'PAYMENT OBLIG ADJUST' ?????
+24 IF ACHSTYPE="P"
SET ACHSAMT=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U,2)
+25 ;
+26 ;IF TYPE = "ADJUSTMENT" OVERWRITE 'IHS PAYMENT AMOUNT' WITH
+27 ;'PAYMENT OBLIG ADJUST'
+28 IF ACHSTYPE="ZA"
SET ACHSAMT=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,2)
+29 ;
+30 ;IF TYPE = "CANCELATION" OVERWRITE 'IHS PAYMENT AMOUNT' THEN NEGATE
+31 IF ACHSTYPE="C"
SET ACHSAMT=-ACHSAMT
+32 ;
+33 ;ADD TO ACCOUNT
+34 ;'DCR ACCOUNT NUMBER'
SET %=$PIECE(ACHSDOCR,U,19)
+35 SET ACHSDCR(%)=ACHSDCR(%)+ACHSAMT
+36 QUIT
End DoDot:4
+37 QUIT
End DoDot:3
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 ;
+41 ;
+42 ; ----- Compare Transactions to Global
+43 SET (ACHSDOCR,ACHSTOTL,ACHSRPRV,ACHSRCOR)=0
+44 ;
+45 ;GET DCR BALANCES NODE 1 ;WHY -1 OFF ACHSREG??????
+46 IF ACHSREG>1
SET ACHSRPRV=$GET(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG-1,1))
+47 ;
+48 FOR %=1:1:7
SET $PIECE(ACHSRCOR,U,%)=$PIECE(ACHSRPRV,U,%)+ACHSDCR(%)
+49 ;
+50 ;GET DCR BALANCES NODE 1 ;NO -1 OFF ACHSREG?????
+51 SET ACHSROUT=$GET(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,1))
+52 ;
+53 ;
+54 FOR %=1:1:7
SET ACHSDCR(%)=$PIECE(ACHSRCOR,U,%)-$PIECE(ACHSROUT,U,%)
Begin DoDot:1
+55 IF ACHSDCR(%)'=0
Begin DoDot:2
+56 SET ACHSTOTL=ACHSDCR(%)+ACHSTOTL
+57 WRITE !!,"Balance for Account ",%
+58 ;R-% NAME
WRITE " (",$PIECE($GET(^ACHS(9,DUZ(2),"RN")),U,%)
+59 ;
WRITE ") is off by ",$FNUMBER(ACHSDCR(%),",",2),"."
End DoDot:2
End DoDot:1
+60 ;
+61 IF ACHSTOTL=0
WRITE !!,"Account Balances are correct."
IF '$ORDER(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG))
Begin DoDot:1
+62 SET ACHS=0
+63 FOR %=1:1:7
SET ACHS=ACHS+$PIECE(ACHSRCOR,U,%)
+64 IF $PIECE($GET(^ACHS(9,DUZ(2),"FY",ACHSFY,0)),U,3)'=ACHS
WRITE !,"YTD Amount is ",$FNUMBER($PIECE($GET(^ACHS(9,DUZ(2),ACHSFY,0)),U,3),",",2)," and should be ",$FNUMBER(ACHS,",",2),"."
+65 QUIT
End DoDot:1
+66 ;
+67 ; ----- Check Totals, Update Global.
+68 IF '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFY)","+")
WRITE !!,"FILE IN USE BY ANOTHER USER, TRY LATER.........."
GOTO EXIT
+69 WRITE !!,"UPDATING ACCOUNT BALANCES FOR THE REGISTERS."
+70 SET ^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,1)=ACHSRCOR
+71 IF '$ORDER(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG))
Begin DoDot:1
+72 SET ACHS=0
+73 FOR %=1:1:7
SET ACHS=ACHS+$PIECE(ACHSRCOR,U,%)
+74 WRITE !,"UPDATING YTD OBLIGATED."
+75 SET $PIECE(^ACHS(9,DUZ(2),"FY",ACHSFY,0),U,3)=ACHS
+76 QUIT
End DoDot:1
+77 IF $$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFY)","-")
+78 WRITE !,"Done."
EXIT ;
+1 QUIT
+2 ;
BDT(F,R) ; Given FY and Reg #, return the Beginning date of the Register.
+1 IF R>1
QUIT $PIECE($GET(^ACHS(9,DUZ(2),"FY",F,"W",R-1,0)),U,2)
+2 QUIT ((F-1700)_$PIECE($GET(^ACHSF(DUZ(2),0)),U,6))-1
+3 ;
EDT(F,R) ; Given FY and Reg #, return the Ending date of the Register.
+1 SET X=$PIECE($GET(^ACHS(9,DUZ(2),"FY",F,"W",R,0)),U,2)
+2 IF X
QUIT X
+3 QUIT DT
+4 ;
FIX(ACHSFY,ACHSREG) ;EP - Fix the Acct Balances and YTD obligated.
+1 NEW ACHSFLG
+2 SET ACHSFLG=1
+3 GOTO START
+4 ;
