ACRFPPR1.m

ACRFPPR1 ;IHS/OIRM/DSD/THL,AEF - PROMPT PAYMENT REPORT;  [ 11/01/2001   9:44 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001

 ;;

GATHER ;EP;GATHER REPORT DATA

 S (ACRIA,ACRIB,ACRIIA,ACRIIB,ACRIIC1,ACRIIC2,ACRIIC3)=0

 S ACROBJDA=$O(^AUTTOBJC("B","4319 ",0))

 Q:'ACROBJDA

 S ACRDATE=ACRBEGIN

 F  S ACRDATE=$O(^AFSLAFP("R",ACRDATE)) Q:'ACRDATE!(ACRDATE>ACREND)  D G1

 Q

G1 S ACRFYDA=0

 F  S ACRFYDA=$O(^AFSLAFP("R",ACRDATE,ACRFYDA)) Q:'ACRFYDA  D G11

 Q

G11 S ACRBATDA=0

 F  S ACRBATDA=$O(^AFSLAFP("R",ACRDATE,ACRFYDA,ACRBATDA)) Q:'ACRBATDA  D

 .S ACRSEQDA=0

 .F  S ACRSEQDA=$O(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA)) Q:'ACRSEQDA  D

 ..S X=$G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,0))

 ..Q:$P(X,U,24)

 ..S ACRIB=ACRIB+1

 ..S ACRIA=ACRIA+$P(X,U,11)

 ..I $P(X,U,8)=ACROBJDA D

 ...S ACRPEN=$P(X,U,11)

 ...S ACRIIC1=ACRIIC1+ACRPEN

 ...S ACRIIC2=ACRIIC2+1

 ...S ACRX=$G(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA-1,0))

 ...S ACRIIA=ACRIIA+$P(ACRX,U,11)

 ...S ACRIIB=ACRIIC2

 ...I ACRPEN<25 S ACRIIC4(1)=$G(ACRIIC4(1))+1,ACRIIC4(11)=$G(ACRIIC4(11))+ACRPEN

 ...E  I ACRPEN<500 S ACRIIC4(2)=$G(ACRIIC4(2))+1,ACRIIC4(22)=$G(ACRIIC4(22))+ACRPEN

 ...E  I ACRPEN<1000 S ACRIIC4(3)=$G(ACRIIC4(3))+1,ACRIIC4(33)=$G(ACRIIC4(33))+ACRPEN

 ...E  I ACRPEN<2500 S ACRIIC4(4)=$G(ACRIIC4(4))+1,ACRIIC4(44)=$G(ACRIIC4(44))+ACRPEN

 ...E  I ACRPEN<3000 S ACRIIC4(5)=$G(ACRIIC4(5))+1,ACRIIC4(55)=$G(ACRIIC4(55))+ACRPEN

 ...E  S ACRIIC4(6)=$G(ACRIIC4(6))+1,ACRIIC4(66)=$G(ACRIIC4(66))+ACRPEN

 Q

ACRFPPR1  ;IHS/OIRM/DSD/THL,AEF - PROMPT PAYMENT REPORT;  [ 11/01/2001   9:44 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001

 +2       ;;

GATHER    ;EP;GATHER REPORT DATA

 +1        SET (ACRIA,ACRIB,ACRIIA,ACRIIB,ACRIIC1,ACRIIC2,ACRIIC3)=0

 +2        SET ACROBJDA=$ORDER(^AUTTOBJC("B","4319 ",0))

 +3        IF 'ACROBJDA

               QUIT 

 +4        SET ACRDATE=ACRBEGIN

 +5        FOR 

               SET ACRDATE=$ORDER(^AFSLAFP("R",ACRDATE))

               IF 'ACRDATE!(ACRDATE>ACREND)

                   QUIT 

               DO G1

 +6        QUIT 

G1         SET ACRFYDA=0

 +1        FOR 

               SET ACRFYDA=$ORDER(^AFSLAFP("R",ACRDATE,ACRFYDA))

               IF 'ACRFYDA

                   QUIT 

               DO G11

 +2        QUIT 

G11        SET ACRBATDA=0

 +1        FOR 

               SET ACRBATDA=$ORDER(^AFSLAFP("R",ACRDATE,ACRFYDA,ACRBATDA))

               IF 'ACRBATDA

                   QUIT 

               Begin DoDot:1

 +2                SET ACRSEQDA=0

 +3                FOR 

                       SET ACRSEQDA=$ORDER(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA))

                       IF 'ACRSEQDA

                           QUIT 

                       Begin DoDot:2

 +4                        SET X=$GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA,0))

 +5                        IF $PIECE(X,U,24)

                               QUIT 

 +6                        SET ACRIB=ACRIB+1

 +7                        SET ACRIA=ACRIA+$PIECE(X,U,11)

 +8                        IF $PIECE(X,U,8)=ACROBJDA

                               Begin DoDot:3

 +9                                SET ACRPEN=$PIECE(X,U,11)

 +10                               SET ACRIIC1=ACRIIC1+ACRPEN

 +11                               SET ACRIIC2=ACRIIC2+1

 +12                               SET ACRX=$GET(^AFSLAFP(ACRFYDA,1,ACRBATDA,1,ACRSEQDA-1,0))

 +13                               SET ACRIIA=ACRIIA+$PIECE(ACRX,U,11)

 +14                               SET ACRIIB=ACRIIC2

 +15                               IF ACRPEN<25

                                       SET ACRIIC4(1)=$GET(ACRIIC4(1))+1

                                       SET ACRIIC4(11)=$GET(ACRIIC4(11))+ACRPEN

 +16                              IF '$TEST

                                       IF ACRPEN<500

                                           SET ACRIIC4(2)=$GET(ACRIIC4(2))+1

                                           SET ACRIIC4(22)=$GET(ACRIIC4(22))+ACRPEN

 +17                              IF '$TEST

                                       IF ACRPEN<1000

                                           SET ACRIIC4(3)=$GET(ACRIIC4(3))+1

                                           SET ACRIIC4(33)=$GET(ACRIIC4(33))+ACRPEN

 +18                              IF '$TEST

                                       IF ACRPEN<2500

                                           SET ACRIIC4(4)=$GET(ACRIIC4(4))+1

                                           SET ACRIIC4(44)=$GET(ACRIIC4(44))+ACRPEN

 +19                              IF '$TEST

                                       IF ACRPEN<3000

                                           SET ACRIIC4(5)=$GET(ACRIIC4(5))+1

                                           SET ACRIIC4(55)=$GET(ACRIIC4(55))+ACRPEN

 +20                              IF '$TEST

                                       SET ACRIIC4(6)=$GET(ACRIIC4(6))+1

                                       SET ACRIIC4(66)=$GET(ACRIIC4(66))+ACRPEN

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +21       QUIT