ASURQ810 ; IHS/ITSC/LMH -RPT 81 DROP SHIP LIST SORT ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine sorts report 81 extracts into proper sequence so that
;the report can be formatted and printed.
I '$D(ASUP("QTR")) D SETQTR^ASUUDATE Q:$D(DUOUT)
S ASUT="ISS",ASUT("TRCD")=""
S ^XTMP("ASUR","R81",0)=ASUK("DT","FM")_U_ASUP("QTR")
S ^XTMP("ASUR","R82",0)=ASUK("DT","FM")_U_ASUP("QTR")
S ASUX("ARST")=ASUL(1,"AR","AP")_"000"
F S ASUX("ARST")=$O(^ASUMS(ASUX("ARST"))) Q:$E(ASUX("ARST"),1,2)'=ASUL(1,"AR","AP") D
.S ASUMX("E#","IDX")=0
.F S ASUMX("E#","IDX")=$O(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"))) Q:$E(ASUMX("E#","IDX"),1,2)'=ASUL(1,"AR","AP") D
..Q:$P(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"),0),U)["999999"
..S ^XTMP("ASUR","R81",0,ASUX("ARST"))=$P(^ASUL(2,ASUX("ARST"),0),U)
..S ^XTMP("ASUR","R82",0,ASUX("ARST"))=^XTMP("ASUR","R81",0,ASUX("ARST"))
..S ASUMS("EOQ","TP")=$P(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"),2),U,5)
..S ASUMX("ACC")=$P(^ASUMX(ASUMX("E#","IDX"),0),U,6)
..S ASUX("ACIX")=ASUMX("ACC")_ASUMX("E#","IDX")
..I ASUMS("EOQ","TP")="S" D Q
...S ^XTMP("ASUR","R81",0,"IDX",ASUMX("E#","IDX"))=ASUMX("ACC")
...S ^XTMP("ASUR","R81",0,ASUX("ARST"),ASUX("ACIX"))=$P(^ASUL(9,ASUMX("ACC"),0),U)
..I ASUMS("EOQ","TP")="Y" D
...S ^XTMP("ASUR","R82",0,"IDX",ASUMX("E#","IDX"))=ASUMX("ACC")
...S ^XTMP("ASUR","R82",0,ASUX("ARST"),ASUX("ACIX"))=$P(^ASUL(9,ASUMX("ACC"),0),U)
S ASUX("QTR")=$E(ASUP("QTR"),5,6)
S ASUX("QTRF")=$E(ASUP("QTR"),1,4)_"00"
S ASUV("YR")=ASUP("YR") S:$L(ASUV("YR"))=4 ASUV("YR")=$E(ASUV("YR"),3,4)
F S ASUX("QTRF")=$O(^ASUML("C",ASUX("QTRF"))) Q:ASUX("QTRF")']"" Q:$E(ASUX("QTRF"),3,4)'=ASUV("YR") D
.S ASUV("CQTR")=$E(ASUX("QTRF"),5,6) Q:ASUV("CQTR")>ASUX("QTR")
.S ASUX("XTRQTR")=""
.F S ASUX("XTRQTR")=$O(^ASUML("C",ASUX("QTRF"),ASUX("XTRQTR"))) Q:ASUX("XTRQTR")'?1N.N D
..S ASUX("XTRDT")=""
..F S ASUX("XTRDT")=$O(^ASUML(ASUX("XTRQTR"),"B",ASUX("XTRDT"))) Q:ASUX("XTRDT")="" D
...S ASUHDA=""
...F S ASUHDA=$O(^ASUH("AX",ASUX("XTRDT"),ASUHDA)) Q:ASUHDA="" D ASURQ811
END ;
K ASUT,ASUR,ASUMS,ASUV,ASUX
Q
ASURQ811 ;DROP SHIP LIST SORT
D READ^ASU0TRRD(.ASUHDA,"H") Q:$G(ASUT)']""
Q:ASUT("TYPE")'=3
S ASUMX("E#","IDX")=ASUL(1,"AR","AP")_ASUT(ASUT,"IDX")
S ASUX("ARST")=ASUL(1,"AR","AP")_0_ASUT(ASUT,"STA")
S ASUX("SST")=ASUL(1,"AR","AP")_0_ASUT(ASUT,"SST")
Q:$G(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"),0))'[""
Q:$P(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"),0),U)["999999"
S ASUMX("ACC")=ASUT(ASUT,"ACC")
S ASUX("QTY")=ASUT(ASUT,"QTY","ISS")
S:ASUX("QTY")']"" ASUX("QTY")=ASUT(ASUT,"QTY","REQ")
I ASUT("TRCD")="3K" D Q
.I ASUT(ASUT,"EOQ TYP")="S" D XTR Q
.I $D(^XTMP("ASUR","R81",0,"IDX",ASUMX("E#","IDX"))) D XTR Q
I ASUT("TRCD")'=32 Q
I ASUT(ASUT,"EOQ TYP")="S" D XTR Q
I $D(^XTMP("ASUR","R81",0,"IDX",ASUMX("E#","IDX"))) D XTR Q
I ASUT(ASUT,"EOQ TYP")="Y" D ASURQ821 Q
I $D(^XTMP("ASUR","R82",0,"IDX",ASUMX("E#","IDX"))) D ASURQ821
XTR ;
I ASUT("TRCD")="3K" D
.S ASUT(ASUT,"VAL")=ASUT(ASUT,"VAL")*-1
.S ASUX("QTY")=ASUX("QTY")*-1
I ASUMX("ACC")']"" D SETACC Q:ASUMX("ACC")']""
S ASUX("ACIX")=ASUMX("ACC")_ASUMX("E#","IDX")
I '$D(^XTMP("ASUR","R81",ASUX("ARST"))) D
.S ^XTMP("ASUR","R81",ASUX("ARST"))=$G(^XTMP("ASUR","R81",0,ASUX("ARST")))
I '$D(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"))) D
.S ^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"))=$G(^XTMP("ASUR","R81",0,ASUX("ARST"),ASUX("ACIX")))
K ASUL(18)
D SST^ASULDIRR(ASUX("SST"))
I '$D(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"))) D
.S ^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"))=$G(^XTMP("ASUR","R81",0,ASUX("ARST"),ASUX("ACIX")))
F X=19,20,22 K ASUL(X)
D REQ^ASULDIRR(ASUT(ASUT,"USR"))
S ASUX("REQ")=$G(ASUL(20,"REQ","E#")) Q:ASUX("REQ")']""
I '$D(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))) D
.S ^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))="0^0^0^0"
S $P(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,2)=$P(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,2)+ASUX("QTY")
S $P(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,4)=$P(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,4)+ASUT(ASUT,"VAL")
I ASUX("QTR")'=ASUV("CQTR") Q
S $P(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U)=$P(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U)+ASUX("QTY")
S $P(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,3)=$P(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,3)+ASUT(ASUT,"VAL")
Q
ASURQ821 ;YEARLY ITEM LIST SORT
I ASUT("TRCD")="3K" D
.S ASUT(ASUT,"VAL")=ASUT(ASUT,"VAL")*-1
.S ASUX("QTY")=ASUX("QTY")*-1
I '$D(^XTMP("ASUR","R82",ASUX("ARST"))),$D(^XTMP("ASUR","R81",ASUX("ARST"))) D
.S ^XTMP("ASUR","R82",ASUX("ARST"))=^XTMP("ASUR","R81",ASUX("ARST"))
I '$G(^XTMP("ASUR","R82",ASUX("ARST")))']"" D
.S ^XTMP("ASUR","R82",ASUX("ARST"))=$G(^XTMP("ASUR","R81",0,ASUX("ARST")))
I '$D(^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"))) D
.S ^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"))=$G(^XTMP("ASUR","R82",0,ASUX("ARST"),ASUX("ACIX")))
D SST^ASULDIRR(ASUX("SST"))
D REQ^ASULDIRR(ASUT(ASUT,"USR"))
S ASUX("REQ")=$G(ASUL(20,"REQ","E#")) Q:ASUX("REQ")']""
I '$D(^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))) D
.S ^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))="0^0^0^0"
S ASUX=^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))
S $P(ASUX,U,2)=$P(ASUX,U,2)+ASUX("QTY")
S $P(ASUX,U,4)=$P(ASUX,U,4)+ASUT(ASUT,"VAL")
I ASUX("QTR")=ASUV("CQTR") D
.S $P(ASUX,U)=$P(ASUX,U)+ASUX("QTY")
.S $P(ASUX,U,3)=$P(ASUX,U,3)+ASUT(ASUT,"VAL")
S ^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))=ASUX
SETACC ;EP; SET ACCOUNT
S ASUMX("ACC")=$P(^ASUMX(ASUMX("E#","IDX"),0),U,6)
Q
ASURQ810 ; IHS/ITSC/LMH -RPT 81 DROP SHIP LIST SORT ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine sorts report 81 extracts into proper sequence so that
+3 ;the report can be formatted and printed.
+4 IF '$DATA(ASUP("QTR"))
DO SETQTR^ASUUDATE
IF $DATA(DUOUT)
QUIT
+5 SET ASUT="ISS"
SET ASUT("TRCD")=""
+6 SET ^XTMP("ASUR","R81",0)=ASUK("DT","FM")_U_ASUP("QTR")
+7 SET ^XTMP("ASUR","R82",0)=ASUK("DT","FM")_U_ASUP("QTR")
+8 SET ASUX("ARST")=ASUL(1,"AR","AP")_"000"
+9 FOR
SET ASUX("ARST")=$ORDER(^ASUMS(ASUX("ARST")))
IF $EXTRACT(ASUX("ARST"),1,2)'=ASUL(1,"AR","AP")
QUIT
Begin DoDot:1
+10 SET ASUMX("E#","IDX")=0
+11 FOR
SET ASUMX("E#","IDX")=$ORDER(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX")))
IF $EXTRACT(ASUMX("E#","IDX"),1,2)'=ASUL(1,"AR","AP")
QUIT
Begin DoDot:2
+12 IF $PIECE(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"),0),U)["999999"
QUIT
+13 SET ^XTMP("ASUR","R81",0,ASUX("ARST"))=$PIECE(^ASUL(2,ASUX("ARST"),0),U)
+14 SET ^XTMP("ASUR","R82",0,ASUX("ARST"))=^XTMP("ASUR","R81",0,ASUX("ARST"))
+15 SET ASUMS("EOQ","TP")=$PIECE(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"),2),U,5)
+16 SET ASUMX("ACC")=$PIECE(^ASUMX(ASUMX("E#","IDX"),0),U,6)
+17 SET ASUX("ACIX")=ASUMX("ACC")_ASUMX("E#","IDX")
+18 IF ASUMS("EOQ","TP")="S"
Begin DoDot:3
+19 SET ^XTMP("ASUR","R81",0,"IDX",ASUMX("E#","IDX"))=ASUMX("ACC")
+20 SET ^XTMP("ASUR","R81",0,ASUX("ARST"),ASUX("ACIX"))=$PIECE(^ASUL(9,ASUMX("ACC"),0),U)
End DoDot:3
QUIT
+21 IF ASUMS("EOQ","TP")="Y"
Begin DoDot:3
+22 SET ^XTMP("ASUR","R82",0,"IDX",ASUMX("E#","IDX"))=ASUMX("ACC")
+23 SET ^XTMP("ASUR","R82",0,ASUX("ARST"),ASUX("ACIX"))=$PIECE(^ASUL(9,ASUMX("ACC"),0),U)
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET ASUX("QTR")=$EXTRACT(ASUP("QTR"),5,6)
+25 SET ASUX("QTRF")=$EXTRACT(ASUP("QTR"),1,4)_"00"
+26 SET ASUV("YR")=ASUP("YR")
IF $LENGTH(ASUV("YR"))=4
SET ASUV("YR")=$EXTRACT(ASUV("YR"),3,4)
+27 FOR
SET ASUX("QTRF")=$ORDER(^ASUML("C",ASUX("QTRF")))
IF ASUX("QTRF")']""
QUIT
IF $EXTRACT(ASUX("QTRF"),3,4)'=ASUV("YR")
QUIT
Begin DoDot:1
+28 SET ASUV("CQTR")=$EXTRACT(ASUX("QTRF"),5,6)
IF ASUV("CQTR")>ASUX("QTR")
QUIT
+29 SET ASUX("XTRQTR")=""
+30 FOR
SET ASUX("XTRQTR")=$ORDER(^ASUML("C",ASUX("QTRF"),ASUX("XTRQTR")))
IF ASUX("XTRQTR")'?1N.N
QUIT
Begin DoDot:2
+31 SET ASUX("XTRDT")=""
+32 FOR
SET ASUX("XTRDT")=$ORDER(^ASUML(ASUX("XTRQTR"),"B",ASUX("XTRDT")))
IF ASUX("XTRDT")=""
QUIT
Begin DoDot:3
+33 SET ASUHDA=""
+34 FOR
SET ASUHDA=$ORDER(^ASUH("AX",ASUX("XTRDT"),ASUHDA))
IF ASUHDA=""
QUIT
DO ASURQ811
End DoDot:3
End DoDot:2
End DoDot:1
END ;
+1 KILL ASUT,ASUR,ASUMS,ASUV,ASUX
+2 QUIT
ASURQ811 ;DROP SHIP LIST SORT
+1 DO READ^ASU0TRRD(.ASUHDA,"H")
IF $GET(ASUT)']""
QUIT
+2 IF ASUT("TYPE")'=3
QUIT
+3 SET ASUMX("E#","IDX")=ASUL(1,"AR","AP")_ASUT(ASUT,"IDX")
+4 SET ASUX("ARST")=ASUL(1,"AR","AP")_0_ASUT(ASUT,"STA")
+5 SET ASUX("SST")=ASUL(1,"AR","AP")_0_ASUT(ASUT,"SST")
+6 IF $GET(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"),0))'[""
QUIT
+7 IF $PIECE(^ASUMS(ASUX("ARST"),1,ASUMX("E#","IDX"),0),U)["999999"
QUIT
+8 SET ASUMX("ACC")=ASUT(ASUT,"ACC")
+9 SET ASUX("QTY")=ASUT(ASUT,"QTY","ISS")
+10 IF ASUX("QTY")']""
SET ASUX("QTY")=ASUT(ASUT,"QTY","REQ")
+11 IF ASUT("TRCD")="3K"
Begin DoDot:1
+12 IF ASUT(ASUT,"EOQ TYP")="S"
DO XTR
QUIT
+13 IF $DATA(^XTMP("ASUR","R81",0,"IDX",ASUMX("E#","IDX")))
DO XTR
QUIT
End DoDot:1
QUIT
+14 IF ASUT("TRCD")'=32
QUIT
+15 IF ASUT(ASUT,"EOQ TYP")="S"
DO XTR
QUIT
+16 IF $DATA(^XTMP("ASUR","R81",0,"IDX",ASUMX("E#","IDX")))
DO XTR
QUIT
+17 IF ASUT(ASUT,"EOQ TYP")="Y"
DO ASURQ821
QUIT
+18 IF $DATA(^XTMP("ASUR","R82",0,"IDX",ASUMX("E#","IDX")))
DO ASURQ821
XTR ;
+1 IF ASUT("TRCD")="3K"
Begin DoDot:1
+2 SET ASUT(ASUT,"VAL")=ASUT(ASUT,"VAL")*-1
+3 SET ASUX("QTY")=ASUX("QTY")*-1
End DoDot:1
+4 IF ASUMX("ACC")']""
DO SETACC
IF ASUMX("ACC")']""
QUIT
+5 SET ASUX("ACIX")=ASUMX("ACC")_ASUMX("E#","IDX")
+6 IF '$DATA(^XTMP("ASUR","R81",ASUX("ARST")))
Begin DoDot:1
+7 SET ^XTMP("ASUR","R81",ASUX("ARST"))=$GET(^XTMP("ASUR","R81",0,ASUX("ARST")))
End DoDot:1
+8 IF '$DATA(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX")))
Begin DoDot:1
+9 SET ^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"))=$GET(^XTMP("ASUR","R81",0,ASUX("ARST"),ASUX("ACIX")))
End DoDot:1
+10 KILL ASUL(18)
+11 DO SST^ASULDIRR(ASUX("SST"))
+12 IF '$DATA(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX")))
Begin DoDot:1
+13 SET ^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"))=$GET(^XTMP("ASUR","R81",0,ASUX("ARST"),ASUX("ACIX")))
End DoDot:1
+14 FOR X=19,20,22
KILL ASUL(X)
+15 DO REQ^ASULDIRR(ASUT(ASUT,"USR"))
+16 SET ASUX("REQ")=$GET(ASUL(20,"REQ","E#"))
IF ASUX("REQ")']""
QUIT
+17 IF '$DATA(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")))
Begin DoDot:1
+18 SET ^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))="0^0^0^0"
End DoDot:1
+19 SET $PIECE(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,2)=$PIECE(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,2)+ASUX("QTY")
+20 SET $PIECE(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,4)=$PIECE(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,4)+ASUT(ASUT,"VAL")
+21 IF ASUX("QTR")'=ASUV("CQTR")
QUIT
+22 SET $PIECE(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U)=$PIECE(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U)+ASUX("QTY")
+23 SET $PIECE(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,3)=$PIECE(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")),U,3)+ASUT(ASUT,"VAL")
+24 QUIT
ASURQ821 ;YEARLY ITEM LIST SORT
+1 IF ASUT("TRCD")="3K"
Begin DoDot:1
+2 SET ASUT(ASUT,"VAL")=ASUT(ASUT,"VAL")*-1
+3 SET ASUX("QTY")=ASUX("QTY")*-1
End DoDot:1
+4 IF '$DATA(^XTMP("ASUR","R82",ASUX("ARST")))
IF $DATA(^XTMP("ASUR","R81",ASUX("ARST")))
Begin DoDot:1
+5 SET ^XTMP("ASUR","R82",ASUX("ARST"))=^XTMP("ASUR","R81",ASUX("ARST"))
End DoDot:1
+6 IF '$GET(^XTMP("ASUR","R82",ASUX("ARST")))']""
Begin DoDot:1
+7 SET ^XTMP("ASUR","R82",ASUX("ARST"))=$GET(^XTMP("ASUR","R81",0,ASUX("ARST")))
End DoDot:1
+8 IF '$DATA(^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX")))
Begin DoDot:1
+9 SET ^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"))=$GET(^XTMP("ASUR","R82",0,ASUX("ARST"),ASUX("ACIX")))
End DoDot:1
+10 DO SST^ASULDIRR(ASUX("SST"))
+11 DO REQ^ASULDIRR(ASUT(ASUT,"USR"))
+12 SET ASUX("REQ")=$GET(ASUL(20,"REQ","E#"))
IF ASUX("REQ")']""
QUIT
+13 IF '$DATA(^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")))
Begin DoDot:1
+14 SET ^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))="0^0^0^0"
End DoDot:1
+15 SET ASUX=^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))
+16 SET $PIECE(ASUX,U,2)=$PIECE(ASUX,U,2)+ASUX("QTY")
+17 SET $PIECE(ASUX,U,4)=$PIECE(ASUX,U,4)+ASUT(ASUT,"VAL")
+18 IF ASUX("QTR")=ASUV("CQTR")
Begin DoDot:1
+19 SET $PIECE(ASUX,U)=$PIECE(ASUX,U)+ASUX("QTY")
+20 SET $PIECE(ASUX,U,3)=$PIECE(ASUX,U,3)+ASUT(ASUT,"VAL")
End DoDot:1
+21 SET ^XTMP("ASUR","R82",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))=ASUX
SETACC ;EP; SET ACCOUNT
+1 SET ASUMX("ACC")=$PIECE(^ASUMX(ASUMX("E#","IDX"),0),U,6)
+2 QUIT
