- ASURM23P ; IHS/ITSC/LMH -RPT 23 LIST OVERSTOCK/INACTV ;
- ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- ;This routine formats and prints report 23, List Overstocked and
- ;Inactive Items from sorted extracts.
- EN ;EP;PRIMARY ENTRY POINT FOR REPORT 21
- 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^ASUD23P",ZTDESC="SAMS RPT 23" D O^ASUUZIS
- I POP S IOP=$I D ^%ZIS Q
- I ASUK(ASUK("PTR"),"Q") Q
- PSER ;EP;FOR TASKMAN QUEUE OF PRINT
- N X,Y,Z
- D:'$D(^XTMP("ASUR","R23")) SORT
- Q:$O(^XTMP("ASUR","R23",0))="" ;WAR 10/1/99 no data for Dir Issue
- D U^ASUUZIS
- S (ASUC("PG"),ASUMS("E#","ARE"))=0
- S ASUMS("E#","ARE")=$O(^XTMP("ASUR","R23",0)) D ARE^ASULARST($E(ASUMS("E#","ARE"),1,2))
- S ASURX("ACC")=$O(^XTMP("ASUR","R23",ASUMS("E#","ARE"),0)) D ACC^ASULDIRF(ASURX("ACC")),ACCTGP
- S ASUV("RPT")="R23",ASUQ("HDR")="HEADER^ASURM23P"
- D ^ASUUDATA I ASUX("NDTA") G K
- S (ASUC("PG"),ASUMS("E#","ARE"))=0
- F S ASUMS("E#","ARE")=$O(^XTMP("ASUR","R23",ASUMS("E#","ARE"))) Q:ASUMS("E#","ARE")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
- .D ARE^ASULARST($E(ASUMS("E#","ARE"),1,2))
- .S ASURX("ACC")=0
- .F S ASURX("ACC")=$O(^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASURX("ACC"))) Q:ASURX("ACC")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
- ..D ACC^ASULDIRF(ASURX("ACC")),ACCTGP
- ..S ASUV("ACCGP")=$G(ASUL(9,"ACC","GP"))
- ..S ASUMS("E#","IDX")=0
- ..D:ASUC("LINE")>(IOSL-2) HEADER Q:$D(DTOUT) Q:$D(DUOUT)
- ..F S ASUMS("E#","IDX")=$O(^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASURX("ACC"),ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
- ...S ASUMX("E#","IDX")=ASUMS("E#","IDX")
- ...D READ^ASUMXDIO
- ...W !?2,$E(ASUMX("IDX"),1,5),".",$E(ASUMX("IDX"),6),?15,ASUMX("DESC",1)," ",ASUMX("DESC",2),?85,ASUMX("AR U/I")
- ...S ASUC("LINE")=ASUC("LINE")+2
- ...S ASUMS("E#","STA")=0
- ...F S ASUMS("E#","STA")=$O(^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASURX("ACC"),ASUMS("E#","IDX"),ASUMS("E#","STA"))) Q:ASUMS("E#","STA")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
- ....S ASUX(0)=^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASURX("ACC"),ASUMS("E#","IDX"),ASUMS("E#","STA"))
- ....S ASUC(0,0,"QTY")=$P(ASUX(0),U),ASUV("AST")=$P(ASUX(0),U,2)
- ....D STA^ASULARST(ASUMS("E#","STA")),^ASUMSTRD
- ....S ASUC(1,ASUMS("E#","STA"))=$E(ASUL(2,"STA","NM"),1,22)
- ....W !?4,$E(ASUL(2,"STA","NM"),1,22),?26,ASUMS("SLC")
- ....D NSNFMT W ?28,ASUV("NSN"),?48,ASUMS("VENAM"),?65,ASUMS("EOQ","TP")
- ....W ?68,$J($FN(ASUC(0,0,"QTY"),","),7),ASUV("AST"),?80,$J($FN(ASUMS("CST/U"),",",2),8)
- ....S ASUC(0,0,"VAL")=(ASUC(0,0,"QTY")*(+ASUMS("CST/U")))
- ....W ?90,$J($FN(ASUC(0,0,"VAL"),",",2),10),?101,$G(ASUL(2,"STA","CTP")),?116,$G(ASUL(2,"STA","TP#"))
- ....S ASUC("LINE")=ASUC("LINE")+1
- ....S ASUC(0,0,"LI")=1
- ....S ASUV("STA")=ASUMS("E#","STA") D ROLL(0)
- ...Q:$D(DTOUT) Q:$D(DUOUT)
- ...D STALOOP(0,"ITEM") Q:$D(DTOUT) Q:$D(DUOUT)
- ...D:ASUC("LINE")>(IOSL-2) HEADER
- ..Q:$D(DTOUT) Q:$D(DUOUT)
- ..W !! S Y="ACCOUNT "_ASUV("ACCGP") D STALOOP(1,Y) Q:$D(DTOUT) Q:$D(DUOUT)
- ..D HEADER Q:$D(DUOUT) Q:$D(DTOUT)
- .Q:$D(DTOUT) Q:$D(DUOUT)
- .W !!! S Y="AREA "_ASUL(1,"AR","NM") D STALOOP(2,Y) Q:$D(DTOUT) Q:$D(DUOUT)
- .S ASUC("LINE")=IOSL
- K ;
- D PAZ^ASUURHDR I ASUK("PTRSEL")']"" D
- .D C^ASUUZIS
- K ASUMX,ASUMS,ASURX,ASUX,ASUC
- Q
- ACCTGP ;
- S ASUL(9,"ACC","GP")=$S(ASURX("ACC")=1:ASUL(9,"ACC","NM"),ASURX("ACC")=3:ASUL(9,"ACC","NM"),1:"GENERAL SUPPLIES")
- S ASUV("PRTACC")=$S(ASUL(9,"ACC","GP")="GENERAL SUPPLIES":"*",1:ASURX("ACC"))
- Q
- NSNFMT ;
- I ASUMS("ORD#")]"" D
- .I $E(ASUMS("ORD#"))="M" S ASUV("NSN")=ASUMS("ORD#") Q
- .I ASUMS("ORD#")]"" S ASUV("NSN")=ASUMS("ORD#")
- .E S ASUV("NSN")=ASUMX("NSN")
- .I $L(ASUV("NSN"))=4 Q
- .S ASUV("NSN")=$E(ASUV("NSN"),1,4)_"-"_$E(ASUV("NSN"),5,$L(ASUV("NSN")))
- .I $L(ASUV("NSN"))>7 S ASUV("NSN")=$E(ASUV("NSN"),1,7)_"-"_$E(ASUV("NSN"),8,$L(ASUV("NSN")))
- .I $L(ASUV("NSN"))>11 S ASUV("NSN")=$E(ASUV("NSN"),1,11)_"-"_$E(ASUV("NSN"),12,$L(ASUV("NSN")))
- Q
- N X,Y
- S ASUC("PG")=$G(ASUC("PG"))+1,ASUC("LINE")=6
- I ASUC("PG")>1 D PAZ^ASUURHDR
- Q:$D(DTOUT) Q:$D(DUOUT)
- W @(IOF),"REPORT #23 LISTING OF OVERSTOCKED SUPPLIES",?90,ASUK("DT"),?110,"PAGE",?115,$J($FN(ASUC("PG"),","),7)
- W !,"AREA",?6,ASUL(1,"AR","AP"),?9,ASUL(1,"AR","NM")
- W !,?50,"G L ACCOUNT 125.",ASUV("PRTACC"),?68,ASUL(9,"ACC","GP"),!
- W !?4,"INDEX",?20,"DESCRIPTION",?84,"UI"
- W !?6,"STATION",?25,"SLC",?29,"ORDER NUMBER",?50,"VENDOR NAME",?65,"TC",?70,"QTY",?83,"U/COST",?93,"T-VALUE",?101,"CONTACT PERSON TELEPHONE #",!
- Q
- STALOOP(X,Y) ;
- S ASUV("STA")=""
- F ASUC=1:1 S ASUV("STA")=$O(ASUC(X,ASUV("STA"))) Q:ASUV("STA")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
- .I ASUC'>1 W !?20,"STATIONS TOTALS FOR ",Y S ASUC("LINE")=$G(ASUC("LINE"))+1 I X>0 W ! S ASUC("LINE")=$G(ASUC("LINE"))+2
- .I X>0 D
- ..D ROLL(X)
- ..W ?30,ASUC(X,ASUV("STA"))
- ..W ?68,$J($FN(ASUC(X,ASUV("STA"),"QTY"),","),7),?90,$J($FN(ASUC(X,ASUV("STA"),"VAL"),",",2),10),?105,"LI - ",$J($FN($G(ASUC(X,ASUV("STA"),"LI")),","),8),!
- ..S ASUC("LINE")=$G(ASUC("LINE"))+1
- .S ASUC("TQTY")=$G(ASUC("TQTY"))+ASUC(X,ASUV("STA"),"QTY")
- .S ASUC("TVAL")=$G(ASUC("TVAL"))+ASUC(X,ASUV("STA"),"VAL")
- .S ASUC("TLI")=$G(ASUC("TLI"))+ASUC(X,ASUV("STA"),"LI")
- .K ASUC(X,ASUV("STA"))
- W ?68,"_______ __________"
- W:X>0 ?110,"________"
- W !?68,$J($FN(ASUC("TQTY"),","),7),?90,$J($FN(ASUC("TVAL"),",",2),10)
- I X>0 W ?110,$J($FN($G(ASUC("TLI")),","),8)
- W !
- D:ASUC("LINE")>(IOSL-2) HEADER
- Q:$D(DTOUT) Q:$D(DUOUT)
- K ASUC("TQTY"),ASUC("TVAL")
- S ASUC("LINE")=$G(ASUC("LINE"))+2
- Q
- ROLL(X) ;
- S ASUV("STF")=$S(X=0:0,1:ASUV("STA"))
- I X>0 S ASUC(X+1,ASUV("STA"))=ASUC(X,ASUV("STF"))
- S ASUC(X+1,ASUV("STA"),"QTY")=$G(ASUC(X+1,ASUV("STA"),"QTY"))+$G(ASUC(X,ASUV("STF"),"QTY"))
- S ASUC(X+1,ASUV("STA"),"VAL")=$G(ASUC(X+1,ASUV("STA"),"VAL"))+$G(ASUC(X,ASUV("STF"),"VAL"))
- S ASUC(X+1,ASUV("STA"),"LI")=$G(ASUC(X+1,ASUV("STA"),"LI"))+$G(ASUC(X,ASUV("STF"),"LI"))
- Q
- SORT ;EP ;
- K ^XTMP("ASUR","R23")
- S ^XTMP("ASUR","R23",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
- S ASUMS("E#","STA")=0
- F S ASUMS("E#","STA")=$O(^ASUMS(ASUMS("E#","STA"))) Q:ASUMS("E#","STA")'?1N.N D
- .F ASUMS("E#","IDX")=0:0 S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")'?1N.N D
- ..S ASUMS("LSTISS")=$P(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),0),U,13)
- ..S ASUV("LIMOS")=$E(ASUK("DT","FM"),1,5)-$E(ASUMS("LSTISS"),1,5)
- ..D ^ASUMSTRD
- ..Q:ASUMS("QTY","O/H")'>0
- ..S ASUMX("ACC")=$P($G(^ASUMX(ASUMS("E#","IDX"),0)),U,6)
- ..Q:ASUMX("ACC")']""
- ..S ASUMX("ACCTYP")=$S(ASUMX("ACC")=1:1,ASUMX("ACC")=3:3,1:4)
- ..I ASUV("LIMOS")>12 D
- ...S ASUC(0,0,"QTY")=ASUMS("QTY","O/H"),ASUV("AST")="*"
- ..E D Q:ASUC(0,0,"QTY")']""
- ...I "PN"[ASUMS("EOQ","TP") S ASUC(0,0,"QTY")="" Q
- ...S ASUV("QTYNEED")=(ASUMS("PMIQ")*12)+ASUMS("RPQ"),ASUC(0,0,"QTY")=ASUMS("QTY","O/H")-ASUV("QTYNEED")
- ...I ASUC(0,0,"QTY")<1 S ASUC(0,0,"QTY")="" Q
- ...S ASUV("AST")=""
- ..S ASUMS("E#","ARE")=$E(ASUMS("E#","STA"),1,2)
- ..S ^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASUMX("ACCTYP"),ASUMS("E#","IDX"),ASUMS("E#","STA"))=ASUC(0,0,"QTY")_U_ASUV("AST")
- Q
- ASURM23P ; IHS/ITSC/LMH -RPT 23 LIST OVERSTOCK/INACTV ;
- +1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- +2 ;This routine formats and prints report 23, List Overstocked and
- +3 ;Inactive Items from sorted extracts.
- EN ;EP;PRIMARY ENTRY POINT FOR REPORT 21
- +1 IF '$DATA(IO)
- DO HOME^%ZIS
- +2 IF '$DATA(DUZ(2))
- WRITE !,"Report must be run from Kernel option"
- QUIT
- +3 IF '$DATA(ASUL(1,"AR","AP"))
- DO SETAREA^ASULARST
- +4 SET ASUK("PTRSEL")=$GET(ASUK("PTRSEL"))
- IF ASUK("PTRSEL")]""
- GOTO PSER
- +5 SET ZTRTN="PSER^ASUD23P"
- SET ZTDESC="SAMS RPT 23"
- DO O^ASUUZIS
- +6 IF POP
- SET IOP=$IO
- DO ^%ZIS
- QUIT
- +7 IF ASUK(ASUK("PTR"),"Q")
- QUIT
- PSER ;EP;FOR TASKMAN QUEUE OF PRINT
- +1 NEW X,Y,Z
- +2 IF '$DATA(^XTMP("ASUR","R23"))
- DO SORT
- +3 ;WAR 10/1/99 no data for Dir Issue
- IF $ORDER(^XTMP("ASUR","R23",0))=""
- QUIT
- +4 DO U^ASUUZIS
- +5 SET (ASUC("PG"),ASUMS("E#","ARE"))=0
- +6 SET ASUMS("E#","ARE")=$ORDER(^XTMP("ASUR","R23",0))
- DO ARE^ASULARST($EXTRACT(ASUMS("E#","ARE"),1,2))
- +7 SET ASURX("ACC")=$ORDER(^XTMP("ASUR","R23",ASUMS("E#","ARE"),0))
- DO ACC^ASULDIRF(ASURX("ACC"))
- DO ACCTGP
- +8 SET ASUV("RPT")="R23"
- SET ASUQ("HDR")="HEADER^ASURM23P"
- +9 DO ^ASUUDATA
- IF ASUX("NDTA")
- GOTO K
- +10 SET (ASUC("PG"),ASUMS("E#","ARE"))=0
- +11 FOR
- SET ASUMS("E#","ARE")=$ORDER(^XTMP("ASUR","R23",ASUMS("E#","ARE")))
- IF ASUMS("E#","ARE")']""
- QUIT
- Begin DoDot:1
- +12 DO ARE^ASULARST($EXTRACT(ASUMS("E#","ARE"),1,2))
- +13 SET ASURX("ACC")=0
- +14 FOR
- SET ASURX("ACC")=$ORDER(^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASURX("ACC")))
- IF ASURX("ACC")']""
- QUIT
- Begin DoDot:2
- +15 DO ACC^ASULDIRF(ASURX("ACC"))
- DO ACCTGP
- +16 SET ASUV("ACCGP")=$GET(ASUL(9,"ACC","GP"))
- +17 SET ASUMS("E#","IDX")=0
- +18 IF ASUC("LINE")>(IOSL-2)
- DO HEADER
- IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +19 FOR
- SET ASUMS("E#","IDX")=$ORDER(^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASURX("ACC"),ASUMS("E#","IDX")))
- IF ASUMS("E#","IDX")']""
- QUIT
- Begin DoDot:3
- +20 SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
- +21 DO READ^ASUMXDIO
- +22 WRITE !?2,$EXTRACT(ASUMX("IDX"),1,5),".",$EXTRACT(ASUMX("IDX"),6),?15,ASUMX("DESC",1)," ",ASUMX("DESC",2),?85,ASUMX("AR U/I")
- +23 SET ASUC("LINE")=ASUC("LINE")+2
- +24 SET ASUMS("E#","STA")=0
- +25 FOR
- SET ASUMS("E#","STA")=$ORDER(^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASURX("ACC"),ASUMS("E#","IDX"),ASUMS("E#","STA")))
- IF ASUMS("E#","STA")']""
- QUIT
- Begin DoDot:4
- +26 SET ASUX(0)=^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASURX("ACC"),ASUMS("E#","IDX"),ASUMS("E#","STA"))
- +27 SET ASUC(0,0,"QTY")=$PIECE(ASUX(0),U)
- SET ASUV("AST")=$PIECE(ASUX(0),U,2)
- +28 DO STA^ASULARST(ASUMS("E#","STA"))
- DO ^ASUMSTRD
- +29 SET ASUC(1,ASUMS("E#","STA"))=$EXTRACT(ASUL(2,"STA","NM"),1,22)
- +30 WRITE !?4,$EXTRACT(ASUL(2,"STA","NM"),1,22),?26,ASUMS("SLC")
- +31 DO NSNFMT
- WRITE ?28,ASUV("NSN"),?48,ASUMS("VENAM"),?65,ASUMS("EOQ","TP")
- +32 WRITE ?68,$JUSTIFY($FNUMBER(ASUC(0,0,"QTY"),","),7),ASUV("AST"),?80,$JUSTIFY($FNUMBER(ASUMS("CST/U"),",",2),8)
- +33 SET ASUC(0,0,"VAL")=(ASUC(0,0,"QTY")*(+ASUMS("CST/U")))
- +34 WRITE ?90,$JUSTIFY($FNUMBER(ASUC(0,0,"VAL"),",",2),10),?101,$GET(ASUL(2,"STA","CTP")),?116,$GET(ASUL(2,"STA","TP#"))
- +35 SET ASUC("LINE")=ASUC("LINE")+1
- +36 SET ASUC(0,0,"LI")=1
- +37 SET ASUV("STA")=ASUMS("E#","STA")
- DO ROLL(0)
- End DoDot:4
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- +38 IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +39 DO STALOOP(0,"ITEM")
- IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +40 IF ASUC("LINE")>(IOSL-2)
- DO HEADER
- End DoDot:3
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- +41 IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +42 WRITE !!
- SET Y="ACCOUNT "_ASUV("ACCGP")
- DO STALOOP(1,Y)
- IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +43 DO HEADER
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- End DoDot:2
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- +44 IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +45 WRITE !!!
- SET Y="AREA "_ASUL(1,"AR","NM")
- DO STALOOP(2,Y)
- IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +46 SET ASUC("LINE")=IOSL
- End DoDot:1
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- K ;
- +1 DO PAZ^ASUURHDR
- IF ASUK("PTRSEL")']""
- Begin DoDot:1
- +2 DO C^ASUUZIS
- End DoDot:1
- +3 KILL ASUMX,ASUMS,ASURX,ASUX,ASUC
- +4 QUIT
- ACCTGP ;
- +1 SET ASUL(9,"ACC","GP")=$SELECT(ASURX("ACC")=1:ASUL(9,"ACC","NM"),ASURX("ACC")=3:ASUL(9,"ACC","NM"),1:"GENERAL SUPPLIES")
- +2 SET ASUV("PRTACC")=$SELECT(ASUL(9,"ACC","GP")="GENERAL SUPPLIES":"*",1:ASURX("ACC"))
- +3 QUIT
- NSNFMT ;
- +1 IF ASUMS("ORD#")]""
- Begin DoDot:1
- +2 IF $EXTRACT(ASUMS("ORD#"))="M"
- SET ASUV("NSN")=ASUMS("ORD#")
- QUIT
- +3 IF ASUMS("ORD#")]""
- SET ASUV("NSN")=ASUMS("ORD#")
- +4 IF '$TEST
- SET ASUV("NSN")=ASUMX("NSN")
- +5 IF $LENGTH(ASUV("NSN"))=4
- QUIT
- +6 SET ASUV("NSN")=$EXTRACT(ASUV("NSN"),1,4)_"-"_$EXTRACT(ASUV("NSN"),5,$LENGTH(ASUV("NSN")))
- +7 IF $LENGTH(ASUV("NSN"))>7
- SET ASUV("NSN")=$EXTRACT(ASUV("NSN"),1,7)_"-"_$EXTRACT(ASUV("NSN"),8,$LENGTH(ASUV("NSN")))
- +8 IF $LENGTH(ASUV("NSN"))>11
- SET ASUV("NSN")=$EXTRACT(ASUV("NSN"),1,11)_"-"_$EXTRACT(ASUV("NSN"),12,$LENGTH(ASUV("NSN")))
- End DoDot:1
- +9 QUIT
- +1 NEW X,Y
- +2 SET ASUC("PG")=$GET(ASUC("PG"))+1
- SET ASUC("LINE")=6
- +3 IF ASUC("PG")>1
- DO PAZ^ASUURHDR
- +4 IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +5 WRITE @(IOF),"REPORT #23 LISTING OF OVERSTOCKED SUPPLIES",?90,ASUK("DT"),?110,"PAGE",?115,$JUSTIFY($FNUMBER(ASUC("PG"),","),7)
- +6 WRITE !,"AREA",?6,ASUL(1,"AR","AP"),?9,ASUL(1,"AR","NM")
- +7 WRITE !,?50,"G L ACCOUNT 125.",ASUV("PRTACC"),?68,ASUL(9,"ACC","GP"),!
- +8 WRITE !?4,"INDEX",?20,"DESCRIPTION",?84,"UI"
- +9 WRITE !?6,"STATION",?25,"SLC",?29,"ORDER NUMBER",?50,"VENDOR NAME",?65,"TC",?70,"QTY",?83,"U/COST",?93,"T-VALUE",?101,"CONTACT PERSON TELEPHONE #",!
- +10 QUIT
- STALOOP(X,Y) ;
- +1 SET ASUV("STA")=""
- +2 FOR ASUC=1:1
- SET ASUV("STA")=$ORDER(ASUC(X,ASUV("STA")))
- IF ASUV("STA")']""
- QUIT
- Begin DoDot:1
- +3 IF ASUC'>1
- WRITE !?20,"STATIONS TOTALS FOR ",Y
- SET ASUC("LINE")=$GET(ASUC("LINE"))+1
- IF X>0
- WRITE !
- SET ASUC("LINE")=$GET(ASUC("LINE"))+2
- +4 IF X>0
- Begin DoDot:2
- +5 DO ROLL(X)
- +6 WRITE ?30,ASUC(X,ASUV("STA"))
- +7 WRITE ?68,$JUSTIFY($FNUMBER(ASUC(X,ASUV("STA"),"QTY"),","),7),?90,$JUSTIFY($FNUMBER(ASUC(X,ASUV("STA"),"VAL"),",",2),10),?105,"LI - ",$JUSTIFY($FNUMBER($GET(ASUC(X,ASUV("STA"),"LI")),","),8),!
- +8 SET ASUC("LINE")=$GET(ASUC("LINE"))+1
- End DoDot:2
- +9 SET ASUC("TQTY")=$GET(ASUC("TQTY"))+ASUC(X,ASUV("STA"),"QTY")
- +10 SET ASUC("TVAL")=$GET(ASUC("TVAL"))+ASUC(X,ASUV("STA"),"VAL")
- +11 SET ASUC("TLI")=$GET(ASUC("TLI"))+ASUC(X,ASUV("STA"),"LI")
- +12 KILL ASUC(X,ASUV("STA"))
- End DoDot:1
- IF $DATA(DUOUT)
- QUIT
- IF $DATA(DTOUT)
- QUIT
- +13 WRITE ?68,"_______ __________"
- +14 IF X>0
- WRITE ?110,"________"
- +15 WRITE !?68,$JUSTIFY($FNUMBER(ASUC("TQTY"),","),7),?90,$JUSTIFY($FNUMBER(ASUC("TVAL"),",",2),10)
- +16 IF X>0
- WRITE ?110,$JUSTIFY($FNUMBER($GET(ASUC("TLI")),","),8)
- +17 WRITE !
- +18 IF ASUC("LINE")>(IOSL-2)
- DO HEADER
- +19 IF $DATA(DTOUT)
- QUIT
- IF $DATA(DUOUT)
- QUIT
- +20 KILL ASUC("TQTY"),ASUC("TVAL")
- +21 SET ASUC("LINE")=$GET(ASUC("LINE"))+2
- +22 QUIT
- ROLL(X) ;
- +1 SET ASUV("STF")=$SELECT(X=0:0,1:ASUV("STA"))
- +2 IF X>0
- SET ASUC(X+1,ASUV("STA"))=ASUC(X,ASUV("STF"))
- +3 SET ASUC(X+1,ASUV("STA"),"QTY")=$GET(ASUC(X+1,ASUV("STA"),"QTY"))+$GET(ASUC(X,ASUV("STF"),"QTY"))
- +4 SET ASUC(X+1,ASUV("STA"),"VAL")=$GET(ASUC(X+1,ASUV("STA"),"VAL"))+$GET(ASUC(X,ASUV("STF"),"VAL"))
- +5 SET ASUC(X+1,ASUV("STA"),"LI")=$GET(ASUC(X+1,ASUV("STA"),"LI"))+$GET(ASUC(X,ASUV("STF"),"LI"))
- +6 QUIT
- SORT ;EP ;
- +1 KILL ^XTMP("ASUR","R23")
- +2 SET ^XTMP("ASUR","R23",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
- +3 SET ASUMS("E#","STA")=0
- +4 FOR
- SET ASUMS("E#","STA")=$ORDER(^ASUMS(ASUMS("E#","STA")))
- IF ASUMS("E#","STA")'?1N.N
- QUIT
- Begin DoDot:1
- +5 FOR ASUMS("E#","IDX")=0:0
- SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX")))
- IF ASUMS("E#","IDX")'?1N.N
- QUIT
- Begin DoDot:2
- +6 SET ASUMS("LSTISS")=$PIECE(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),0),U,13)
- +7 SET ASUV("LIMOS")=$EXTRACT(ASUK("DT","FM"),1,5)-$EXTRACT(ASUMS("LSTISS"),1,5)
- +8 DO ^ASUMSTRD
- +9 IF ASUMS("QTY","O/H")'>0
- QUIT
- +10 SET ASUMX("ACC")=$PIECE($GET(^ASUMX(ASUMS("E#","IDX"),0)),U,6)
- +11 IF ASUMX("ACC")']""
- QUIT
- +12 SET ASUMX("ACCTYP")=$SELECT(ASUMX("ACC")=1:1,ASUMX("ACC")=3:3,1:4)
- +13 IF ASUV("LIMOS")>12
- Begin DoDot:3
- +14 SET ASUC(0,0,"QTY")=ASUMS("QTY","O/H")
- SET ASUV("AST")="*"
- End DoDot:3
- +15 IF '$TEST
- Begin DoDot:3
- +16 IF "PN"[ASUMS("EOQ","TP")
- SET ASUC(0,0,"QTY")=""
- QUIT
- +17 SET ASUV("QTYNEED")=(ASUMS("PMIQ")*12)+ASUMS("RPQ")
- SET ASUC(0,0,"QTY")=ASUMS("QTY","O/H")-ASUV("QTYNEED")
- +18 IF ASUC(0,0,"QTY")<1
- SET ASUC(0,0,"QTY")=""
- QUIT
- +19 SET ASUV("AST")=""
- End DoDot:3
- IF ASUC(0,0,"QTY")']""
- QUIT
- +20 SET ASUMS("E#","ARE")=$EXTRACT(ASUMS("E#","STA"),1,2)
- +21 SET ^XTMP("ASUR","R23",ASUMS("E#","ARE"),ASUMX("ACCTYP"),ASUMS("E#","IDX"),ASUMS("E#","STA"))=ASUC(0,0,"QTY")_U_ASUV("AST")
- End DoDot:2
- End DoDot:1
- +22 QUIT
