ASURD10P ; IHS/ITSC/LMH -RPT 10A -LST DIRECT ISSUE TRANS ; [ 07/18/2000 7:59 AM ]
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 10, Direct Issues
;Transaction List.
;K ^XTMP("ASUR","R10A")
;S ^XTMP("ASUR","R10A",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 10
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^ASURD10P",ZTDESC="SAMS RPT 10A" 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 CMPT ;JDH D:'$D(^XTMP("ASUR","R10A")) CMPT
D U^ASUUZIS
S ASUV("RPT")="R10A",ASUQ("HDR")="HEADER^ASURD10P"
D ^ASUUDATA I ASUX("NDTA") G K
S (ASUX("VO"),ASUX("SQ"))="",(ASUC("TOT"),ASUC("VALTOT"))=0
F S ASUX("AS")=$O(^XTMP("ASUR","R10A",ASUX("AS"))) Q:ASUX("AS")="" D Q:$D(DUOUT)
.I ASUV("ARST")'=ASUX("AS") D HEADER Q:$D(DUOUT)
.S ASUV("ARST")=ASUX("AS")
.F S ASUX("VO")=$O(^XTMP("ASUR","R10A",ASUX("AS"),ASUX("VO"))) Q:ASUX("VO")="" D Q:$D(DUOUT)
..F S ASUX("SQ")=$O(^XTMP("ASUR","R10A",ASUX("AS"),ASUX("VO"),ASUX("SQ"))) Q:ASUX("SQ")="" D Q:$D(DUOUT)
...S ASUHDA=(^XTMP("ASUR","R10A",ASUX("AS"),ASUX("VO"),ASUX("SQ")))
...D READ^ASU0TRRD(.ASUHDA,"H") Q:$G(ASUT)']""
...I ASUC("LN")>(IOSL-2) D HEADER Q:$D(DUOUT)
...S ASUX("VAL")=ASUT(ASUT,"VAL")
...S ASUC("TOT")=ASUC("TOT")+1
...S:"0K0M0O0N"[ASUT("TRCD") ASUC("VALTOT")=ASUC("VALTOT")-ASUX("VAL")
...S:"02040506"[ASUT("TRCD") ASUC("VALTOT")=ASUC("VALTOT")+ASUX("VAL")
...W !?3,ASUT(ASUT,"VOU"),?15,ASUT("TRCD"),?21,$J(ASUT(ASUT,"QTY","ISS"),6)
...S ASUC("LN")=ASUC("LN")+1
...W ?29,$J($FN(ASUX("VAL"),",",2),9)
...W:"0K0M0O0N"[ASUT("TRCD") ?39,"-"
...W ?41,ASUT(ASUT,"ACC")
...S ASUV("SOBJ")=ASUT(ASUT,"SOBJ")
...W:ASUV("SOBJ")]"" ?47,$E(ASUV("SOBJ"),1,2)_"."_$E(ASUV("SOBJ"),3,4)
...W ?57,ASUT(ASUT,"SSA"),?62,ASUT(ASUT,"CAN")
...W ?70,ASUT(ASUT,"USR"),?75,ASUT(ASUT,"SST"),?82,ASUT(ASUT,"SRC"),?87,ASUT(ASUT,"PON")
.D:ASUC("LN")>(IOSL-4) HEADER
.W !!?2,"NUMBER LINE ITEMS: ",$J(ASUC("TOT"),6)
.W !?2,"TOTAL VALUE:$ ",?29,$J($FN(ASUC("VALTOT"),",",2),9)
.S ASUC("VALTOT")=0
K ;
K ASUX,ASUV,ASUC,ASUQ,ASUL(2),^XTMP("ASUR","R10A")
D PAZ^ASUURHDR
I ASUK("PTRSEL")]"" Q
D C^ASUUZIS
Q
CMPT ;EP;COMPUTE REPORT CONTENTS
K ^XTMP("ASUR","R10A") S ^XTMP("ASUR","R10A",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM") N Z
D:$G(ASUN("TYP"))']"" ^ASUURANG
F Z="02","04","05","06","0K","0M","0N","0O" D
.S ASUHDA=$G(ASUN("B#"))-1
.F S ASUHDA=$O(^ASUH("T",Z,ASUHDA)) Q:ASUHDA>$G(ASUN("E#")) Q:ASUHDA']"" D
..D READ^ASU0TRRD(.ASUHDA,"H") Q:$G(ASUT)']"" Q:$P(ASUT(ASUT,"TRKY"),"-")'=ASUL(2,"STA","E#")
..;S ^XTMP("ASUR","R10A",ASUT(ASUT,"PT","STA"),ASUT(ASUT,"VOU"),ASUHDA)=ASUHDA
Q
DUMB ;
F Z="5C","5D" D
S ASUC("PG")=$G(ASUC("PG"))+1
I ASUC("PG")>1 D PAZ^ASUURHDR Q:$D(DUOUT) W @IOF
W !?5,"REPORT #10A. LIST DIRECT ISSUE TRANSACTIONS"
W ?100,"DATE: ",ASUX("DT"),?120,"PAGE: ",ASUC("PG")
S X=ASUL(1,"AR","AP") W !?3,"AREA: ",ASUL(1,"AR","AP")
W ?15,ASUL(1,"AR","NM")
I ASUX("AS")'=$G(ASUL(2,"STA","E#")) D STA^ASULARST(ASUX("AS"))
W !?3,"STATION: ",$G(ASUL(2,"STA","CD"))
W ?15,$G(ASUL(2,"STA","NM"))
W !!?3,"VOUCHER",?14,"TRAN",?22,"NUMBER",?32,"VALUE",?39,"ACCOUNT",?47,"OBJECT",?54,"SUB SUB",?63,"CAN",?69,"USER",?75,"SUB",?80,"SOURCE",?88,"PURCHASE"
W !?3,"NUMBER",?14,"CODE",?20,"LINE ITEMS",?40,"CODE",?46,"SUB OBJ",?56,"ACT",?69,"CODE",?75,"STAT",?81,"CODE",?89,"ORDER"
W !,"------------------------------------------------------------------------------------------------------------------------------------",!!
S ASUC("LN")=9
Q
ASURD10P ; IHS/ITSC/LMH -RPT 10A -LST DIRECT ISSUE TRANS ; [ 07/18/2000 7:59 AM ]
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 10, Direct Issues
+3 ;Transaction List.
+4 ;K ^XTMP("ASUR","R10A")
+5 ;S ^XTMP("ASUR","R10A",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 10
+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^ASURD10P"
SET ZTDESC="SAMS RPT 10A"
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 ;JDH D:'$D(^XTMP("ASUR","R10A")) CMPT
DO CMPT
+2 DO U^ASUUZIS
+3 SET ASUV("RPT")="R10A"
SET ASUQ("HDR")="HEADER^ASURD10P"
+4 DO ^ASUUDATA
IF ASUX("NDTA")
GOTO K
+5 SET (ASUX("VO"),ASUX("SQ"))=""
SET (ASUC("TOT"),ASUC("VALTOT"))=0
+6 FOR
SET ASUX("AS")=$ORDER(^XTMP("ASUR","R10A",ASUX("AS")))
IF ASUX("AS")=""
QUIT
Begin DoDot:1
+7 IF ASUV("ARST")'=ASUX("AS")
DO HEADER
IF $DATA(DUOUT)
QUIT
+8 SET ASUV("ARST")=ASUX("AS")
+9 FOR
SET ASUX("VO")=$ORDER(^XTMP("ASUR","R10A",ASUX("AS"),ASUX("VO")))
IF ASUX("VO")=""
QUIT
Begin DoDot:2
+10 FOR
SET ASUX("SQ")=$ORDER(^XTMP("ASUR","R10A",ASUX("AS"),ASUX("VO"),ASUX("SQ")))
IF ASUX("SQ")=""
QUIT
Begin DoDot:3
+11 SET ASUHDA=(^XTMP("ASUR","R10A",ASUX("AS"),ASUX("VO"),ASUX("SQ")))
+12 DO READ^ASU0TRRD(.ASUHDA,"H")
IF $GET(ASUT)']""
QUIT
+13 IF ASUC("LN")>(IOSL-2)
DO HEADER
IF $DATA(DUOUT)
QUIT
+14 SET ASUX("VAL")=ASUT(ASUT,"VAL")
+15 SET ASUC("TOT")=ASUC("TOT")+1
+16 IF "0K0M0O0N"[ASUT("TRCD")
SET ASUC("VALTOT")=ASUC("VALTOT")-ASUX("VAL")
+17 IF "02040506"[ASUT("TRCD")
SET ASUC("VALTOT")=ASUC("VALTOT")+ASUX("VAL")
+18 WRITE !?3,ASUT(ASUT,"VOU"),?15,ASUT("TRCD"),?21,$JUSTIFY(ASUT(ASUT,"QTY","ISS"),6)
+19 SET ASUC("LN")=ASUC("LN")+1
+20 WRITE ?29,$JUSTIFY($FNUMBER(ASUX("VAL"),",",2),9)
+21 IF "0K0M0O0N"[ASUT("TRCD")
WRITE ?39,"-"
+22 WRITE ?41,ASUT(ASUT,"ACC")
+23 SET ASUV("SOBJ")=ASUT(ASUT,"SOBJ")
+24 IF ASUV("SOBJ")]""
WRITE ?47,$EXTRACT(ASUV("SOBJ"),1,2)_"."_$EXTRACT(ASUV("SOBJ"),3,4)
+25 WRITE ?57,ASUT(ASUT,"SSA"),?62,ASUT(ASUT,"CAN")
+26 WRITE ?70,ASUT(ASUT,"USR"),?75,ASUT(ASUT,"SST"),?82,ASUT(ASUT,"SRC"),?87,ASUT(ASUT,"PON")
End DoDot:3
IF $DATA(DUOUT)
QUIT
End DoDot:2
IF $DATA(DUOUT)
QUIT
+27 IF ASUC("LN")>(IOSL-4)
DO HEADER
+28 WRITE !!?2,"NUMBER LINE ITEMS: ",$JUSTIFY(ASUC("TOT"),6)
+29 WRITE !?2,"TOTAL VALUE:$ ",?29,$JUSTIFY($FNUMBER(ASUC("VALTOT"),",",2),9)
+30 SET ASUC("VALTOT")=0
End DoDot:1
IF $DATA(DUOUT)
QUIT
K ;
+1 KILL ASUX,ASUV,ASUC,ASUQ,ASUL(2),^XTMP("ASUR","R10A")
+2 DO PAZ^ASUURHDR
+3 IF ASUK("PTRSEL")]""
QUIT
+4 DO C^ASUUZIS
+5 QUIT
CMPT ;EP;COMPUTE REPORT CONTENTS
+1 KILL ^XTMP("ASUR","R10A")
SET ^XTMP("ASUR","R10A",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
NEW Z
+2 IF $GET(ASUN("TYP"))']""
DO ^ASUURANG
+3 FOR Z="02","04","05","06","0K","0M","0N","0O"
Begin DoDot:1
+4 SET ASUHDA=$GET(ASUN("B#"))-1
+5 FOR
SET ASUHDA=$ORDER(^ASUH("T",Z,ASUHDA))
IF ASUHDA>$GET(ASUN("E#"))
QUIT
IF ASUHDA']""
QUIT
Begin DoDot:2
+6 DO READ^ASU0TRRD(.ASUHDA,"H")
IF $GET(ASUT)']""
QUIT
IF $PIECE(ASUT(ASUT,"TRKY"),"-")'=ASUL(2,"STA","E#")
QUIT
+7 ;S ^XTMP("ASUR","R10A",ASUT(ASUT,"PT","STA"),ASUT(ASUT,"VOU"),ASUHDA)=ASUHDA
End DoDot:2
End DoDot:1
+8 QUIT
DUMB ;
+1 FOR Z="5C","5D"
Begin DoDot:1
End DoDot:1
+1 SET ASUC("PG")=$GET(ASUC("PG"))+1
+2 IF ASUC("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
WRITE @IOF
+3 WRITE !?5,"REPORT #10A. LIST DIRECT ISSUE TRANSACTIONS"
+4 WRITE ?100,"DATE: ",ASUX("DT"),?120,"PAGE: ",ASUC("PG")
+5 SET X=ASUL(1,"AR","AP")
WRITE !?3,"AREA: ",ASUL(1,"AR","AP")
+6 WRITE ?15,ASUL(1,"AR","NM")
+7 IF ASUX("AS")'=$GET(ASUL(2,"STA","E#"))
DO STA^ASULARST(ASUX("AS"))
+8 WRITE !?3,"STATION: ",$GET(ASUL(2,"STA","CD"))
+9 WRITE ?15,$GET(ASUL(2,"STA","NM"))
+10 WRITE !!?3,"VOUCHER",?14,"TRAN",?22,"NUMBER",?32,"VALUE",?39,"ACCOUNT",?47,"OBJECT",?54,"SUB SUB",?63,"CAN",?69,"USER",?75,"SUB",?80,"SOURCE",?88,"PURCHASE"
+11 WRITE !?3,"NUMBER",?14,"CODE",?20,"LINE ITEMS",?40,"CODE",?46,"SUB OBJ",?56,"ACT",?69,"CODE",?75,"STAT",?81,"CODE",?89,"ORDER"
+12 WRITE !,"------------------------------------------------------------------------------------------------------------------------------------",!!
+13 SET ASUC("LN")=9
+14 QUIT
