ASURM24P ; IHS/ITSC/LMH -RPT 24 SUPPLY EXPIRATION ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 24, List Inactive Items
;from sorted extracts.
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 24
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^ASURM24P",ZTDESC="SAMS RPT 24" 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","R24")) SORT
Q:$O(^XTMP("ASUR","R24",0))="" ;WAR 10/1/99 no data for Dir Issue
D U^ASUUZIS
S (ASUC("PG"),ASUMS("E#","STA"))=0,ASUF("BK")=0
S ASUMS("E#","STA")=$O(^XTMP("ASUR","R24",0))
I ASUMS("E#","STA")]"" D
.D ARE^ASULARST($E(ASUMS("E#","STA"),1,2)),STA^ASULARST(ASUMS("E#","STA"))
.S ASURX("ACG")=$O(^XTMP("ASUR","R24",ASUMS("E#","STA"),0)) D ACGNM^ASULDIRF(ASURX("ACG"))
S ASUV("RPT")="R24",ASUQ("HDR")="HEADER^ASURM24P"
D ^ASUUDATA I ASUX("NDTA") G K
S (ASUC("PG"),ASUMS("E#","STA"))=0,ASUF("BK")=""
F S ASUMS("E#","STA")=$O(^XTMP("ASUR","R24",ASUMS("E#","STA"))) Q:ASUMS("E#","STA")']"" D Q:$D(DTOUT) Q:$D(DUOUT)
.D ARE^ASULARST($E(ASUMS("E#","STA"),1,2)),STA^ASULARST(ASUMS("E#","STA"))
.S ASURX("ACG")=0
.F S ASURX("ACG")=$O(^XTMP("ASUR","R24",ASUMS("E#","STA"),ASURX("ACG"))) Q:ASURX("ACG")']"" D Q:$D(DTOUT) Q:$D(DUOUT)
..D ACGNM^ASULDIRF(ASURX("ACG")) D:ASUC("PG")>1 HEADER
..S ASUMS("E#","IDX")=0
..F S ASUMS("E#","IDX")=$O(^XTMP("ASUR","R24",ASUMS("E#","STA"),ASURX("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,^ASUMSTRD D:ASUF("BK") HEADER Q:$D(DUOUT) Q:$D(DTOUT)
...W !,$E(ASUMX("IDX"),1,5),".",$E(ASUMX("IDX"),6),?12,ASUMS("SLC"),?15,ASUMX("DESC",1),?48,ASUMX("AR U/I"),?52,ASUMS("PMIQ")
...S ASUV("DXP")=0
...F ASUV("DXPC")=1:1 S ASUV("DXP")=$O(ASUMS("DXP",ASUV("DXP"))) Q:ASUV("DXP")']"" D
....S X1=ASUK("DT","FM"),X2=ASUV("DXP") D ^%DTC Q:X>121
....W:ASUV("DXPC")=2 ?15,ASUMX("DESC",2)
....S Y=ASUV("DXP") X ^DD("DD") W ?58,Y,?67,$J($FN(ASUMS("DXP",ASUV("DXP")),","),8)
....W:ASUV("DXPC")=1 ?82,$J($FN(ASUMS("QTY","O/H"),","),5)
....W !
...W:ASUV("DXPC")=2 ?15,ASUMX("DESC",2)
...W !
...S ASUC("TOTLI")=$G(ASUC("TOTLI"))+1
K ;
K ASUMX,ASUMS,ASURX,ASUX,ASUC,ASUF("BK")
Q
S ASUC("PG")=$G(ASUC("PG"))+1,ASUC("LINE")=5
I ASUC("PG")>1 D PAZ^ASUURHDR Q:$D(DUOUT) Q:$D(DTOUT)
W @(IOF),"REPORT #24 SUPPLY EXPIRATION REPORT",?90,ASUK("DT"),?110,"PAGE",?115,$J($FN(ASUC("PG"),","),7)
W !,"AREA",?6,$G(ASUL(1,"AR","AP")),?9,$G(ASUL(1,"AR","NM"))
W !,"STAT",?6,$G(ASUL(2,"STA","CD")),?9,$G(ASUL(2,"STA","NM")),?50,"G L ACCOUNT 125.",$G(ASUL(9,"ACG")),?68,$G(ASUL(9,"ACG","NM")),!
W !?61,"EXP",?66,"SHORT DATED",?82,"TOTAL"
W !?3,"INDEX",?60,"DATE QUANTITY QUANTITY"
W !?3,"NUMBER",?10,"SLC",?15,"DESCRIPTION",?47,"U/I",?52,"PAMIQ",?69,"ON HAND ON HAND ACTION TAKEN",!
Q
SORT ;EP ;
K ^XTMP("ASUR","R24")
S ^XTMP("ASUR","R24",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
..D ^ASUMSTRD Q:ASUMS("DXP")'>0
..S (ASUF("DXP"),ASUV("DXP"))=0
..F S ASUV("DXP")=$O(ASUMS("DXP",ASUV("DXP"))) Q:ASUV("DXP")']"" D Q:ASUF("DXP")
...S X1=ASUK("DT","FM"),X2=ASUV("DXP") D ^%DTC
...Q:X>121 S ASUF("DXP")=1
..Q:'ASUF("DXP")
..S ASUMX("E#","IDX")=ASUMS("E#","IDX") D READ^ASUMXDIO,ACC^ASULDIRF(ASUMX("ACC"))
..S ^XTMP("ASUR","R24",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"))=ASUV("DXP")
Q
ASURM24P ; IHS/ITSC/LMH -RPT 24 SUPPLY EXPIRATION ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 24, List Inactive Items
+3 ;from sorted extracts.
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 24
+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^ASURM24P"
SET ZTDESC="SAMS RPT 24"
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","R24"))
DO SORT
+2 ;WAR 10/1/99 no data for Dir Issue
IF $ORDER(^XTMP("ASUR","R24",0))=""
QUIT
+3 DO U^ASUUZIS
+4 SET (ASUC("PG"),ASUMS("E#","STA"))=0
SET ASUF("BK")=0
+5 SET ASUMS("E#","STA")=$ORDER(^XTMP("ASUR","R24",0))
+6 IF ASUMS("E#","STA")]""
Begin DoDot:1
+7 DO ARE^ASULARST($EXTRACT(ASUMS("E#","STA"),1,2))
DO STA^ASULARST(ASUMS("E#","STA"))
+8 SET ASURX("ACG")=$ORDER(^XTMP("ASUR","R24",ASUMS("E#","STA"),0))
DO ACGNM^ASULDIRF(ASURX("ACG"))
End DoDot:1
+9 SET ASUV("RPT")="R24"
SET ASUQ("HDR")="HEADER^ASURM24P"
+10 DO ^ASUUDATA
IF ASUX("NDTA")
GOTO K
+11 SET (ASUC("PG"),ASUMS("E#","STA"))=0
SET ASUF("BK")=""
+12 FOR
SET ASUMS("E#","STA")=$ORDER(^XTMP("ASUR","R24",ASUMS("E#","STA")))
IF ASUMS("E#","STA")']""
QUIT
Begin DoDot:1
+13 DO ARE^ASULARST($EXTRACT(ASUMS("E#","STA"),1,2))
DO STA^ASULARST(ASUMS("E#","STA"))
+14 SET ASURX("ACG")=0
+15 FOR
SET ASURX("ACG")=$ORDER(^XTMP("ASUR","R24",ASUMS("E#","STA"),ASURX("ACG")))
IF ASURX("ACG")']""
QUIT
Begin DoDot:2
+16 DO ACGNM^ASULDIRF(ASURX("ACG"))
IF ASUC("PG")>1
DO HEADER
+17 SET ASUMS("E#","IDX")=0
+18 FOR
SET ASUMS("E#","IDX")=$ORDER(^XTMP("ASUR","R24",ASUMS("E#","STA"),ASURX("ACG"),ASUMS("E#","IDX")))
IF ASUMS("E#","IDX")']""
QUIT
Begin DoDot:3
+19 SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
+20 DO READ^ASUMXDIO
DO ^ASUMSTRD
IF ASUF("BK")
DO HEADER
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+21 WRITE !,$EXTRACT(ASUMX("IDX"),1,5),".",$EXTRACT(ASUMX("IDX"),6),?12,ASUMS("SLC"),?15,ASUMX("DESC",1),?48,ASUMX("AR U/I"),?52,ASUMS("PMIQ")
+22 SET ASUV("DXP")=0
+23 FOR ASUV("DXPC")=1:1
SET ASUV("DXP")=$ORDER(ASUMS("DXP",ASUV("DXP")))
IF ASUV("DXP")']""
QUIT
Begin DoDot:4
+24 SET X1=ASUK("DT","FM")
SET X2=ASUV("DXP")
DO ^%DTC
IF X>121
QUIT
+25 IF ASUV("DXPC")=2
WRITE ?15,ASUMX("DESC",2)
+26 SET Y=ASUV("DXP")
XECUTE ^DD("DD")
WRITE ?58,Y,?67,$JUSTIFY($FNUMBER(ASUMS("DXP",ASUV("DXP")),","),8)
+27 IF ASUV("DXPC")=1
WRITE ?82,$JUSTIFY($FNUMBER(ASUMS("QTY","O/H"),","),5)
+28 WRITE !
End DoDot:4
+29 IF ASUV("DXPC")=2
WRITE ?15,ASUMX("DESC",2)
+30 WRITE !
+31 SET ASUC("TOTLI")=$GET(ASUC("TOTLI"))+1
End DoDot:3
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
End DoDot:2
IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
End DoDot:1
IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
K ;
+1 KILL ASUMX,ASUMS,ASURX,ASUX,ASUC,ASUF("BK")
+2 QUIT
+1 SET ASUC("PG")=$GET(ASUC("PG"))+1
SET ASUC("LINE")=5
+2 IF ASUC("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+3 WRITE @(IOF),"REPORT #24 SUPPLY EXPIRATION REPORT",?90,ASUK("DT"),?110,"PAGE",?115,$JUSTIFY($FNUMBER(ASUC("PG"),","),7)
+4 WRITE !,"AREA",?6,$GET(ASUL(1,"AR","AP")),?9,$GET(ASUL(1,"AR","NM"))
+5 WRITE !,"STAT",?6,$GET(ASUL(2,"STA","CD")),?9,$GET(ASUL(2,"STA","NM")),?50,"G L ACCOUNT 125.",$GET(ASUL(9,"ACG")),?68,$GET(ASUL(9,"ACG","NM")),!
+6 WRITE !?61,"EXP",?66,"SHORT DATED",?82,"TOTAL"
+7 WRITE !?3,"INDEX",?60,"DATE QUANTITY QUANTITY"
+8 WRITE !?3,"NUMBER",?10,"SLC",?15,"DESCRIPTION",?47,"U/I",?52,"PAMIQ",?69,"ON HAND ON HAND ACTION TAKEN",!
+9 QUIT
SORT ;EP ;
+1 KILL ^XTMP("ASUR","R24")
+2 SET ^XTMP("ASUR","R24",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 DO ^ASUMSTRD
IF ASUMS("DXP")'>0
QUIT
+7 SET (ASUF("DXP"),ASUV("DXP"))=0
+8 FOR
SET ASUV("DXP")=$ORDER(ASUMS("DXP",ASUV("DXP")))
IF ASUV("DXP")']""
QUIT
Begin DoDot:3
+9 SET X1=ASUK("DT","FM")
SET X2=ASUV("DXP")
DO ^%DTC
+10 IF X>121
QUIT
SET ASUF("DXP")=1
End DoDot:3
IF ASUF("DXP")
QUIT
+11 IF 'ASUF("DXP")
QUIT
+12 SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
DO READ^ASUMXDIO
DO ACC^ASULDIRF(ASUMX("ACC"))
+13 SET ^XTMP("ASUR","R24",ASUMS("E#","STA"),ASUL(9,"ACG"),ASUMS("E#","IDX"))=ASUV("DXP")
End DoDot:2
End DoDot:1
+14 QUIT
