ACRFCAA ;IHS/OIRM/DSD/THL,AEF - CALCULATE QUARTERLY ALLOWANCE TOTALS; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;ROUTINE USED TO CALCULATE QUARTERLY ALLOWANCE TOTALS
EN S ACRX=@ACRGREF@(ACRZDA,"DT"),ACR0=@ACRGREF@(ACRZDA,0),ACRAMT=+ACR0,ACRORIG=$P(ACR0,U,8)
S ACRFY=$P(ACRX,U)
S ACRQT=$P(ACRX,U,2)
S ACRREC=$E($P(ACRX,U,3))
S ACRAPPNO=$P(ACRX,U,4)
S ACRALWNO=$P(ACRX,U,5)
S ACRBANO=$P(ACRX,U,6)
S ACRSSANO=$P(ACRX,U,8)
S ACRAPTNO=$P(ACRX,U,13)
D CALC
S ACRALW=$P(^AUTTALLW(ACRALWNO,0),U)
S ACRAPP=$P(^AUTTPRO(ACRAPPNO,0),U)
S ACRBA=$P(^AUTTBA(ACRBANO,0),U,2)
S ACRAPT=$P(^AUTTACPT(ACRAPTNO,0),U)
S Y=DT
X ^DD("DD")
S ACRTODAY=Y
S ACRAMDNO=1
S ACRSTRET="300 SAN MATEO, N.E., SUITE 600"
S ACRCITY="ALBUQUERQUE"
S ACRSTATE="NM"
S ACRZIP="87108"
S ACRTO="CMB"
D ^ACRFPAA
D EXIT
Q
CALC S (ACRX,ACRO1,ACRI1,ACRD1,ACRNO1,ACRNI1,ACRND1,ACRTNO1,ACRTNI1,ACRTND1,ACRO2,ACRI2,ACRD2,ACRNO2,ACRNI2,ACRND2,ACRTNO2,ACRTNI2,ACRTND2,ACRO3,ACRI3,ACRD3,ACRNO3,ACRNI3,ACRND3,ACRTNO3,ACRTNI3,ACRTND3)=0
S (ACRO4,ACRI4,ACRD4,ACRNO4,ACRNI4,ACRND4,ACRTNO4,ACRTNI4,ACRTND4)=0
F S ACRX=$O(@ACRGREF@("AC",ACRALWNO,ACRFY,ACRX)) Q:'ACRX D SET
D SSA
Q
FIRST ;
S:ACRREC="R"&(ACRORIG="O") ACRO1=ACRO1+ACRAMT
S:ACRREC="R"&(ACRORIG="I") ACRI1=ACRI1+ACRAMT
S:ACRREC="R"&(ACRORIG="D") ACRD1=ACRD1+ACRAMT
S:ACRREC='"R"&(ACRORIG="O") ACRNO1=ACRNO1+ACRAMT
S:ACRREC='"R"&(ACRORIG="I") ACRNI1=ACRNI1+ACRAMT
S:ACRREC='"R"&(ACRORIG="D") ACRND1=ACRND1+ACRAMT
S ACRTNO1=ACRTNO1+ACRNO1,ACRTNI1=ACRTNI1+ACRNI1,ACRTND1=ACRTND1+ACRND1
Q
SECOND ;
S:ACRREC="R"&(ACRORIG="O") ACRO2=ACRO2+ACRAMT
S:ACRREC="R"&(ACRORIG="I") ACRI2=ACRI2+ACRAMT
S:ACRREC="R"&(ACRORIG="D") ACRD2=ACRD2+ACRAMT
S:ACRREC='"R"&(ACRORIG="O") ACRNO2=ACRNO2+ACRAMT
S:ACRREC='"R"&(ACRORIG="I") ACRNI2=ACRNI2+ACRAMT
S:ACRREC='"R"&(ACRORIG="D") ACRND2=ACRND2+ACRAMT
S ACRTNO2=ACRTNO2+ACRNO2,ACRTNI2=ACRTNI2+ACRNI2,ACRTND2=ACRTND2+ACRND2
Q
THIRD ;
S:ACRREC="R"&(ACRORIG="O") ACRO3=ACRO3+ACRAMT
S:ACRREC="R"&(ACRORIG="I") ACRI3=ACRI3+ACRAMT
S:ACRREC="R"&(ACRORIG="D") ACRD3=ACRD3+ACRAMT
S:ACRREC='"R"&(ACRORIG="O") ACRNO3=ACRNO3+ACRAMT
S:ACRREC='"R"&(ACRORIG="I") ACRNI3=ACRNI3+ACRAMT
S:ACRREC='"R"&(ACRORIG="D") ACRND3=ACRND3+ACRAMT
S ACRTNO3=ACRTNO3+ACRNO3,ACRTNI3=ACRTNI3+ACRNI3,ACRTND3=ACRTND3+ACRND3
Q
FOURTH ;
S:ACRREC="R"&(ACRORIG="O") ACRO4=ACRO4+ACRAMT
S:ACRREC="R"&(ACRORIG="I") ACRI4=ACRI4+ACRAMT
S:ACRREC="R"&(ACRORIG="D") ACRD4=ACRD4+ACRAMT
S:ACRREC='"R"&(ACRORIG="O") ACRNO4=ACRNO4+ACRAMT
S:ACRREC='"R"&(ACRORIG="I") ACRNI4=ACRNI4+ACRAMT
S:ACRREC='"R"&(ACRORIG="D") ACRND4=ACRND4+ACRAMT
S ACRTNO4=ACRTNO4+ACRNO4,ACRTNI4=ACRTNI4+ACRNI4,ACRTND4=ACRTND4+ACRND4
Q
EXIT K ACRAMT,ACRAPTNO,ACRD,ACRND1,ACRND2,ACRND3,ACRND4,ACRNI1,ACRNI2
K ACRNI3,ACRNI4,ACRNO1,ACRNO2,ACRNO3,ACRNO4,ACRORIG,ACRQT,ACRTND1
K ACRTND2,ACRTND3,ACRTND4,ACRTNI1,ACRTNI2,ACRTNI3,ACRTNI4,ACRTNO1
K ACRTNO2,ACRTNO3,ACRTNO4,ACRY,ACRZ
K ^TMP("ACRSSA",$J)
K ACRO1,ACRO2,ACRO3,ACRO4,ACRQ1,ACRO1,ACRI1,ACRD1,ACRQ2,ACRO2,ACRI2
K ACRD2,ACRQ3,ACRO3,ACRI3,ACRD3,ACRQ4,ACRO4,ACRI4,ACRD4,ACRGTOT,ACRQ1
K ACRQ2,ACRQ3,ACRQ4,ACRTI,ACRI1,ACRI2,ACRI3,ACRI4,ACRTD,ACRD1,ACRD2
K ACRD3,ACRD4,ACRFY,ACRSSANO
K ACRTOT,ACRREC,ACRNREC,ACRSSA,ACRREC,ACRNREC,ACRTOT,ACRRTOT,ACRNTOT
K ACRSSA,ACRX,ACRI,ACRALW,ACRAMDNO,ACRTODAY,ACRTO,ACRSTRET,ACRCITY
K ACRSTATE,ACRZIP,ACRAPP,ACRAPPNO,ACRAPT,ACRBA,ACRBANO
Q
SET S ^TMP("ACRSSA",$J,ACRSSANO,ACRX)=ACRAMT_"^"_ACRREC
S ^TMP("ACRSSA",$J,"TOT",ACRSSANO)="0^0"
S ACRD=$S(ACRQT=1:"FIRST",ACRQT=2:"SECOND",ACRQT=3:"THIRD",1:"FOURTH")
D @ACRD
Q
SSA S ACRSSANO=0
F S ACRSSANO=$O(^TMP("ACRSSA",$J,ACRSSANO)) Q:'ACRSSANO D
.S ACRZ=0
.F S ACRZ=$O(^TMP("ACRSSA",$J,ACRSSANO,ACRZ)) Q:'ACRZ D
..S ACRY=^TMP("ACRSSA",$J,ACRSSANO,ACRZ)
..D SSA1
Q
SSA1 S:$P(ACRY,U,2)="R" $P(^TMP("ACRSSA",$J,"TOT",ACRSSANO),U)=$P(^TMP("ACRSSA",$J,"TOT",ACRSSANO),U)+$P(ACRY,U)
S:$P(ACRY,U,2)="N" $P(^TMP("ACRSSA",$J,"TOT",ACRSSANO),U,2)=$P(^TMP("ACRSSA",$J,"TOT",ACRSSANO),U,2)+$P(ACRY,U)
Q
ACRFCAA ;IHS/OIRM/DSD/THL,AEF - CALCULATE QUARTERLY ALLOWANCE TOTALS; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;ROUTINE USED TO CALCULATE QUARTERLY ALLOWANCE TOTALS
EN SET ACRX=@ACRGREF@(ACRZDA,"DT")
SET ACR0=@ACRGREF@(ACRZDA,0)
SET ACRAMT=+ACR0
SET ACRORIG=$PIECE(ACR0,U,8)
+1 SET ACRFY=$PIECE(ACRX,U)
+2 SET ACRQT=$PIECE(ACRX,U,2)
+3 SET ACRREC=$EXTRACT($PIECE(ACRX,U,3))
+4 SET ACRAPPNO=$PIECE(ACRX,U,4)
+5 SET ACRALWNO=$PIECE(ACRX,U,5)
+6 SET ACRBANO=$PIECE(ACRX,U,6)
+7 SET ACRSSANO=$PIECE(ACRX,U,8)
+8 SET ACRAPTNO=$PIECE(ACRX,U,13)
+9 DO CALC
+10 SET ACRALW=$PIECE(^AUTTALLW(ACRALWNO,0),U)
+11 SET ACRAPP=$PIECE(^AUTTPRO(ACRAPPNO,0),U)
+12 SET ACRBA=$PIECE(^AUTTBA(ACRBANO,0),U,2)
+13 SET ACRAPT=$PIECE(^AUTTACPT(ACRAPTNO,0),U)
+14 SET Y=DT
+15 XECUTE ^DD("DD")
+16 SET ACRTODAY=Y
+17 SET ACRAMDNO=1
+18 SET ACRSTRET="300 SAN MATEO, N.E., SUITE 600"
+19 SET ACRCITY="ALBUQUERQUE"
+20 SET ACRSTATE="NM"
+21 SET ACRZIP="87108"
+22 SET ACRTO="CMB"
+23 DO ^ACRFPAA
+24 DO EXIT
+25 QUIT
CALC SET (ACRX,ACRO1,ACRI1,ACRD1,ACRNO1,ACRNI1,ACRND1,ACRTNO1,ACRTNI1,ACRTND1,ACRO2,ACRI2,ACRD2,ACRNO2,ACRNI2,ACRND2,ACRTNO2,ACRTNI2,ACRTND2,ACRO3,ACRI3,ACRD3,ACRNO3,ACRNI3,ACRND3,ACRTNO3,ACRTNI3,ACRTND3)=0
+1 SET (ACRO4,ACRI4,ACRD4,ACRNO4,ACRNI4,ACRND4,ACRTNO4,ACRTNI4,ACRTND4)=0
+2 FOR
SET ACRX=$ORDER(@ACRGREF@("AC",ACRALWNO,ACRFY,ACRX))
IF 'ACRX
QUIT
DO SET
+3 DO SSA
+4 QUIT
FIRST ;
+1 IF ACRREC="R"&(ACRORIG="O")
SET ACRO1=ACRO1+ACRAMT
+2 IF ACRREC="R"&(ACRORIG="I")
SET ACRI1=ACRI1+ACRAMT
+3 IF ACRREC="R"&(ACRORIG="D")
SET ACRD1=ACRD1+ACRAMT
+4 IF ACRREC='"R"&(ACRORIG="O")
SET ACRNO1=ACRNO1+ACRAMT
+5 IF ACRREC='"R"&(ACRORIG="I")
SET ACRNI1=ACRNI1+ACRAMT
+6 IF ACRREC='"R"&(ACRORIG="D")
SET ACRND1=ACRND1+ACRAMT
+7 SET ACRTNO1=ACRTNO1+ACRNO1
SET ACRTNI1=ACRTNI1+ACRNI1
SET ACRTND1=ACRTND1+ACRND1
+8 QUIT
SECOND ;
+1 IF ACRREC="R"&(ACRORIG="O")
SET ACRO2=ACRO2+ACRAMT
+2 IF ACRREC="R"&(ACRORIG="I")
SET ACRI2=ACRI2+ACRAMT
+3 IF ACRREC="R"&(ACRORIG="D")
SET ACRD2=ACRD2+ACRAMT
+4 IF ACRREC='"R"&(ACRORIG="O")
SET ACRNO2=ACRNO2+ACRAMT
+5 IF ACRREC='"R"&(ACRORIG="I")
SET ACRNI2=ACRNI2+ACRAMT
+6 IF ACRREC='"R"&(ACRORIG="D")
SET ACRND2=ACRND2+ACRAMT
+7 SET ACRTNO2=ACRTNO2+ACRNO2
SET ACRTNI2=ACRTNI2+ACRNI2
SET ACRTND2=ACRTND2+ACRND2
+8 QUIT
THIRD ;
+1 IF ACRREC="R"&(ACRORIG="O")
SET ACRO3=ACRO3+ACRAMT
+2 IF ACRREC="R"&(ACRORIG="I")
SET ACRI3=ACRI3+ACRAMT
+3 IF ACRREC="R"&(ACRORIG="D")
SET ACRD3=ACRD3+ACRAMT
+4 IF ACRREC='"R"&(ACRORIG="O")
SET ACRNO3=ACRNO3+ACRAMT
+5 IF ACRREC='"R"&(ACRORIG="I")
SET ACRNI3=ACRNI3+ACRAMT
+6 IF ACRREC='"R"&(ACRORIG="D")
SET ACRND3=ACRND3+ACRAMT
+7 SET ACRTNO3=ACRTNO3+ACRNO3
SET ACRTNI3=ACRTNI3+ACRNI3
SET ACRTND3=ACRTND3+ACRND3
+8 QUIT
FOURTH ;
+1 IF ACRREC="R"&(ACRORIG="O")
SET ACRO4=ACRO4+ACRAMT
+2 IF ACRREC="R"&(ACRORIG="I")
SET ACRI4=ACRI4+ACRAMT
+3 IF ACRREC="R"&(ACRORIG="D")
SET ACRD4=ACRD4+ACRAMT
+4 IF ACRREC='"R"&(ACRORIG="O")
SET ACRNO4=ACRNO4+ACRAMT
+5 IF ACRREC='"R"&(ACRORIG="I")
SET ACRNI4=ACRNI4+ACRAMT
+6 IF ACRREC='"R"&(ACRORIG="D")
SET ACRND4=ACRND4+ACRAMT
+7 SET ACRTNO4=ACRTNO4+ACRNO4
SET ACRTNI4=ACRTNI4+ACRNI4
SET ACRTND4=ACRTND4+ACRND4
+8 QUIT
EXIT KILL ACRAMT,ACRAPTNO,ACRD,ACRND1,ACRND2,ACRND3,ACRND4,ACRNI1,ACRNI2
+1 KILL ACRNI3,ACRNI4,ACRNO1,ACRNO2,ACRNO3,ACRNO4,ACRORIG,ACRQT,ACRTND1
+2 KILL ACRTND2,ACRTND3,ACRTND4,ACRTNI1,ACRTNI2,ACRTNI3,ACRTNI4,ACRTNO1
+3 KILL ACRTNO2,ACRTNO3,ACRTNO4,ACRY,ACRZ
+4 KILL ^TMP("ACRSSA",$JOB)
+5 KILL ACRO1,ACRO2,ACRO3,ACRO4,ACRQ1,ACRO1,ACRI1,ACRD1,ACRQ2,ACRO2,ACRI2
+6 KILL ACRD2,ACRQ3,ACRO3,ACRI3,ACRD3,ACRQ4,ACRO4,ACRI4,ACRD4,ACRGTOT,ACRQ1
+7 KILL ACRQ2,ACRQ3,ACRQ4,ACRTI,ACRI1,ACRI2,ACRI3,ACRI4,ACRTD,ACRD1,ACRD2
+8 KILL ACRD3,ACRD4,ACRFY,ACRSSANO
+9 KILL ACRTOT,ACRREC,ACRNREC,ACRSSA,ACRREC,ACRNREC,ACRTOT,ACRRTOT,ACRNTOT
+10 KILL ACRSSA,ACRX,ACRI,ACRALW,ACRAMDNO,ACRTODAY,ACRTO,ACRSTRET,ACRCITY
+11 KILL ACRSTATE,ACRZIP,ACRAPP,ACRAPPNO,ACRAPT,ACRBA,ACRBANO
+12 QUIT
SET SET ^TMP("ACRSSA",$JOB,ACRSSANO,ACRX)=ACRAMT_"^"_ACRREC
+1 SET ^TMP("ACRSSA",$JOB,"TOT",ACRSSANO)="0^0"
+2 SET ACRD=$SELECT(ACRQT=1:"FIRST",ACRQT=2:"SECOND",ACRQT=3:"THIRD",1:"FOURTH")
+3 DO @ACRD
+4 QUIT
SSA SET ACRSSANO=0
+1 FOR
SET ACRSSANO=$ORDER(^TMP("ACRSSA",$JOB,ACRSSANO))
IF 'ACRSSANO
QUIT
Begin DoDot:1
+2 SET ACRZ=0
+3 FOR
SET ACRZ=$ORDER(^TMP("ACRSSA",$JOB,ACRSSANO,ACRZ))
IF 'ACRZ
QUIT
Begin DoDot:2
+4 SET ACRY=^TMP("ACRSSA",$JOB,ACRSSANO,ACRZ)
+5 DO SSA1
End DoDot:2
End DoDot:1
+6 QUIT
SSA1 IF $PIECE(ACRY,U,2)="R"
SET $PIECE(^TMP("ACRSSA",$JOB,"TOT",ACRSSANO),U)=$PIECE(^TMP("ACRSSA",$JOB,"TOT",ACRSSANO),U)+$PIECE(ACRY,U)
+1 IF $PIECE(ACRY,U,2)="N"
SET $PIECE(^TMP("ACRSSA",$JOB,"TOT",ACRSSANO),U,2)=$PIECE(^TMP("ACRSSA",$JOB,"TOT",ACRSSANO),U,2)+$PIECE(ACRY,U)
+2 QUIT
