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

ACHSBRF.m

Go to the documentation of this file. 
  1. ACHSBRF ; IHS/ITSC/TPF/PMF - FIX CHS REGISTER BALANCES ;  
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**22**;JUN 11, 2001;Build 43
  1.  ;
  1.  ; Prompt user for FY and register number.
  1.  ; Check to see if the register balances are correct.
  1.  ; If not, calculate and fix.
  1.  ;
  1.  ;  THANKS TO FONDA JACKSON OF PORTLAND FOR THE ORIGINAL ROUTINE.
  1.  ;
  1. START ;
  1.  ;  -----  Initialize vars.
  1.  I $G(ACHSFLG) G VARS
  1.  N ACHSFY,ACHSREG
  1. VARS ;
  1.  N ACHSDOCR,ACHSDIEN,ACHSTYPE,ACHSAMT,ACHSDCR,ACHSMAX,ACHSMIN,ACHSTOTL,ACHSBDT,ACHSEDT,ACHSTIEN,ACHSROUT,ACHSRPRV,ACHSRCOR
  1.  ;
  1.  F %=1:1:7 S ACHSDCR(%)=0      ;INITIALIZE 
  1.  ;
  1.  I $G(ACHSFLG) G DATES
  1.  ;
  1.  F %=0:0 S %=$O(ACHSFYWK(DUZ(2),%)) Q:'%  S ACHSMIN=$S('$D(ACHSMIN):%,1:ACHSMIN),ACHSMAX=%
  1.  ;
  1. FY ;  -----  Display FYs, ask FY.
  1.  ;
  1.  ;
  1.  D SB1^ACHSFU      ;DISPLAY VALID FISCAL YEARS
  1.  ;
  1.  S ACHSFY=$$DIR^XBDIR("N^"_ACHSMIN_":"_ACHSMAX_":0","ENTER FISCAL YEAR",ACHSMAX,"","ENTER FISCAL YEAR WITH ALL FOUR DIGITS","^D SB1^ACHSFU",1)
  1.  Q:$D(DUOUT)!$D(DTOUT)
  1.  I '$D(ACHSFYWK(DUZ(2),ACHSFY)) W !,"FY DOES NOT EXIST." G FY
  1.  ;
  1. REG ;  -----  Ask Register.
  1.  S ACHSREG=$$DIR^XBDIR("N^1:"_$P($G(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",0)),U,3)_":0","ENTER THE REGISTER NUMBER","","","","",1)
  1.  Q:$D(DUOUT)!$D(DTOUT)
  1.  I '$L($G(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,0))) W !!,"REGISTER DOES NOT EXIST." G REG
  1.  ;
  1. DATES ;
  1.  S ACHSBDT=$$BDT(ACHSFY,ACHSREG)
  1.  S ACHSEDT=$$EDT(ACHSFY,ACHSREG)
  1.  ;
  1.  ;
  1.  ;  -----  Total up the Transactions.
  1.  W !,"Checking transactions for FY ",ACHSFY,", Register ",ACHSREG,"."
  1.  ;
  1.  D WAIT^DICD    ;DISPLAY FILEMAN WAIT MESSAGE
  1.  ;
  1.  ;
  1.  F  S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT)) Q:(ACHSBDT>ACHSEDT)!(ACHSBDT'?1N.N)  S ACHSTYPE="" D
  1.  . F  S ACHSTYPE=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE)) Q:ACHSTYPE'?1A.A  S ACHSDIEN=0 D
  1.  ..Q:ACHSTYPE="IP"  ;Q IF INTERM PAY ;ACHS*3.1*22
  1.  ..F  S ACHSDIEN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,ACHSDIEN)) Q:ACHSDIEN'?1N.N  W "." S ACHSTIEN=0 D
  1.  ... F  S ACHSTIEN=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,ACHSDIEN,ACHSTIEN)) Q:ACHSTIEN'?1N.N  D
  1.  .... S ACHSDOCR=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))   ;GET DOCUMENT 0 NODE
  1.  ....;
  1.  .... Q:$P(ACHSDOCR,U,14)'=$E(ACHSFY,4)          ;USE ONLY CHOSEN FY
  1.  ....;
  1.  ....;'IHS PAYMENT AMOUNT'
  1.  .... S ACHSAMT=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,4)
  1.  ....;IF TYPE = "PAYMENT" OVERWRITE 'IHS PAYMENT AMOUNT' WITH
  1.  ....;'PAYMENT OBLIG ADJUST'   ?????
  1.  .... S:ACHSTYPE="P" ACHSAMT=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U,2)
  1.  ....;
  1.  ....;IF TYPE = "ADJUSTMENT" OVERWRITE 'IHS PAYMENT AMOUNT' WITH
  1.  ....;'PAYMENT OBLIG ADJUST'
  1.  .... S:ACHSTYPE="ZA" ACHSAMT=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")),U,2)
  1.  ....;
  1.  ....;IF TYPE = "CANCELATION" OVERWRITE 'IHS PAYMENT AMOUNT' THEN NEGATE
  1.  .... S:ACHSTYPE="C" ACHSAMT=-ACHSAMT
  1.  ....;
  1.  ....;ADD TO ACCOUNT  
  1.  .... S %=$P(ACHSDOCR,U,19)               ;'DCR ACCOUNT NUMBER'
  1.  .... S ACHSDCR(%)=ACHSDCR(%)+ACHSAMT
  1.  ....Q
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  ;
  1.  ;
  1.  ;  -----  Compare Transactions to Global
  1.  S (ACHSDOCR,ACHSTOTL,ACHSRPRV,ACHSRCOR)=0
  1.  ;
  1.  ;GET DCR BALANCES NODE 1    ;WHY -1 OFF ACHSREG??????
  1.  I ACHSREG>1 S ACHSRPRV=$G(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG-1,1))
  1.  ;
  1.  F %=1:1:7 S $P(ACHSRCOR,U,%)=$P(ACHSRPRV,U,%)+ACHSDCR(%)
  1.  ;
  1.  ;GET DCR BALANCES NODE 1    ;NO -1 OFF ACHSREG?????
  1.  S ACHSROUT=$G(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,1))
  1.  ;
  1.  ;
  1.  F %=1:1:7 S ACHSDCR(%)=$P(ACHSRCOR,U,%)-$P(ACHSROUT,U,%) D
  1.  .I ACHSDCR(%)'=0 D
  1.  ..S ACHSTOTL=ACHSDCR(%)+ACHSTOTL
  1.  ..W !!,"Balance for Account ",%
  1.  ..W " (",$P($G(^ACHS(9,DUZ(2),"RN")),U,%)             ;R-% NAME
  1.  ..W ") is off by ",$FN(ACHSDCR(%),",",2),"."      ;
  1.  ;
  1.  I ACHSTOTL=0 W !!,"Account Balances are correct." I '$O(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG)) D
  1.  . S ACHS=0
  1.  . F %=1:1:7 S ACHS=ACHS+$P(ACHSRCOR,U,%)
  1.  . 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),"."
  1.  .Q
  1.  ;
  1.  ;  -----  Check Totals, Update Global.
  1.  I '$$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFY)","+") W !!,"FILE IN USE BY ANOTHER USER, TRY LATER.........." G EXIT
  1.  W !!,"UPDATING ACCOUNT BALANCES FOR THE REGISTERS."
  1.  S ^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG,1)=ACHSRCOR
  1.  I '$O(^ACHS(9,DUZ(2),"FY",ACHSFY,"W",ACHSREG)) D
  1.  . S ACHS=0
  1.  . F %=1:1:7 S ACHS=ACHS+$P(ACHSRCOR,U,%)
  1.  . W !,"UPDATING YTD OBLIGATED."
  1.  . S $P(^ACHS(9,DUZ(2),"FY",ACHSFY,0),U,3)=ACHS
  1.  .Q
  1.  I $$LOCK^ACHS("^ACHS(9,DUZ(2),""FY"",ACHSFY)","-")
  1.  W !,"Done."
  1. EXIT ;
  1.  Q
  1.  ;
  1. BDT(F,R) ; Given FY and Reg #, return the Beginning date of the Register.
  1.  I R>1 Q $P($G(^ACHS(9,DUZ(2),"FY",F,"W",R-1,0)),U,2)
  1.  Q ((F-1700)_$P($G(^ACHSF(DUZ(2),0)),U,6))-1
  1.  ;
  1. EDT(F,R) ; Given FY and Reg #, return the Ending date of the Register.
  1.  S X=$P($G(^ACHS(9,DUZ(2),"FY",F,"W",R,0)),U,2)
  1.  I X Q X
  1.  Q DT
  1.  ;
  1. FIX(ACHSFY,ACHSREG) ;EP - Fix the Acct Balances and YTD obligated.
  1.  N ACHSFLG
  1.  S ACHSFLG=1
  1.  G START
  1.  ;