ASURQ49P ; IHS/ITSC/LMH -RPT 49 R & N ITEMS ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 49, List R & N Items
;from sorted extracts.
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 49
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^ASUD49P",ZTDESC="SAMS RPT 49" D O^ASUUZIS
I POP S IOP=$I D ^%ZIS Q
I ASUK(ASUK("PTR"),"Q") Q
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
D:'$D(^XTMP("ASUR","R49")) ^ASURQ490
D U^ASUUZIS
S ASUV("E#","STA")=$O(^XTMP("ASUR","R49",0)) D ARE^ASULARST($E(ASUV("E#","STA"),1,2)),STA^ASULARST(ASUV("E#","STA"))
S ASUL(9,"ACG")=$O(^XTMP("ASUR","R49",ASUV("E#","STA"),0)) D ACGNM^ASULDIRF(ASUL(9,"ACG"))
S ASUV("RPT")="R49",ASUQ("HDR")="HEADER^ASURQ49P"
S (ASUC("PG"),ASUMS("E#","STA"))=0,ASUF("BK")="",ASUV("PART")="A DETAIL LISTING"
D ^ASUUDATA I ASUX("NDTA") G K
F S ASUMS("E#","STA")=$O(^XTMP("ASUR","R49",ASUMS("E#","STA"))) Q:ASUMS("E#","STA")']"" D Q:$D(DTOUT) Q:$D(DUOUT)
.S ASUMS("E#","ARE")=$E(ASUMS("E#","STA"),1,2)
.D ARE^ASULARST(ASUMS("E#","ARE")),STA^ASULARST(ASUMS("E#","STA"))
.S ASUL(9,"ACG")=0
.F S ASUL(9,"ACG")=$O(^XTMP("ASUR","R49",ASUMS("E#","STA"),ASUL(9,"ACG"))) Q:ASUL(9,"ACG")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
..S ASUMS("E#","IDX")=0 D ACGNM^ASULDIRF(ASUL(9,"ACG"))
..F S ASUMS("E#","IDX")=$O(^XTMP("ASUR","R49",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
...S ASUMX("E#","IDX")=ASUMS("E#","IDX")
...D READ^ASUMXDIO D ^ASUMSTRD D:ASUF("BK") HEADER Q:$D(DUOUT) Q:$D(DTOUT)
...W !!,$E(ASUMX("IDX"),1,5),".",$E(ASUMX("IDX"),6),?9,ASUMX("ACC"),?15,ASUMX("DESC",1),!
...S ASUC("LINE")=$G(ASUC("LINE"))+2,ASUV("ERR")=0 D:ASUC("LINE")>(IOSL-4) HEADER
...F S ASUV("ERR")=$O(^XTMP("ASUR","R49",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"),ASUV("ERR"))) Q:ASUV("ERR")']"" D Q:$D(DUOUT) Q:$D(DTOUT)
....W !?10,^XTMP("ASUR","R49",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"),ASUV("ERR"))
....S ASUC("LINE")=$G(ASUC("LINE"))+1 D:ASUC("LINE")>(IOSL-1) HEADER
..S ASUF("BK")=1
.S Y=^XTMP("ASUR","R49",ASUMS("E#","STA"),0),ASUC("PC")=0
.F X="TOT","TPA","13IS","XS","AIV" S ASUC("PC")=ASUC("PC")+1,ASUC("VAL",X)=$P(Y,U,ASUC("PC"))
.F X="TOT","13IS","XS","ZBAL","PSTDU","MOD","NOIS","NSN","R13","RPQ","LPP" S ASUC("PC")=ASUC("PC")+1 S ASUC("LI",X)=$P(Y,U,ASUC("PC"))
.S ASUV("PART")="B STATION SUMMARY" D HEADER D SUMMARY S ASUV("PART")="A DETAIL LISTING"
.S ASUF("BK")=1
K ;
K ASUMX,ASUMS,ASURX,ASUX,ASUC,ASUF("BK")
Q
SUMMARY ;
S ASUV("PART")="B STATION SUMMARY" D HEADER
W !!?6,"01. $",$J($FN(ASUC("VAL","TOT"),",",2),12)," TOTAL CURRENT INVENTORY VALUE"
W !!?6,"02. $",$J($FN(ASUC("VAL","TPA"),",",2),12)," TYPE CODE A ITEMS ONLY - CURRENT INVENTORY VALUE"
W !!?6,"03. $",$J($FN(ASUC("VAL","AIV"),",",2),12)," TYPE CODE A ITEMS ONLY - AVERAGE INVENTORY VALUE BASED ON EOQ PRINCIPLE OF STOCK REPLENISHMENT"
W !!?6,"04. $",$J($FN(ASUC("VAL","13IS"),",",2),12)," VALUE OF ITEMS WITH NO ISSUES IN 13 MONTHS OR LONGER"
W !!?6,"05. $",$J($FN(ASUC("VAL","XS"),",",2),12)," VALUE OF EXCESS QUANTITY ON HAND"
W !!?6,"06. ",$J($FN(ASUC("LI","TOT"),"",0),6)," TOTAL NUMBER OF LINE ITEMS IN INVENTORY"
W !!?6,"07. ",$J($FN(ASUC("LI","13IS"),"",0),6)," ITEMS HAVE HAD NO ISSUES IN 13 MONTHS OR LONGER"
W !!?6,"08. ",$J($FN(ASUC("LI","XS"),"",0),6)," ITEMS HAVE EXCESS QUANTITY ON HAND"
W !!?6,"09. ",$J($FN(ASUC("LI","ZBAL"),"",0),6)," ITEMS ARE ZERO BALANCE - ZERO DUE IN"
W !!?6,"11. ",$J($FN(ASUC("LI","PSTDU"),"",0),6)," DUE INS THAT ARE 60 DAYS OR MORE PAST THE DELIVERY DATE"
W !!?6,"12. ",$J($FN(ASUC("LI","MOD"),"",0),6)," ITEMS NEED EOQ TYPE CODE AND/OR MODIFIER REVIEWED/UPDATED"
W !!?6,"13. ",$J($FN(ASUC("LI","NOIS"),"",0),6)," ITEMS HAVE HAD NO ISSUES SINCE BEING ESTABLISHED"
W !!?6,"14. ",$J($FN(ASUC("LI","NSN"),"",0),6)," ITEMS NEED TO BE UPDATED WITH VALID NATIONAL STOCK NUMBER"
W !!?6,"15. ",$J($FN(ASUC("LI","R13"),"",0),6)," ITEMS HAVE APPEARED ON REQUIREMENTS ANALYSIS REPORT EXCESSIVE TIMES"
W !!?6,"16. ",$J($FN(ASUC("LI","RPQ"),"",0),6)," ITEMS NEED REVIEW POINT QUANTITY REVIEWED/UPDATED"
W !!?6,"17. ",$J($FN(ASUC("LI","LPP"),"",0),6)," ITEMS NEED TO HAVE LAST PURCHASE PRICE REVIEWED/UPDATED"
Q
S ASUC("PG")=$G(ASUC("PG"))+1,ASUC("LINE")=6,ASUF("BK")=0
I ASUC("PG")>1 D PAZ^ASUURHDR Q:$D(DUOUT) Q:$D(DTOUT)
W @(IOF),"REPORT #49 DATA EXECEPTION ANALYSIS",?90,ASUK("DT"),?110,"PAGE",?115,$J($FN(ASUC("PG"),","),7)
W !,"AREA:",?6,ASUL(1,"AR","AP"),?9,ASUL(1,"AR","NM"),?50,"PART ",ASUV("PART")
W !,"STAT:",?6,ASUL(2,"STA","CD"),?9,ASUL(2,"STA","NM")
W !,"ACCT:",?7,ASUL(9,"ACG")," ",ASUL(9,"ACG","NM")
I $E(ASUV("PART"))="A" D
.W !!," INDEX A"
.W !,"NUMBER C",?15,"DESCRIPTION"
Q
ASURQ49P ; IHS/ITSC/LMH -RPT 49 R & N ITEMS ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 49, List R & N Items
+3 ;from sorted extracts.
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 49
+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^ASUD49P"
SET ZTDESC="SAMS RPT 49"
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 IF '$DATA(^XTMP("ASUR","R49"))
DO ^ASURQ490
+2 DO U^ASUUZIS
+3 SET ASUV("E#","STA")=$ORDER(^XTMP("ASUR","R49",0))
DO ARE^ASULARST($EXTRACT(ASUV("E#","STA"),1,2))
DO STA^ASULARST(ASUV("E#","STA"))
+4 SET ASUL(9,"ACG")=$ORDER(^XTMP("ASUR","R49",ASUV("E#","STA"),0))
DO ACGNM^ASULDIRF(ASUL(9,"ACG"))
+5 SET ASUV("RPT")="R49"
SET ASUQ("HDR")="HEADER^ASURQ49P"
+6 SET (ASUC("PG"),ASUMS("E#","STA"))=0
SET ASUF("BK")=""
SET ASUV("PART")="A DETAIL LISTING"
+7 DO ^ASUUDATA
IF ASUX("NDTA")
GOTO K
+8 FOR
SET ASUMS("E#","STA")=$ORDER(^XTMP("ASUR","R49",ASUMS("E#","STA")))
IF ASUMS("E#","STA")']""
QUIT
Begin DoDot:1
+9 SET ASUMS("E#","ARE")=$EXTRACT(ASUMS("E#","STA"),1,2)
+10 DO ARE^ASULARST(ASUMS("E#","ARE"))
DO STA^ASULARST(ASUMS("E#","STA"))
+11 SET ASUL(9,"ACG")=0
+12 FOR
SET ASUL(9,"ACG")=$ORDER(^XTMP("ASUR","R49",ASUMS("E#","STA"),ASUL(9,"ACG")))
IF ASUL(9,"ACG")']""
QUIT
Begin DoDot:2
+13 SET ASUMS("E#","IDX")=0
DO ACGNM^ASULDIRF(ASUL(9,"ACG"))
+14 FOR
SET ASUMS("E#","IDX")=$ORDER(^XTMP("ASUR","R49",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX")))
IF ASUMS("E#","IDX")']""
QUIT
Begin DoDot:3
+15 SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
+16 DO READ^ASUMXDIO
DO ^ASUMSTRD
IF ASUF("BK")
DO HEADER
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+17 WRITE !!,$EXTRACT(ASUMX("IDX"),1,5),".",$EXTRACT(ASUMX("IDX"),6),?9,ASUMX("ACC"),?15,ASUMX("DESC",1),!
+18 SET ASUC("LINE")=$GET(ASUC("LINE"))+2
SET ASUV("ERR")=0
IF ASUC("LINE")>(IOSL-4)
DO HEADER
+19 FOR
SET ASUV("ERR")=$ORDER(^XTMP("ASUR","R49",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"),ASUV("ERR")))
IF ASUV("ERR")']""
QUIT
Begin DoDot:4
+20 WRITE !?10,^XTMP("ASUR","R49",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"),ASUV("ERR"))
+21 SET ASUC("LINE")=$GET(ASUC("LINE"))+1
IF ASUC("LINE")>(IOSL-1)
DO HEADER
End DoDot:4
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
End DoDot:3
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+22 SET ASUF("BK")=1
End DoDot:2
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+23 SET Y=^XTMP("ASUR","R49",ASUMS("E#","STA"),0)
SET ASUC("PC")=0
+24 FOR X="TOT","TPA","13IS","XS","AIV"
SET ASUC("PC")=ASUC("PC")+1
SET ASUC("VAL",X)=$PIECE(Y,U,ASUC("PC"))
+25 FOR X="TOT","13IS","XS","ZBAL","PSTDU","MOD","NOIS","NSN","R13","RPQ","LPP"
SET ASUC("PC")=ASUC("PC")+1
SET ASUC("LI",X)=$PIECE(Y,U,ASUC("PC"))
+26 SET ASUV("PART")="B STATION SUMMARY"
DO HEADER
DO SUMMARY
SET ASUV("PART")="A DETAIL LISTING"
+27 SET ASUF("BK")=1
End DoDot:1
IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
K ;
+1 KILL ASUMX,ASUMS,ASURX,ASUX,ASUC,ASUF("BK")
+2 QUIT
SUMMARY ;
+1 SET ASUV("PART")="B STATION SUMMARY"
DO HEADER
+2 WRITE !!?6,"01. $",$JUSTIFY($FNUMBER(ASUC("VAL","TOT"),",",2),12)," TOTAL CURRENT INVENTORY VALUE"
+3 WRITE !!?6,"02. $",$JUSTIFY($FNUMBER(ASUC("VAL","TPA"),",",2),12)," TYPE CODE A ITEMS ONLY - CURRENT INVENTORY VALUE"
+4 WRITE !!?6,"03. $",$JUSTIFY($FNUMBER(ASUC("VAL","AIV"),",",2),12)," TYPE CODE A ITEMS ONLY - AVERAGE INVENTORY VALUE BASED ON EOQ PRINCIPLE OF STOCK REPLENISHMENT"
+5 WRITE !!?6,"04. $",$JUSTIFY($FNUMBER(ASUC("VAL","13IS"),",",2),12)," VALUE OF ITEMS WITH NO ISSUES IN 13 MONTHS OR LONGER"
+6 WRITE !!?6,"05. $",$JUSTIFY($FNUMBER(ASUC("VAL","XS"),",",2),12)," VALUE OF EXCESS QUANTITY ON HAND"
+7 WRITE !!?6,"06. ",$JUSTIFY($FNUMBER(ASUC("LI","TOT"),"",0),6)," TOTAL NUMBER OF LINE ITEMS IN INVENTORY"
+8 WRITE !!?6,"07. ",$JUSTIFY($FNUMBER(ASUC("LI","13IS"),"",0),6)," ITEMS HAVE HAD NO ISSUES IN 13 MONTHS OR LONGER"
+9 WRITE !!?6,"08. ",$JUSTIFY($FNUMBER(ASUC("LI","XS"),"",0),6)," ITEMS HAVE EXCESS QUANTITY ON HAND"
+10 WRITE !!?6,"09. ",$JUSTIFY($FNUMBER(ASUC("LI","ZBAL"),"",0),6)," ITEMS ARE ZERO BALANCE - ZERO DUE IN"
+11 WRITE !!?6,"11. ",$JUSTIFY($FNUMBER(ASUC("LI","PSTDU"),"",0),6)," DUE INS THAT ARE 60 DAYS OR MORE PAST THE DELIVERY DATE"
+12 WRITE !!?6,"12. ",$JUSTIFY($FNUMBER(ASUC("LI","MOD"),"",0),6)," ITEMS NEED EOQ TYPE CODE AND/OR MODIFIER REVIEWED/UPDATED"
+13 WRITE !!?6,"13. ",$JUSTIFY($FNUMBER(ASUC("LI","NOIS"),"",0),6)," ITEMS HAVE HAD NO ISSUES SINCE BEING ESTABLISHED"
+14 WRITE !!?6,"14. ",$JUSTIFY($FNUMBER(ASUC("LI","NSN"),"",0),6)," ITEMS NEED TO BE UPDATED WITH VALID NATIONAL STOCK NUMBER"
+15 WRITE !!?6,"15. ",$JUSTIFY($FNUMBER(ASUC("LI","R13"),"",0),6)," ITEMS HAVE APPEARED ON REQUIREMENTS ANALYSIS REPORT EXCESSIVE TIMES"
+16 WRITE !!?6,"16. ",$JUSTIFY($FNUMBER(ASUC("LI","RPQ"),"",0),6)," ITEMS NEED REVIEW POINT QUANTITY REVIEWED/UPDATED"
+17 WRITE !!?6,"17. ",$JUSTIFY($FNUMBER(ASUC("LI","LPP"),"",0),6)," ITEMS NEED TO HAVE LAST PURCHASE PRICE REVIEWED/UPDATED"
+18 QUIT
+1 SET ASUC("PG")=$GET(ASUC("PG"))+1
SET ASUC("LINE")=6
SET ASUF("BK")=0
+2 IF ASUC("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+3 WRITE @(IOF),"REPORT #49 DATA EXECEPTION ANALYSIS",?90,ASUK("DT"),?110,"PAGE",?115,$JUSTIFY($FNUMBER(ASUC("PG"),","),7)
+4 WRITE !,"AREA:",?6,ASUL(1,"AR","AP"),?9,ASUL(1,"AR","NM"),?50,"PART ",ASUV("PART")
+5 WRITE !,"STAT:",?6,ASUL(2,"STA","CD"),?9,ASUL(2,"STA","NM")
+6 WRITE !,"ACCT:",?7,ASUL(9,"ACG")," ",ASUL(9,"ACG","NM")
+7 IF $EXTRACT(ASUV("PART"))="A"
Begin DoDot:1
+8 WRITE !!," INDEX A"
+9 WRITE !,"NUMBER C",?15,"DESCRIPTION"
End DoDot:1
+10 QUIT
