- 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
