ASURM78P.m

ASURM78P ; IHS/ITSC/LMH -PRINT RPT 78 DATA FROM ASURX(76 ; 

 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000

 ;This routine formats and prints report 78, Analysis of Issues by

 ;Area Report.

EN ;EP;PRIMARY ENTRY POINT FOR REPORT 78

 Q  ;WAR 5/21/99

 I '$D(IO) D HOME^%ZIS

 I '$D(DUZ(2)) W !,"Report must be run from Kernel option" Q

 I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST

 S ASUK("PTRSEL")=$G(ASUK("PTRSEL")) I ASUK("PTRSEL")]"" G PSER

 S ZTRTN="PSER^ASURM78P",ZTDESC="SAMS RPT 78" D O^ASUUZIS

 I POP S IOP=$I D ^%ZIS Q

 I ASUK(ASUK("PTR"),"Q") Q

 I ($D(ASUK("DT"))#10)'=1 D DATE^ASUUDATE

PSER ;EP;FOR TASKMAN QUEUE OF PRINT

 D U^ASUUZIS

 S ASUV("RPT")="R78",ASUC("PG")=""

 I ($D(ASUK("DT"))#10)'=1 D DATE^ASUUDATE

 D EN1,P1^ASURO76P

 S (ASUX("SST"),ASUX("USR"),ASUX("ACC"))=""

 F  S ASUX("SST")=$O(^XTMP("ASUR","R76",ASUX("SST"))) Q:ASUX("SST")=""  D

 .F  S ASUX("USR")=$O(^XTMP("ASUR","R76",ASUX("SST"),ASUX("USR"))) Q:'ASUX("USR")  D

 ..S ASUX("REQ")=ASUX("SST")_$E(ASUX("USR"),3,6)

 ..F ASUX("ACC")=0:0 S ASUX("ACC")=$O(^XTMP("ASUR","R76",ASUX("SST"),ASUX("USR"),ASUX("ACC"))) Q:'ASUX("ACC")  S ASUC("TR")=^(ASUX("ACC")) D

 ...F ASUV("FIELD")=2:1:22 D

 ....S ASUC(ASUV("FIELD"),1,ASUX("ACC"))=ASUC(ASUV("FIELD"),1,ASUX("ACC"))+$P(ASUC("TR"),U,ASUV("FIELD"))

 D SBK,P3^ASURO76P,HEADER^ASURO76P,P1^ASURO76P,EN1

 D ZAP0^ASURO76P

 D PAZ^ASUURHDR

 I ASUK("PTRSEL")]"" W @IOF Q

 D C^ASUUZIS

 Q

SBK ;

 F ASUV("ACC")=1,2,3,4,5,9 D

 .F ASUV("FIELD")=2:1:22 D

 ..S ASUC(ASUV("FIELD"),0,ASUV("ACC"))=ASUC(ASUV("FIELD"),1,ASUV("ACC"))

 Q

EN1 ;

 F ASUV("ACC")=1,2,3,4,5,9 D

 .F ASUV("FIELD")=2:1:26 D

 ..S ASUC(ASUV("FIELD"),1,ASUV("ACC"))=0

 Q

ASURM78P  ; IHS/ITSC/LMH -PRINT RPT 78 DATA FROM ASURX(76 ; 

 +1       ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000

 +2       ;This routine formats and prints report 78, Analysis of Issues by

 +3       ;Area Report.

EN        ;EP;PRIMARY ENTRY POINT FOR REPORT 78

 +1       ;WAR 5/21/99

           QUIT 

 +2        IF '$DATA(IO)

               DO HOME^%ZIS

 +3        IF '$DATA(DUZ(2))

               WRITE !,"Report must be run from Kernel option"

               QUIT 

 +4        IF '$DATA(ASUL(1,"AR","AP"))

               DO SETAREA^ASULARST

 +5        SET ASUK("PTRSEL")=$GET(ASUK("PTRSEL"))

           IF ASUK("PTRSEL")]""

               GOTO PSER

 +6        SET ZTRTN="PSER^ASURM78P"

           SET ZTDESC="SAMS RPT 78"

           DO O^ASUUZIS

 +7        IF POP

               SET IOP=$IO

               DO ^%ZIS

               QUIT 

 +8        IF ASUK(ASUK("PTR"),"Q")

               QUIT 

 +9        IF ($DATA(ASUK("DT"))#10)'=1

               DO DATE^ASUUDATE

PSER      ;EP;FOR TASKMAN QUEUE OF PRINT

 +1        DO U^ASUUZIS

 +2        SET ASUV("RPT")="R78"

           SET ASUC("PG")=""

 +3        IF ($DATA(ASUK("DT"))#10)'=1

               DO DATE^ASUUDATE

 +4        DO EN1

           DO P1^ASURO76P

 +5        SET (ASUX("SST"),ASUX("USR"),ASUX("ACC"))=""

 +6        FOR 

               SET ASUX("SST")=$ORDER(^XTMP("ASUR","R76",ASUX("SST")))

               IF ASUX("SST")=""

                   QUIT 

               Begin DoDot:1

 +7                FOR 

                       SET ASUX("USR")=$ORDER(^XTMP("ASUR","R76",ASUX("SST"),ASUX("USR")))

                       IF 'ASUX("USR")

                           QUIT 

                       Begin DoDot:2

 +8                        SET ASUX("REQ")=ASUX("SST")_$EXTRACT(ASUX("USR"),3,6)

 +9                        FOR ASUX("ACC")=0:0

                               SET ASUX("ACC")=$ORDER(^XTMP("ASUR","R76",ASUX("SST"),ASUX("USR"),ASUX("ACC")))

                               IF 'ASUX("ACC")

                                   QUIT 

                               SET ASUC("TR")=^(ASUX("ACC"))

                               Begin DoDot:3

 +10                               FOR ASUV("FIELD")=2:1:22

                                       Begin DoDot:4

 +11                                       SET ASUC(ASUV("FIELD"),1,ASUX("ACC"))=ASUC(ASUV("FIELD"),1,ASUX("ACC"))+$PIECE(ASUC("TR"),U,ASUV("FIELD"))

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +12       DO SBK

           DO P3^ASURO76P

           DO HEADER^ASURO76P

           DO P1^ASURO76P

           DO EN1

 +13       DO ZAP0^ASURO76P

 +14       DO PAZ^ASUURHDR

 +15       IF ASUK("PTRSEL")]""

               WRITE @IOF

               QUIT 

 +16       DO C^ASUUZIS

 +17       QUIT 

SBK       ;

 +1        FOR ASUV("ACC")=1,2,3,4,5,9

               Begin DoDot:1

 +2                FOR ASUV("FIELD")=2:1:22

                       Begin DoDot:2

 +3                        SET ASUC(ASUV("FIELD"),0,ASUV("ACC"))=ASUC(ASUV("FIELD"),1,ASUV("ACC"))

                       End DoDot:2

               End DoDot:1

 +4        QUIT 

EN1       ;

 +1        FOR ASUV("ACC")=1,2,3,4,5,9

               Begin DoDot:1

 +2                FOR ASUV("FIELD")=2:1:26

                       Begin DoDot:2

 +3                        SET ASUC(ASUV("FIELD"),1,ASUV("ACC"))=0

                       End DoDot:2

               End DoDot:1

 +4        QUIT