- 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
