- 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
