ASURQ81P ; IHS/ITSC/LMH -RPT 81 LIST DROP SHIP ITEMS ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 81, List of Drop Ship
;Items.
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 81
Q ;WAR 5/21/99
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^ASURQ81P",ZTDESC="SAMS RPT 81" D O^ASUUZIS
I POP S IOP=$I D ^%ZIS Q
I ASUK(ASUK("PTR"),"Q") Q
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
S ASUF("HDR")=1
S ASUX("ARST")=$O(^XTMP("ASUR","R81",0))
I ASUX("ARST")']"" D
.I ASUP("TYP")=0 Q
.D ^ASURQ810
D U^ASUUZIS
S ASUX("ARST")=$O(^XTMP("ASUR","R81",0))
I ASUX("ARST")']"" W !!,"No Data for Drop Ship Report for this quarter" G K
S ASUV("ARST")=ASUX("ARST")
D ARE^ASULARST($P(^ASUL(1,$E(ASUX("ARST"),1,2),0),U,2))
S ASUQA("AR")=ASUL(1,"AR","AP")_" - "_ASUL(1,"AR","NM")
D STA^ASULARST(ASUX("ARST"))
S ASUQA("STA")=ASUL(2,"STA","CD")_" - "_ASUL(2,"STA","NM")
S Y=$P(^XTMP("ASUR","R81",0),U) X ^DD("DD") S ASUV("DT")=Y
S (ASUC("LN"),ASUC("PG"))=0
S ASUP("YR")=$E($P(^XTMP("ASUR","R81",0),U,2),1,4),ASUT("QTR")=$E($P(^XTMP("ASUR","R81",0),U,2),5,6)
S ASUQA("DIV")=$S(ASUT("QTR")="04":12,ASUT("QTR")="03":9,ASUT("QTR")="02":6,1:3)
S ASUX("ACIX")="" K ASUL(9)
F S ASUX("ACIX")=$O(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"))) Q:ASUX("ACIX")="" Q:$D(DTOUT) Q:$D(DUOUT) D
.S ASUMX("ACC")=$E(ASUX("ACIX"))
.I $G(ASUL(9,"ACC"))'=ASUMX("ACC") D
..I $G(ASUL(9,"ACC"))]"" S ASUV("LEV")=1 D PRTOTL
..D ACC^ASULDIRF(ASUMX("ACC"))
..S ASUQA("ACC")=ASUL(9,"ACC")_" - "_ASUL(9,"ACC","NM")
.D P1
I $D(DUOUT)!($D(DTOUT)) G K
I ASUV("LEV")'=1 D
.S ASUV("LEV")=1 D PRTOTL
S ASUV("LEV")=2 D PRTOTL
D CLS^ASUUHDG
K ;
K ASUC,ASUF,ASUQA,ASUR,ASUT,ASUV,ASUX,ASURZ,ASURZX,ASUMS
F X=3:1:22 K ASUL(X) ;Clear Table Lookup fields
K DFOUT,DIR,DLOUT,DTOUT,DUOUT
K X,X1,Y
I ASUK("PTRSEL")]"" Q
D C^ASUUZIS
Q
NEWQTR ;EP ;
;GLOBAL ASURX IS A UTILITY REPORT EXTRACT GLOBAL
K ^XTMP("ASUR","R81"),^XTMP("ASUR","R82")
S ^XTMP("ASUR","R81",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
S ^XTMP("ASUR","R82",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM") G EN
P1 ;
S ASUMX("E#","IDX")=$E(ASUX("ACIX"),2,9) D READ^ASUMXDIO
S ASUX("REQ")="",ASUF("IDX")=0
F S ASUX("REQ")=$O(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))) Q:ASUX("REQ")="" Q:$D(DTOUT) Q:$D(DUOUT) D
.S ASUQA=^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))
.I $G(ASUX("SST"))'=$E(ASUX("REQ"),1,5) D
..K ASUL(18)
..S ASUX("SST")=$E(ASUX("REQ"),1,5)
..D SST^ASULDIRR(ASUX("SST"))
..S ASUQA("SST")=ASUL(18,"SST")_" - "_ASUL(18,"SST","NM")
.S ASUV("SST")=ASUX("SST")
.S $P(ASUQA(0,ASUX("SST")),U)=$P(ASUQA,U)
.S $P(ASUQA(0,ASUX("SST")),U,2)=$P(ASUQA,U,2)
.S $P(ASUQA(0,ASUX("SST")),U,3)=$FN(($P(ASUQA,U,2)/ASUQA("DIV")),"",2)
.S $P(ASUQA(0,ASUX("SST")),U,4)=$P(ASUQA,U,3)
.S $P(ASUQA(0,ASUX("SST")),U,5)=$P(ASUQA,U,4)
.S $P(ASUQA(0,ASUX("SST")),U,6)=$FN(($P(ASUQA,U,3)/ASUQA("DIV")),"",2)
.S ASUV("LEV")=0
.D P3
.F X=19,20,22 K ASUL(X)
.S ASUX("USR")=ASUL(1,"AR","AP")_$E(ASUX("REQ"),6,9)
.D USR^ASULDIRR(ASUX("USR"))
.D REQ^ASULDIRR(ASUX("REQ"))
.S ASUQA("USR")=ASUL(19,"USR")_" - "_ASUL(19,"USR","NM")
.D:ASUF("HDR") HEADER Q:$D(DUOUT)
.W ! S ASUC("LN")=ASUC("LN")+1
.I ASUF("IDX")=1 D
..W ?10,ASUMX("DESC",2) S ASUF("IDX")=2
.E I ASUF("IDX")=0 D
..W ! S ASUC("LN")=ASUC("LN")+1
..W ?1,$E(ASUMX("IDX"),1,5)_"."_$E(ASUMX("IDX"),6,6)
..W ?10,ASUMX("DESC",1)
..W ?45,ASUMX("AR U/I")
..S ASUF("IDX")=1
.D P2
Q:$D(DTOUT) Q:$D(DUOUT)
I ASUF("IDX")=1 W !?10,ASUMX("DESC",2) S ASUC("LN")=ASUC("LN")+1
I ASUF("IDX") S ASUV("SST")=0 D PRTOTL
Q
P2 ;
W ?50,ASUL(18,"SST"),?55,ASUL(19,"USR")
PRLQTY ;
F ASUV("PIECE")=1:1:3 D
.S ASURZX=((ASUV("PIECE")-1)*10)+60
.S ASURZ=$J($FN($P(ASUQA(ASUV("LEV"),ASUV("SST")),U,ASUV("PIECE")),"+,T",0),10)
.D PRCOLM
PRLVAL ;
F ASUV("PIECE")=4:1:6 D
.S ASURZX=((ASUV("PIECE")-4)*12)+90
.S ASURZ=$J($FN($P(ASUQA(ASUV("LEV"),ASUV("SST")),U,ASUV("PIECE")),"+,T",2),12)
.D PRCOLM
I ASUC("LN")>(IOSL-2) S ASUF("HDR")=1
Q
PRCOLM ;
W ?ASURZX,ASURZ
Q
PRTOTL ;
I ASUC("LN")>(IOSL-ASUV("LEV")*3) S ASUF("HDR")=1
D:ASUF("HDR") HEADER Q:$D(DUOUT)
W !,$P($T(TOTNAM+ASUV("LEV")),";",4)
S ASUC("LN")=ASUC("LN")+1
S ASUV("SST")=0
I ASUV("LEV")=0 D
.D PRDASH
.W !?35,$P($T(TOTNAM+ASUV("LEV")),";",3)
.S ASUC("LN")=ASUC("LN")+1
.D PRLQTY,PRDDSH
E D
.D PRSST
.S ASUF("HDR")=1
.S ASUV("SST")=0
.W !?55,$P($T(TOTNAM+ASUV("LEV")),";",3)
.S ASUC("LN")=ASUC("LN")+1
.D PRLVAL
.W ! D PRDDSHV
S ASUV("SST")=ASUL(18,"SST","E#")
K ASUQA(ASUV("LEV"))
Q
PRDASH ;
F ASUC=0:1:2 S X=(ASUC*10)+60 W ?X," _________"
PRDASHV ;
F ASUC=0:1:2 S X=(ASUC*12)+90 W ?X," ___________",?1,""
S ASUC("LN")=ASUC("LN")+1
Q
PRDDSH ;
W !
F ASUC=0:1:2 S X=(ASUC*10)+60 W ?X," ========="
PRDDSHV ;
F ASUC=0:1:2 S X=(ASUC*12)+90 W ?X," ===========",?1,""
S ASUC("LN")=ASUC("LN")+1
Q
S ASUV("SST")=0
F S ASUV("SST")=$O(ASUQA(ASUV("LEV"),ASUV("SST"))) Q:ASUV("SST")="" D
.W !?50,$E(ASUV("SST"),4,5)
.W ?55,$P($T(TOTNAM+ASUV("LEV")),";",3)
.D PRLVAL
W ! D PRDASHV
Q
S ASUC("PG")=ASUC("PG")+1
D:ASUC("PG")>1 PAZ^ASUURHDR Q:$D(DUOUT)
W @IOF,!,"REPORT #81 QUARTERLY LISTING OF ITEMS DROP SHIPPED",?70,"DATE : ",ASUV("DT"),?95,"PAGE :",$J(ASUC("PG"),3)
W !,"AREA: ",ASUQA("AR"),?50,$S(ASUT("QTR")="04":"LAST",ASUT("QTR")="03":"THIRD",ASUT("QTR")="02":"SECOND",1:"1ST")," QUARTER OF FISCAL YEAR ",ASUP("YR")
S:'$G(ASUQA("ACC")) ASUQA("ACC")=$G(ASUL(9,"ACC"))_"-"_$G(ASUL(9,"ACC","NM"))
W !,"STAT: ",ASUQA("STA"),?53,"GL ACCOUNT : ",ASUQA("ACC")
W !!?68,"QUANTITY ISSUED",?96,"ISSUE VALUE ISSUE VALUE"
W !?3,"INDEX ITEM",?45,"U",?49,"SUB",?55,"USER",?64,"CURRENT",?83,"MONTHLY",?96,"CURRENT",?119,"MONTHLY"
W !?2,"NUMBER DESCRIPTION",?46,"I",?49,"STA",?55,"CODE",?64,"QUARTER",?76,"Y-T-D",?83,"AVERAGE",?96,"QUARTER",?110,"Y-T-D",?119,"AVERAGE"
W ! F ASUC=1:1:132 W "_"
W !!
S ASUC("LN")=10,ASUF("HDR")=0
Q
TOTNAM ;;ITEM TOTAL
;;GL ACCOUNT TOTAL VALUE;SUMMARY OF DROP SHIPPED BY ACCOUNT
;;TOTAL VALUE DROP SHIPPED;SUMMARY OF TOTAL VALUE DROP SHIPPED
P3 ;
F ASUV("PIECE")=1:1:6 D
.S ASUQA(0,0)=$G(ASUQA(0,0))
.S $P(ASUQA(0,0),U,ASUV("PIECE"))=$P(ASUQA(0,0),U,ASUV("PIECE"))+$P(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
F ASUV("LEVA")=0:1:2 D ONE
Q
ONE ;
F ASUV("PIECE")=1:1:6 D
.S ASUQA(ASUV("LEVA")+1,ASUX("SST"))=$G(ASUQA(ASUV("LEVA")+1,ASUX("SST")))
.S $P(ASUQA(ASUV("LEVA")+1,ASUX("SST")),U,ASUV("PIECE"))=$P(ASUQA(ASUV("LEVA")+1,ASUX("SST")),U,ASUV("PIECE"))+$P(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
.S ASUQA(ASUV("LEVA")+1,0)=$G(ASUQA(ASUV("LEVA")+1,0))
.S $P(ASUQA(ASUV("LEVA")+1,0),U,ASUV("PIECE"))=$P(ASUQA(ASUV("LEVA")+1,0),U,ASUV("PIECE"))+$P(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
Q
ASURQ81P ; IHS/ITSC/LMH -RPT 81 LIST DROP SHIP ITEMS ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 81, List of Drop Ship
+3 ;Items.
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 81
+1 ;WAR 5/21/99
QUIT
+2 IF '$DATA(IO)
DO HOME^%ZIS
+3 IF '$DATA(DUZ(2))
WRITE !,"Report must be run from Kernel option"
QUIT
+4 IF '$DATA(ASUL(1,"AR","AP"))
DO SETAREA^ASULARST
+5 SET ASUK("PTRSEL")=$GET(ASUK("PTRSEL"))
IF ASUK("PTRSEL")]""
GOTO PSER
+6 SET ZTRTN="PSER^ASURQ81P"
SET ZTDESC="SAMS RPT 81"
DO O^ASUUZIS
+7 IF POP
SET IOP=$IO
DO ^%ZIS
QUIT
+8 IF ASUK(ASUK("PTR"),"Q")
QUIT
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
+1 SET ASUF("HDR")=1
+2 SET ASUX("ARST")=$ORDER(^XTMP("ASUR","R81",0))
+3 IF ASUX("ARST")']""
Begin DoDot:1
+4 IF ASUP("TYP")=0
QUIT
+5 DO ^ASURQ810
End DoDot:1
+6 DO U^ASUUZIS
+7 SET ASUX("ARST")=$ORDER(^XTMP("ASUR","R81",0))
+8 IF ASUX("ARST")']""
WRITE !!,"No Data for Drop Ship Report for this quarter"
GOTO K
+9 SET ASUV("ARST")=ASUX("ARST")
+10 DO ARE^ASULARST($PIECE(^ASUL(1,$EXTRACT(ASUX("ARST"),1,2),0),U,2))
+11 SET ASUQA("AR")=ASUL(1,"AR","AP")_" - "_ASUL(1,"AR","NM")
+12 DO STA^ASULARST(ASUX("ARST"))
+13 SET ASUQA("STA")=ASUL(2,"STA","CD")_" - "_ASUL(2,"STA","NM")
+14 SET Y=$PIECE(^XTMP("ASUR","R81",0),U)
XECUTE ^DD("DD")
SET ASUV("DT")=Y
+15 SET (ASUC("LN"),ASUC("PG"))=0
+16 SET ASUP("YR")=$EXTRACT($PIECE(^XTMP("ASUR","R81",0),U,2),1,4)
SET ASUT("QTR")=$EXTRACT($PIECE(^XTMP("ASUR","R81",0),U,2),5,6)
+17 SET ASUQA("DIV")=$SELECT(ASUT("QTR")="04":12,ASUT("QTR")="03":9,ASUT("QTR")="02":6,1:3)
+18 SET ASUX("ACIX")=""
KILL ASUL(9)
+19 FOR
SET ASUX("ACIX")=$ORDER(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX")))
IF ASUX("ACIX")=""
QUIT
IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
Begin DoDot:1
+20 SET ASUMX("ACC")=$EXTRACT(ASUX("ACIX"))
+21 IF $GET(ASUL(9,"ACC"))'=ASUMX("ACC")
Begin DoDot:2
+22 IF $GET(ASUL(9,"ACC"))]""
SET ASUV("LEV")=1
DO PRTOTL
+23 DO ACC^ASULDIRF(ASUMX("ACC"))
+24 SET ASUQA("ACC")=ASUL(9,"ACC")_" - "_ASUL(9,"ACC","NM")
End DoDot:2
+25 DO P1
End DoDot:1
+26 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO K
+27 IF ASUV("LEV")'=1
Begin DoDot:1
+28 SET ASUV("LEV")=1
DO PRTOTL
End DoDot:1
+29 SET ASUV("LEV")=2
DO PRTOTL
+30 DO CLS^ASUUHDG
K ;
+1 KILL ASUC,ASUF,ASUQA,ASUR,ASUT,ASUV,ASUX,ASURZ,ASURZX,ASUMS
+2 ;Clear Table Lookup fields
FOR X=3:1:22
KILL ASUL(X)
+3 KILL DFOUT,DIR,DLOUT,DTOUT,DUOUT
+4 KILL X,X1,Y
+5 IF ASUK("PTRSEL")]""
QUIT
+6 DO C^ASUUZIS
+7 QUIT
NEWQTR ;EP ;
+1 ;GLOBAL ASURX IS A UTILITY REPORT EXTRACT GLOBAL
+2 KILL ^XTMP("ASUR","R81"),^XTMP("ASUR","R82")
+3 SET ^XTMP("ASUR","R81",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
+4 SET ^XTMP("ASUR","R82",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
GOTO EN
P1 ;
+1 SET ASUMX("E#","IDX")=$EXTRACT(ASUX("ACIX"),2,9)
DO READ^ASUMXDIO
+2 SET ASUX("REQ")=""
SET ASUF("IDX")=0
+3 FOR
SET ASUX("REQ")=$ORDER(^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ")))
IF ASUX("REQ")=""
QUIT
IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
Begin DoDot:1
+4 SET ASUQA=^XTMP("ASUR","R81",ASUX("ARST"),ASUX("ACIX"),ASUX("REQ"))
+5 IF $GET(ASUX("SST"))'=$EXTRACT(ASUX("REQ"),1,5)
Begin DoDot:2
+6 KILL ASUL(18)
+7 SET ASUX("SST")=$EXTRACT(ASUX("REQ"),1,5)
+8 DO SST^ASULDIRR(ASUX("SST"))
+9 SET ASUQA("SST")=ASUL(18,"SST")_" - "_ASUL(18,"SST","NM")
End DoDot:2
+10 SET ASUV("SST")=ASUX("SST")
+11 SET $PIECE(ASUQA(0,ASUX("SST")),U)=$PIECE(ASUQA,U)
+12 SET $PIECE(ASUQA(0,ASUX("SST")),U,2)=$PIECE(ASUQA,U,2)
+13 SET $PIECE(ASUQA(0,ASUX("SST")),U,3)=$FNUMBER(($PIECE(ASUQA,U,2)/ASUQA("DIV")),"",2)
+14 SET $PIECE(ASUQA(0,ASUX("SST")),U,4)=$PIECE(ASUQA,U,3)
+15 SET $PIECE(ASUQA(0,ASUX("SST")),U,5)=$PIECE(ASUQA,U,4)
+16 SET $PIECE(ASUQA(0,ASUX("SST")),U,6)=$FNUMBER(($PIECE(ASUQA,U,3)/ASUQA("DIV")),"",2)
+17 SET ASUV("LEV")=0
+18 DO P3
+19 FOR X=19,20,22
KILL ASUL(X)
+20 SET ASUX("USR")=ASUL(1,"AR","AP")_$EXTRACT(ASUX("REQ"),6,9)
+21 DO USR^ASULDIRR(ASUX("USR"))
+22 DO REQ^ASULDIRR(ASUX("REQ"))
+23 SET ASUQA("USR")=ASUL(19,"USR")_" - "_ASUL(19,"USR","NM")
+24 IF ASUF("HDR")
DO HEADER
IF $DATA(DUOUT)
QUIT
+25 WRITE !
SET ASUC("LN")=ASUC("LN")+1
+26 IF ASUF("IDX")=1
Begin DoDot:2
+27 WRITE ?10,ASUMX("DESC",2)
SET ASUF("IDX")=2
End DoDot:2
+28 IF '$TEST
IF ASUF("IDX")=0
Begin DoDot:2
+29 WRITE !
SET ASUC("LN")=ASUC("LN")+1
+30 WRITE ?1,$EXTRACT(ASUMX("IDX"),1,5)_"."_$EXTRACT(ASUMX("IDX"),6,6)
+31 WRITE ?10,ASUMX("DESC",1)
+32 WRITE ?45,ASUMX("AR U/I")
+33 SET ASUF("IDX")=1
End DoDot:2
+34 DO P2
End DoDot:1
+35 IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
+36 IF ASUF("IDX")=1
WRITE !?10,ASUMX("DESC",2)
SET ASUC("LN")=ASUC("LN")+1
+37 IF ASUF("IDX")
SET ASUV("SST")=0
DO PRTOTL
+38 QUIT
P2 ;
+1 WRITE ?50,ASUL(18,"SST"),?55,ASUL(19,"USR")
PRLQTY ;
+1 FOR ASUV("PIECE")=1:1:3
Begin DoDot:1
+2 SET ASURZX=((ASUV("PIECE")-1)*10)+60
+3 SET ASURZ=$JUSTIFY($FNUMBER($PIECE(ASUQA(ASUV("LEV"),ASUV("SST")),U,ASUV("PIECE")),"+,T",0),10)
+4 DO PRCOLM
End DoDot:1
PRLVAL ;
+1 FOR ASUV("PIECE")=4:1:6
Begin DoDot:1
+2 SET ASURZX=((ASUV("PIECE")-4)*12)+90
+3 SET ASURZ=$JUSTIFY($FNUMBER($PIECE(ASUQA(ASUV("LEV"),ASUV("SST")),U,ASUV("PIECE")),"+,T",2),12)
+4 DO PRCOLM
End DoDot:1
+5 IF ASUC("LN")>(IOSL-2)
SET ASUF("HDR")=1
+6 QUIT
PRCOLM ;
+1 WRITE ?ASURZX,ASURZ
+2 QUIT
PRTOTL ;
+1 IF ASUC("LN")>(IOSL-ASUV("LEV")*3)
SET ASUF("HDR")=1
+2 IF ASUF("HDR")
DO HEADER
IF $DATA(DUOUT)
QUIT
+3 WRITE !,$PIECE($TEXT(TOTNAM+ASUV("LEV")),";",4)
+4 SET ASUC("LN")=ASUC("LN")+1
+5 SET ASUV("SST")=0
+6 IF ASUV("LEV")=0
Begin DoDot:1
+7 DO PRDASH
+8 WRITE !?35,$PIECE($TEXT(TOTNAM+ASUV("LEV")),";",3)
+9 SET ASUC("LN")=ASUC("LN")+1
+10 DO PRLQTY
DO PRDDSH
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 DO PRSST
+13 SET ASUF("HDR")=1
+14 SET ASUV("SST")=0
+15 WRITE !?55,$PIECE($TEXT(TOTNAM+ASUV("LEV")),";",3)
+16 SET ASUC("LN")=ASUC("LN")+1
+17 DO PRLVAL
+18 WRITE !
DO PRDDSHV
End DoDot:1
+19 SET ASUV("SST")=ASUL(18,"SST","E#")
+20 KILL ASUQA(ASUV("LEV"))
+21 QUIT
PRDASH ;
+1 FOR ASUC=0:1:2
SET X=(ASUC*10)+60
WRITE ?X," _________"
PRDASHV ;
+1 FOR ASUC=0:1:2
SET X=(ASUC*12)+90
WRITE ?X," ___________",?1,""
+2 SET ASUC("LN")=ASUC("LN")+1
+3 QUIT
PRDDSH ;
+1 WRITE !
+2 FOR ASUC=0:1:2
SET X=(ASUC*10)+60
WRITE ?X," ========="
PRDDSHV ;
+1 FOR ASUC=0:1:2
SET X=(ASUC*12)+90
WRITE ?X," ===========",?1,""
+2 SET ASUC("LN")=ASUC("LN")+1
+3 QUIT
+1 SET ASUV("SST")=0
+2 FOR
SET ASUV("SST")=$ORDER(ASUQA(ASUV("LEV"),ASUV("SST")))
IF ASUV("SST")=""
QUIT
Begin DoDot:1
+3 WRITE !?50,$EXTRACT(ASUV("SST"),4,5)
+4 WRITE ?55,$PIECE($TEXT(TOTNAM+ASUV("LEV")),";",3)
+5 DO PRLVAL
End DoDot:1
+6 WRITE !
DO PRDASHV
+7 QUIT
+1 SET ASUC("PG")=ASUC("PG")+1
+2 IF ASUC("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
+3 WRITE @IOF,!,"REPORT #81 QUARTERLY LISTING OF ITEMS DROP SHIPPED",?70,"DATE : ",ASUV("DT"),?95,"PAGE :",$JUSTIFY(ASUC("PG"),3)
+4 WRITE !,"AREA: ",ASUQA("AR"),?50,$SELECT(ASUT("QTR")="04":"LAST",ASUT("QTR")="03":"THIRD",ASUT("QTR")="02":"SECOND",1:"1ST")," QUARTER OF FISCAL YEAR ",ASUP("YR")
+5 IF '$GET(ASUQA("ACC"))
SET ASUQA("ACC")=$GET(ASUL(9,"ACC"))_"-"_$GET(ASUL(9,"ACC","NM"))
+6 WRITE !,"STAT: ",ASUQA("STA"),?53,"GL ACCOUNT : ",ASUQA("ACC")
+7 WRITE !!?68,"QUANTITY ISSUED",?96,"ISSUE VALUE ISSUE VALUE"
+8 WRITE !?3,"INDEX ITEM",?45,"U",?49,"SUB",?55,"USER",?64,"CURRENT",?83,"MONTHLY",?96,"CURRENT",?119,"MONTHLY"
+9 WRITE !?2,"NUMBER DESCRIPTION",?46,"I",?49,"STA",?55,"CODE",?64,"QUARTER",?76,"Y-T-D",?83,"AVERAGE",?96,"QUARTER",?110,"Y-T-D",?119,"AVERAGE"
+10 WRITE !
FOR ASUC=1:1:132
WRITE "_"
+11 WRITE !!
+12 SET ASUC("LN")=10
SET ASUF("HDR")=0
+13 QUIT
TOTNAM ;;ITEM TOTAL
+1 ;;GL ACCOUNT TOTAL VALUE;SUMMARY OF DROP SHIPPED BY ACCOUNT
+2 ;;TOTAL VALUE DROP SHIPPED;SUMMARY OF TOTAL VALUE DROP SHIPPED
P3 ;
+1 FOR ASUV("PIECE")=1:1:6
Begin DoDot:1
+2 SET ASUQA(0,0)=$GET(ASUQA(0,0))
+3 SET $PIECE(ASUQA(0,0),U,ASUV("PIECE"))=$PIECE(ASUQA(0,0),U,ASUV("PIECE"))+$PIECE(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
End DoDot:1
+4 FOR ASUV("LEVA")=0:1:2
DO ONE
+5 QUIT
ONE ;
+1 FOR ASUV("PIECE")=1:1:6
Begin DoDot:1
+2 SET ASUQA(ASUV("LEVA")+1,ASUX("SST"))=$GET(ASUQA(ASUV("LEVA")+1,ASUX("SST")))
+3 SET $PIECE(ASUQA(ASUV("LEVA")+1,ASUX("SST")),U,ASUV("PIECE"))=$PIECE(ASUQA(ASUV("LEVA")+1,ASUX("SST")),U,ASUV("PIECE"))+$PIECE(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
+4 SET ASUQA(ASUV("LEVA")+1,0)=$GET(ASUQA(ASUV("LEVA")+1,0))
+5 SET $PIECE(ASUQA(ASUV("LEVA")+1,0),U,ASUV("PIECE"))=$PIECE(ASUQA(ASUV("LEVA")+1,0),U,ASUV("PIECE"))+$PIECE(ASUQA(0,ASUX("SST")),U,ASUV("PIECE"))
End DoDot:1
+6 QUIT
