ASURD11P ; IHS/ITSC/LMH -RPT 11 DAILY TRANS REGISTER ; [ 07/17/2000 9:13 AM ]
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints Daily Transaction Register
EN ;EP;PRIMARY
D:'$D(IO) HOME^%ZIS I '$D(DUZ(2)) W !,"Report must be run from Kernel option" Q
D:'$D(ASUL(1,"AR","AP")) SETAREA^ASULARST
S ASUK("PTRSEL")=$G(ASUK("PTRSEL")) I ASUK("PTRSEL")]"" G PSER
S ZTRTN="PSER^ASURD11P",ZTDESC="SAMS RPT 11" D O^ASUUZIS I POP S IOP=$I D ^%ZIS Q
I ASUK(ASUK("PTR"),"Q") Q
PSER ;EP;FOR TM Q
D:'$D(^XTMP("ASUR","R11")) CMPT D U^ASUUZIS S ASUV("RPT")="R11",ASUQ("HDR")="HEADER^ASURD11P" D ^ASUUDATA I ASUX("NDTA") G K
S ASUC("LN")=9
S (ASUC("LI-TOT"),ASUC("VLR"),ASUC("VLI"),ASUC("VLJ"),ASUA("LIA"),ASUC("DEL"),ASUC("TOT"),ASUC("VALTOT"))=0
S ASUX("AS")=0 F S ASUX("AS")=$O(^XTMP("ASUR","R11",ASUX("AS"))) Q:ASUX("AS")="" D Q:$D(DUOUT)
.I ASUV("ARST")'=ASUX("AS") D
..K ASUL(2) D STA^ASULARST($E(ASUX("AS"),3,4)) S ASUV("ARST")=ASUX("AS")
.S ASUX("AG")="" F S ASUX("AG")=$O(^XTMP("ASUR","R11",ASUX("AS"),$G(ASUX("AG")))) Q:ASUX("AG")="" D Q:$D(DUOUT)
..I ASUC("LN")<(IOSL-2) W ! S ASUC("LN")=ASUC("LN")+1
..D:ASUC("LN")>(IOSL-3) HEADER^ASURD11P
..K ASUA D CALCT
..S ASUA("VL")=0
..S ASUX("IX")="" F S ASUX("IX")=$O(^XTMP("ASUR","R11",ASUX("AS"),ASUX("AG"),$G(ASUX("IX")))) Q:ASUX("IX")="" D Q:$D(DUOUT)
...S ASUA(0)=$G(^XTMP("ASUMA",ASUX("AS"),ASUX("AG"),ASUX("IX")))
...S (ASUCX("QTT"),ASUA("QTY"))=$P(ASUA(0),U,3),(ASUCX("VLT"),ASUA("VAL"))=$P(ASUA(0),U,2),(ASUCX("QTDIT"),ASUA("QTDI"))=$P(ASUA(0),U,4)
...S (ASUMS("E#","IDX"),ASUMX("E#","IDX"))=ASUX("IX") D READ^ASUMXDIO,^ASUMSTRD
...S ASUC("LN")=ASUC("LN")+1 W !?3,ASUMX("ACC"),?5,ASUMS("EOQ","TP"),?7,ASUMS("SRC"),?9,$E(ASUX("IX"),3,7),".",$E(ASUX("IX"),8),?17,ASUMS("SLC")
...S X=$S(ASUMX("DESC")]"":ASUMX("DESC"),1:ASUMX("DELDS")) W ?19,$E(X,1,30),?51,ASUMX("AR U/I"),?55,$E(ASUMS("ESTB"),2,3),"-",$E(ASUMS("ESTB"),4,5)
...W:$G(ASUT("TYPE"))'=1 ?68,$J($FN(ASUA("QTY"),"T"),5)
...W ?75,$J($FN(ASUMS("CST/U"),"T",2),8),?89,$J($FN(ASUA("VAL"),"T",2),12)
...W ?101,$J($FN(ASUA("QTDI"),"T"),6),?131,ASUMX("CAT"),!
...S ASUCX("QTDIT")=$G(ASUA("QTDI")),ASUF("DESC")=1
...S ASUV("NSN")=ASUMS("ORD#") I ASUV("NSN")=$C(32)!(ASUV("NSN")="") S ASUV("NSN")=ASUMX("NSN")
...I $E(ASUV("NSN"))'="M" S ASUV("NSN")=$E(ASUV("NSN"),1,4)_"-"_$E(ASUV("NSN"),5,6)_"-"_$E(ASUV("NSN"),7,9)_"-"_$E(ASUV("NSN"),10,14)
...S ASUX("SQ")="" F S ASUX("SQ")=$O(^XTMP("ASUR","R11",ASUX("AS"),ASUX("AG"),ASUX("IX"),$G(ASUX("SQ")))) Q:ASUX("SQ")="" D
....S ASUHDA=^XTMP("ASUR","R11",ASUX("AS"),ASUX("AG"),ASUX("IX"),ASUX("SQ")) K ASUT D READ^ASU0TRRD(.ASUHDA,"H") Q:$G(ASUT)']"" I "4A4C5A5C"[ASUT("TRCD") Q
....I ASUC("LN")>(IOSL-5) D HEADER^ASURD11P
....S ASUC("LI-TOT")=$G(ASUC("LI-TOT"))+1 S ASUV("CST/U")=""
....I ASUT("TRCD")="5D" S ASUCX("QTDIT")=0
....I $E(ASUT("TRCD"))="1" D
.....S ASUX("QTDI")=ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN")
.....I ASUX("QTDI")=0 D
......S (ASUX("QTDI"),ASUV("CST/U"))=0
.....E D
......S ASUV("CST/U")=ASUT(ASUT,"VAL")/ASUX("QTDI")
....E D
.....I ASUT(ASUT,"QTY")=0!(ASUT(ASUT,"QTY")="") S ASUV("CST/U")=ASUMS("LPP")
.....E S ASUV("CST/U")=ASUT(ASUT,"VAL")/ASUT(ASUT,"QTY")
....I ASUV("CST/U")<0 S ASUV("CST/U")=ASUV("CST/U")*-1
....I "2K2M2N2O2P323334363731"[ASUT("TRCD") D
.....D P8 W ?51,$G(ASUT(ASUT,"U/I")),?52,ASUT(ASUT,"VOU") S:ASUT(ASUT,"QTY")=0 ASUV("CST/U")=0
.....W ?63,ASUT("TRCD"),$G(ASUT(ASUT,"PST")),?68,$J($FN((ASUT(ASUT,"QTY")*-1),"T"),5),?75,$J($FN(ASUV("CST/U"),"T,",2),8) K X
.....W:ASUT(ASUT,"FPN")="P" ?88,"P"
.....W ?89,$J($FN((ASUT(ASUT,"VAL")*-1),"T,",2),12)
.....S ASUT(ASUT,"VAL")=ASUT(ASUT,"VAL")*-1,ASUCX("VLT")=$G(ASUCX("VLT"))+ASUT(ASUT,"VAL")
.....S ASUCX("QTT")=$G(ASUCX("QTT"))-ASUT(ASUT,"QTY")
.....I "2K2M2N2O"[ASUT("TRCD") S ASUC("VLR")=$G(ASUC("VLR"))+ASUT(ASUT,"VAL")
.....I "313332"[ASUT("TRCD") S ASUC("VLI")=$G(ASUC("VLI"))+ASUT(ASUT,"VAL")
.....I "2P343637"[ASUT("TRCD") S ASUC("VLJ")=$G(ASUC("VLJ"))+ASUT(ASUT,"VAL")
....I "22242526273K3L3M3O3P"[ASUT("TRCD") D
.....W:ASUT(ASUT,"SRC")]"" ?7,$E(ASUT(ASUT,"SRC")) D P8 W $G(ASUT(ASUT,"U/I")),?52,ASUT(ASUT,"VOU"),?63,ASUT("TRCD")
.....W ?68,$J($FN(ASUT(ASUT,"QTY"),"T"),5)
.....W ?75,$J($FN(ASUV("CST/U"),"T,",2),8)
.....W:ASUT(ASUT,"SRC")'=ASUMS("SRC") ?87,"*"
.....W ?89,$J($FN(ASUT(ASUT,"VAL"),"T,",2),12)
.....I $G(ASUT(ASUT,"D/IF"))]"" D
......S ASUX("QTDI")=ASUT(ASUT,"D/IF") S:ASUX("QTDI")=0 ASUX("QTDI")=(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN"))
......W ?101,$J($FN(ASUX("QTDI"),"T",0),6) S ASUCX("QTDIT")=$G(ASUCX("QTDIT"))+ASUX("QTDI")
.....S ASUX("QTDI")=0,ASUCX("VLT")=$G(ASUCX("VLT"))+ASUT(ASUT,"VAL")
.....S ASUCX("QTT")=$G(ASUCX("QTT"))+ASUT(ASUT,"QTY")
.....I "22242526"[ASUT("TRCD") S ASUC("VLR")=$G(ASUC("VLR"))+ASUT(ASUT,"VAL")
.....I "3K3L"[ASUT("TRCD") S ASUC("VLI")=$G(ASUC("VLI"))+ASUT(ASUT,"VAL")
.....I "273P3M3O"[ASUT("TRCD") S ASUC("VLJ")=$G(ASUC("VLJ"))+ASUT(ASUT,"VAL")
....I "121415161K1M1N1O"[ASUT("TRCD") D
.....W ?7,$E(ASUT(ASUT,"SRC")) D P8 W ?51,$G(ASUT(ASUT,"U/I"))
.....S ASUT(ASUT,"VAL")=0
.....I $L(ASUT(ASUT,"DTD"))>0&(ASUT(ASUT,"DTD")'=" ") W ?52,$E(ASUT(ASUT,"DTD"),4,5)_"-"_$E(ASUT(ASUT,"DTD"),6,7)_"-"_$E(ASUT(ASUT,"DTD"),2,3)
.....W ?63,ASUT("TRCD")
.....;W ?68,$J($FN(ASUT(ASUT,"QTY"),"T"),5)
.....W ?75,$J($FN(ASUV("CST/U"),"T,",2),8)
.....;S ASUCX("VLT")=$G(ASUCX("VLT"))+ASUT(ASUT,"VAL"),ASUCX("QTT")=$G(ASUCX("QTT"))+ASUT(ASUT,"QTY")
.....S ASUCX("QTDIT")=$G(ASUCX("QTDIT"))+ASUX("QTDI")
.....W ?101,$J($FN(ASUX("QTDI"),"T"),6)
....I ASUT("TRCD")="5D" D
.....W ?55,ASUT(ASUT,"VOU"),?91,"ITEM DEL" S (ASUCX("QTT"),ASUCX("QTDIT"),ASUCX("VLT"))=0
....W ?108,$G(ASUT(ASUT,"REQ TYP")),?110,$G(ASUT(ASUT,"SSA"))
....W:ASUT("TYPE")'=2 ?113,$G(ASUT(ASUT,"SST"))
....W ?116,$G(ASUT(ASUT,"PON"))
....W:ASUT("TYPE")'=2 ?117,$G(ASUT(ASUT,"CAN"))
....I ASUT("TYPE")>2 W ?126,$G(ASUT(ASUT,"USR")),!
....E W !
....S ASUC("LN")=ASUC("LN")+1
....I ASUC("LN")>(IOSL-5) D HEADER^ASURD11P
...I ASUF("DESC")=1 W !?19,$E(ASUMX("DESC"),31,60) S ASUF("DESC")=2,ASUC("LN")=ASUC("LN")+1
...I ASUF("DESC")=2 W !?33,ASUV("NSN") S ASUF("DESC")=3,ASUC("LN")=ASUC("LN")+1
...;S ASUCX("VLT")=$G(ASUCX("VLT"))+$G(ASUA("VL")),ASUCX("QTT")=$G(ASUCX("QTT"))+$G(ASUA("QTY"))
...I $G(ASUCX("QTDIT"))<0 S ASUCX("QTDIT")=0
...I $G(ASUCX("QTT"))<0 S ASUCX("QTT")=0
...W ?68,"______",?89,"___________",?102,"______",!?60,"TOTAL",?68,$J($FN(ASUCX("QTT"),"T",0),5),?89,$J($FN(ASUCX("VLT"),"T,",2),12),?101,$J(ASUCX("QTDIT"),6),?111,"PAMIQ=",ASUMS("PMIQ"),!
...S ASUC("LN")=ASUC("LN")+2 K ASUCX
..Q:$D(DUOUT)
..S ASUC("VLGT")=ASUC("VLR")+ASUC("VLI")+ASUC("VLJ")+$G(ASUA("VLN"))+$G(ASUA("VLA")),ASUC("LN")=ASUC("LN")+8 I ASUC("LN")>(IOSL-5) D HEADER Q:$D(DUOUT)
..W !?10,"OPENING ACTIVE INVENTORY VALUE:",$J($FN($G(ASUA("VLA")),"T,",2),14),?64,"ACTIVE LI:",$J($FN($G(ASUA("LIA")),",",0),7)
..W !?27,"RECEIPT VALUE:",$J($FN($G(ASUC("VLR")),"T,",2),14),?62,"INACTIVE LI:",$J($FN($G(ASUA("LIN")),"",0),7)
..W !?29,"ISSUE VALUE:",$J($FN($G(ASUC("VLI")),"T,",2),14),?65,"TOTAL LI:",$J($FN(($G(ASUA("LIN"))+$G(ASUA("LIA"))),",",0),7)
..W !?24,"ADJUSTMENT VALUE:",$J($FN($G(ASUC("VLJ")),"T,",2),14)
..W !?16,"INACTIVE INVENTORY VALUE:",$J($FN($G(ASUA("VLN")),"T,",2),14)
..W !?17,"TOTAL CLOSING INVENTORY:",$J($FN($G(ASUC("VLGT")),"T,",2),14)
..S (ASUC("VLR"),ASUC("VLI"),ASUC("VLJ"),ASUC("VLGT"),ASUA("VLA"),ASUA("VL"))=0,ASUC("LN")=IOSL+1
K ;
K ASUX,ASUV,ASUC,ASUCX,ASUQ D PAZ^ASUURHDR I ASUK("PTRSEL")]"" W @IOF Q
D C^ASUUZIS Q
Q:$G(ASUX("AG"))']""
S ASUC("PG")=$G(ASUC("PG"))+1 I ASUC("PG")>1 D PAZ^ASUURHDR Q:$D(DUOUT) W @IOF
W ?5,"REPORT #11. SAMS STOCK TRANSACTION REGISTER",?100,"DATE: ",ASUX("DT"),?120,"PAGE: ",ASUC("PG")
W !?3,"AREA: ",ASUL(1,"AR","AP"),?15,ASUL(1,"AR","NM")
W !?3,"STATION: ",$G(ASUL(2,"STA","CD")),?15,$G(ASUL(2,"STA","NM")),?50,"ACCOUNT GROUP: ",$S(ASUX("AG")=1:"PHARMACY",ASUX("AG")=3:"SUBSISTENCE",1:"GENERAL SUPPLIES")
W !!?3,"A",?5,"T",?7,"S",?17,"S",?51,"U",?55,"DATE",?63,"TR",?67,"QUANTITY",?80,"UNIT",?91,"TOTAL",?99,"DUE-IN",?108,"T",?118,"PO",?125,"USR CAT"
W !?3,"C",?5,"Y",?7,"O",?9,"INDEX",?17,"L",?19,"DESCRIPTION",?51,"I",?63,"CD",?80,"COST",?91,"VALUE",?99,"QUANTITY",?108,"I",?110,"SUB",?114,"SUB",?118,"OR",?130,"CD"
W !?3,"C",?5,"P",?7,"U",?9,"NUMBER",?17,"C",?33,"ORDER NUMBER",?53,"VOUCHER NO",?108,"R",?110,"ACT",?114,"STA",?118,"CAN"
W !,"------------------------------------------------------------------------------------------------------------------------------------",!!
S ASUC("LN")=9
Q
P8 ;WRITE DESCRIPTION LINES
I '$D(ASUF("DESC")) S ASUF("DESC")=1
I ASUF("DESC")>2 S ASUF("DESC")=ASUF("DESC")+1
I ASUF("DESC")=2 W ?33,ASUV("NSN") S ASUF("DESC")=3
I ASUF("DESC")=1 W ?19,$E(ASUMX("DESC"),31,60) S ASUF("DESC")=2
Q
CALCT ;
S ASUN("E#")="" F S ASUN("E#")=$O(^XTMP("ASUMA",ASUX("AS"),ASUX("AG"),ASUN("E#"))) Q:ASUN("E#")="" D
.S ASUA(0)=^XTMP("ASUMA",ASUX("AS"),ASUX("AG"),ASUN("E#"))
.I $P(ASUA(0),U)="A" D
..S ASUA("LIA")=$G(ASUA("LIA"))+1,ASUA("VLA")=$G(ASUA("VLA"))+$P(ASUA(0),U,2)
.E D
..S ASUA("LIN")=$G(ASUA("LIN"))+1,ASUA("VLN")=$G(ASUA("VLN"))+$P(ASUA(0),U,2)
Q
CMPT ;EP;COMPUTE CONTENTS
K ^XTMP("ASUR","R11") S ^XTMP("ASUR","R11",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM"),ASUTX=0
D:$G(ASUN("TYP"))']"" ^ASUURANG
S ASUHDA=$G(ASUN("B#"))-1
F S ASUHDA=$O(^ASUH(ASUHDA)) Q:ASUHDA>$G(ASUN("E#")) Q:ASUHDA'?1N.N D
.Q:ASUHDA=0
.D READ^ASU0TRRD(.ASUHDA,"H") Q:$G(ASUT)']"" Q:$E(ASUT("TRCD"))="4" Q:$E(ASUT("TRCD"))="0" Q:ASUT="UNK"
.S ^XTMP("ASUR","R11",ASUT(ASUT,"PT","STA"),ASUL(9,"ACG"),ASUT(ASUT,"PT","IDX"),ASUHDA)=ASUHDA
Q
ASURD11P ; IHS/ITSC/LMH -RPT 11 DAILY TRANS REGISTER ; [ 07/17/2000 9:13 AM ]
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints Daily Transaction Register
EN ;EP;PRIMARY
+1 IF '$DATA(IO)
DO HOME^%ZIS
IF '$DATA(DUZ(2))
WRITE !,"Report must be run from Kernel option"
QUIT
+2 IF '$DATA(ASUL(1,"AR","AP"))
DO SETAREA^ASULARST
+3 SET ASUK("PTRSEL")=$GET(ASUK("PTRSEL"))
IF ASUK("PTRSEL")]""
GOTO PSER
+4 SET ZTRTN="PSER^ASURD11P"
SET ZTDESC="SAMS RPT 11"
DO O^ASUUZIS
IF POP
SET IOP=$IO
DO ^%ZIS
QUIT
+5 IF ASUK(ASUK("PTR"),"Q")
QUIT
PSER ;EP;FOR TM Q
+1 IF '$DATA(^XTMP("ASUR","R11"))
DO CMPT
DO U^ASUUZIS
SET ASUV("RPT")="R11"
SET ASUQ("HDR")="HEADER^ASURD11P"
DO ^ASUUDATA
IF ASUX("NDTA")
GOTO K
+2 SET ASUC("LN")=9
+3 SET (ASUC("LI-TOT"),ASUC("VLR"),ASUC("VLI"),ASUC("VLJ"),ASUA("LIA"),ASUC("DEL"),ASUC("TOT"),ASUC("VALTOT"))=0
+4 SET ASUX("AS")=0
FOR
SET ASUX("AS")=$ORDER(^XTMP("ASUR","R11",ASUX("AS")))
IF ASUX("AS")=""
QUIT
Begin DoDot:1
+5 IF ASUV("ARST")'=ASUX("AS")
Begin DoDot:2
+6 KILL ASUL(2)
DO STA^ASULARST($EXTRACT(ASUX("AS"),3,4))
SET ASUV("ARST")=ASUX("AS")
End DoDot:2
+7 SET ASUX("AG")=""
FOR
SET ASUX("AG")=$ORDER(^XTMP("ASUR","R11",ASUX("AS"),$GET(ASUX("AG"))))
IF ASUX("AG")=""
QUIT
Begin DoDot:2
+8 IF ASUC("LN")<(IOSL-2)
WRITE !
SET ASUC("LN")=ASUC("LN")+1
+9 IF ASUC("LN")>(IOSL-3)
DO HEADER^ASURD11P
+10 KILL ASUA
DO CALCT
+11 SET ASUA("VL")=0
+12 SET ASUX("IX")=""
FOR
SET ASUX("IX")=$ORDER(^XTMP("ASUR","R11",ASUX("AS"),ASUX("AG"),$GET(ASUX("IX"))))
IF ASUX("IX")=""
QUIT
Begin DoDot:3
+13 SET ASUA(0)=$GET(^XTMP("ASUMA",ASUX("AS"),ASUX("AG"),ASUX("IX")))
+14 SET (ASUCX("QTT"),ASUA("QTY"))=$PIECE(ASUA(0),U,3)
SET (ASUCX("VLT"),ASUA("VAL"))=$PIECE(ASUA(0),U,2)
SET (ASUCX("QTDIT"),ASUA("QTDI"))=$PIECE(ASUA(0),U,4)
+15 SET (ASUMS("E#","IDX"),ASUMX("E#","IDX"))=ASUX("IX")
DO READ^ASUMXDIO
DO ^ASUMSTRD
+16 SET ASUC("LN")=ASUC("LN")+1
WRITE !?3,ASUMX("ACC"),?5,ASUMS("EOQ","TP"),?7,ASUMS("SRC"),?9,$EXTRACT(ASUX("IX"),3,7),".",$EXTRACT(ASUX("IX"),8),?17,ASUMS("SLC")
+17 SET X=$SELECT(ASUMX("DESC")]"":ASUMX("DESC"),1:ASUMX("DELDS"))
WRITE ?19,$EXTRACT(X,1,30),?51,ASUMX("AR U/I"),?55,$EXTRACT(ASUMS("ESTB"),2,3),"-",$EXTRACT(ASUMS("ESTB"),4,5)
+18 IF $GET(ASUT("TYPE"))'=1
WRITE ?68,$JUSTIFY($FNUMBER(ASUA("QTY"),"T"),5)
+19 WRITE ?75,$JUSTIFY($FNUMBER(ASUMS("CST/U"),"T",2),8),?89,$JUSTIFY($FNUMBER(ASUA("VAL"),"T",2),12)
+20 WRITE ?101,$JUSTIFY($FNUMBER(ASUA("QTDI"),"T"),6),?131,ASUMX("CAT"),!
+21 SET ASUCX("QTDIT")=$GET(ASUA("QTDI"))
SET ASUF("DESC")=1
+22 SET ASUV("NSN")=ASUMS("ORD#")
IF ASUV("NSN")=$CHAR(32)!(ASUV("NSN")="")
SET ASUV("NSN")=ASUMX("NSN")
+23 IF $EXTRACT(ASUV("NSN"))'="M"
SET ASUV("NSN")=$EXTRACT(ASUV("NSN"),1,4)_"-"_$EXTRACT(ASUV("NSN"),5,6)_"-"_$EXTRACT(ASUV("NSN"),7,9)_"-"_$EXTRACT(ASUV("NSN"),10,14)
+24 SET ASUX("SQ")=""
FOR
SET ASUX("SQ")=$ORDER(^XTMP("ASUR","R11",ASUX("AS"),ASUX("AG"),ASUX("IX"),$GET(ASUX("SQ"))))
IF ASUX("SQ")=""
QUIT
Begin DoDot:4
+25 SET ASUHDA=^XTMP("ASUR","R11",ASUX("AS"),ASUX("AG"),ASUX("IX"),ASUX("SQ"))
KILL ASUT
DO READ^ASU0TRRD(.ASUHDA,"H")
IF $GET(ASUT)']""
QUIT
IF "4A4C5A5C"[ASUT("TRCD")
QUIT
+26 IF ASUC("LN")>(IOSL-5)
DO HEADER^ASURD11P
+27 SET ASUC("LI-TOT")=$GET(ASUC("LI-TOT"))+1
SET ASUV("CST/U")=""
+28 IF ASUT("TRCD")="5D"
SET ASUCX("QTDIT")=0
+29 IF $EXTRACT(ASUT("TRCD"))="1"
Begin DoDot:5
+30 SET ASUX("QTDI")=ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN")
+31 IF ASUX("QTDI")=0
Begin DoDot:6
+32 SET (ASUX("QTDI"),ASUV("CST/U"))=0
End DoDot:6
+33 IF '$TEST
Begin DoDot:6
+34 SET ASUV("CST/U")=ASUT(ASUT,"VAL")/ASUX("QTDI")
End DoDot:6
End DoDot:5
+35 IF '$TEST
Begin DoDot:5
+36 IF ASUT(ASUT,"QTY")=0!(ASUT(ASUT,"QTY")="")
SET ASUV("CST/U")=ASUMS("LPP")
+37 IF '$TEST
SET ASUV("CST/U")=ASUT(ASUT,"VAL")/ASUT(ASUT,"QTY")
End DoDot:5
+38 IF ASUV("CST/U")<0
SET ASUV("CST/U")=ASUV("CST/U")*-1
+39 IF "2K2M2N2O2P323334363731"[ASUT("TRCD")
Begin DoDot:5
+40 DO P8
WRITE ?51,$GET(ASUT(ASUT,"U/I")),?52,ASUT(ASUT,"VOU")
IF ASUT(ASUT,"QTY")=0
SET ASUV("CST/U")=0
+41 WRITE ?63,ASUT("TRCD"),$GET(ASUT(ASUT,"PST")),?68,$JUSTIFY($FNUMBER((ASUT(ASUT,"QTY")*-1),"T"),5),?75,$JUSTIFY($FNUMBER(ASUV("CST/U"),"T,",2),8)
KILL X
+42 IF ASUT(ASUT,"FPN")="P"
WRITE ?88,"P"
+43 WRITE ?89,$JUSTIFY($FNUMBER((ASUT(ASUT,"VAL")*-1),"T,",2),12)
+44 SET ASUT(ASUT,"VAL")=ASUT(ASUT,"VAL")*-1
SET ASUCX("VLT")=$GET(ASUCX("VLT"))+ASUT(ASUT,"VAL")
+45 SET ASUCX("QTT")=$GET(ASUCX("QTT"))-ASUT(ASUT,"QTY")
+46 IF "2K2M2N2O"[ASUT("TRCD")
SET ASUC("VLR")=$GET(ASUC("VLR"))+ASUT(ASUT,"VAL")
+47 IF "313332"[ASUT("TRCD")
SET ASUC("VLI")=$GET(ASUC("VLI"))+ASUT(ASUT,"VAL")
+48 IF "2P343637"[ASUT("TRCD")
SET ASUC("VLJ")=$GET(ASUC("VLJ"))+ASUT(ASUT,"VAL")
End DoDot:5
+49 IF "22242526273K3L3M3O3P"[ASUT("TRCD")
Begin DoDot:5
+50 IF ASUT(ASUT,"SRC")]""
WRITE ?7,$EXTRACT(ASUT(ASUT,"SRC"))
DO P8
WRITE $GET(ASUT(ASUT,"U/I")),?52,ASUT(ASUT,"VOU"),?63,ASUT("TRCD")
+51 WRITE ?68,$JUSTIFY($FNUMBER(ASUT(ASUT,"QTY"),"T"),5)
+52 WRITE ?75,$JUSTIFY($FNUMBER(ASUV("CST/U"),"T,",2),8)
+53 IF ASUT(ASUT,"SRC")'=ASUMS("SRC")
WRITE ?87,"*"
+54 WRITE ?89,$JUSTIFY($FNUMBER(ASUT(ASUT,"VAL"),"T,",2),12)
+55 IF $GET(ASUT(ASUT,"D/IF"))]""
Begin DoDot:6
+56 SET ASUX("QTDI")=ASUT(ASUT,"D/IF")
IF ASUX("QTDI")=0
SET ASUX("QTDI")=(ASUT(ASUT,"QTY")*ASUT(ASUT,"SIGN"))
+57 WRITE ?101,$JUSTIFY($FNUMBER(ASUX("QTDI"),"T",0),6)
SET ASUCX("QTDIT")=$GET(ASUCX("QTDIT"))+ASUX("QTDI")
End DoDot:6
+58 SET ASUX("QTDI")=0
SET ASUCX("VLT")=$GET(ASUCX("VLT"))+ASUT(ASUT,"VAL")
+59 SET ASUCX("QTT")=$GET(ASUCX("QTT"))+ASUT(ASUT,"QTY")
+60 IF "22242526"[ASUT("TRCD")
SET ASUC("VLR")=$GET(ASUC("VLR"))+ASUT(ASUT,"VAL")
+61 IF "3K3L"[ASUT("TRCD")
SET ASUC("VLI")=$GET(ASUC("VLI"))+ASUT(ASUT,"VAL")
+62 IF "273P3M3O"[ASUT("TRCD")
SET ASUC("VLJ")=$GET(ASUC("VLJ"))+ASUT(ASUT,"VAL")
End DoDot:5
+63 IF "121415161K1M1N1O"[ASUT("TRCD")
Begin DoDot:5
+64 WRITE ?7,$EXTRACT(ASUT(ASUT,"SRC"))
DO P8
WRITE ?51,$GET(ASUT(ASUT,"U/I"))
+65 SET ASUT(ASUT,"VAL")=0
+66 IF $LENGTH(ASUT(ASUT,"DTD"))>0&(ASUT(ASUT,"DTD")'=" ")
WRITE ?52,$EXTRACT(ASUT(ASUT,"DTD"),4,5)_"-"_$EXTRACT(ASUT(ASUT,"DTD"),6,7)_"-"_$EXTRACT(ASUT(ASUT,"DTD"),2,3)
+67 WRITE ?63,ASUT("TRCD")
+68 ;W ?68,$J($FN(ASUT(ASUT,"QTY"),"T"),5)
+69 WRITE ?75,$JUSTIFY($FNUMBER(ASUV("CST/U"),"T,",2),8)
+70 ;S ASUCX("VLT")=$G(ASUCX("VLT"))+ASUT(ASUT,"VAL"),ASUCX("QTT")=$G(ASUCX("QTT"))+ASUT(ASUT,"QTY")
+71 SET ASUCX("QTDIT")=$GET(ASUCX("QTDIT"))+ASUX("QTDI")
+72 WRITE ?101,$JUSTIFY($FNUMBER(ASUX("QTDI"),"T"),6)
End DoDot:5
+73 IF ASUT("TRCD")="5D"
Begin DoDot:5
+74 WRITE ?55,ASUT(ASUT,"VOU"),?91,"ITEM DEL"
SET (ASUCX("QTT"),ASUCX("QTDIT"),ASUCX("VLT"))=0
End DoDot:5
+75 WRITE ?108,$GET(ASUT(ASUT,"REQ TYP")),?110,$GET(ASUT(ASUT,"SSA"))
+76 IF ASUT("TYPE")'=2
WRITE ?113,$GET(ASUT(ASUT,"SST"))
+77 WRITE ?116,$GET(ASUT(ASUT,"PON"))
+78 IF ASUT("TYPE")'=2
WRITE ?117,$GET(ASUT(ASUT,"CAN"))
+79 IF ASUT("TYPE")>2
WRITE ?126,$GET(ASUT(ASUT,"USR")),!
+80 IF '$TEST
WRITE !
+81 SET ASUC("LN")=ASUC("LN")+1
+82 IF ASUC("LN")>(IOSL-5)
DO HEADER^ASURD11P
End DoDot:4
+83 IF ASUF("DESC")=1
WRITE !?19,$EXTRACT(ASUMX("DESC"),31,60)
SET ASUF("DESC")=2
SET ASUC("LN")=ASUC("LN")+1
+84 IF ASUF("DESC")=2
WRITE !?33,ASUV("NSN")
SET ASUF("DESC")=3
SET ASUC("LN")=ASUC("LN")+1
+85 ;S ASUCX("VLT")=$G(ASUCX("VLT"))+$G(ASUA("VL")),ASUCX("QTT")=$G(ASUCX("QTT"))+$G(ASUA("QTY"))
+86 IF $GET(ASUCX("QTDIT"))<0
SET ASUCX("QTDIT")=0
+87 IF $GET(ASUCX("QTT"))<0
SET ASUCX("QTT")=0
+88 WRITE ?68,"______",?89,"___________",?102,"______",!?60,"TOTAL",?68,$JUSTIFY($FNUMBER(ASUCX("QTT"),"T",0),5),?89,$JUSTIFY($FNUMBER(ASUCX("VLT"),"T,",2),12),?101,$JUSTIFY(ASUCX("QTDIT"),6),?111,"PAMIQ=",ASUMS("PMIQ"),!
+89 SET ASUC("LN")=ASUC("LN")+2
KILL ASUCX
End DoDot:3
IF $DATA(DUOUT)
QUIT
+90 IF $DATA(DUOUT)
QUIT
+91 SET ASUC("VLGT")=ASUC("VLR")+ASUC("VLI")+ASUC("VLJ")+$GET(ASUA("VLN"))+$GET(ASUA("VLA"))
SET ASUC("LN")=ASUC("LN")+8
IF ASUC("LN")>(IOSL-5)
DO HEADER
IF $DATA(DUOUT)
QUIT
+92 WRITE !?10,"OPENING ACTIVE INVENTORY VALUE:",$JUSTIFY($FNUMBER($GET(ASUA("VLA")),"T,",2),14),?64,"ACTIVE LI:",$JUSTIFY($FNUMBER($GET(ASUA("LIA")),",",0),7)
+93 WRITE !?27,"RECEIPT VALUE:",$JUSTIFY($FNUMBER($GET(ASUC("VLR")),"T,",2),14),?62,"INACTIVE LI:",$JUSTIFY($FNUMBER($GET(ASUA("LIN")),"",0),7)
+94 WRITE !?29,"ISSUE VALUE:",$JUSTIFY($FNUMBER($GET(ASUC("VLI")),"T,",2),14),?65,"TOTAL LI:",$JUSTIFY($FNUMBER(($GET(ASUA("LIN"))+$GET(ASUA("LIA"))),",",0),7)
+95 WRITE !?24,"ADJUSTMENT VALUE:",$JUSTIFY($FNUMBER($GET(ASUC("VLJ")),"T,",2),14)
+96 WRITE !?16,"INACTIVE INVENTORY VALUE:",$JUSTIFY($FNUMBER($GET(ASUA("VLN")),"T,",2),14)
+97 WRITE !?17,"TOTAL CLOSING INVENTORY:",$JUSTIFY($FNUMBER($GET(ASUC("VLGT")),"T,",2),14)
+98 SET (ASUC("VLR"),ASUC("VLI"),ASUC("VLJ"),ASUC("VLGT"),ASUA("VLA"),ASUA("VL"))=0
SET ASUC("LN")=IOSL+1
End DoDot:2
IF $DATA(DUOUT)
QUIT
End DoDot:1
IF $DATA(DUOUT)
QUIT
K ;
+1 KILL ASUX,ASUV,ASUC,ASUCX,ASUQ
DO PAZ^ASUURHDR
IF ASUK("PTRSEL")]""
WRITE @IOF
QUIT
+2 DO C^ASUUZIS
QUIT
+1 IF $GET(ASUX("AG"))']""
QUIT
+2 SET ASUC("PG")=$GET(ASUC("PG"))+1
IF ASUC("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
WRITE @IOF
+3 WRITE ?5,"REPORT #11. SAMS STOCK TRANSACTION REGISTER",?100,"DATE: ",ASUX("DT"),?120,"PAGE: ",ASUC("PG")
+4 WRITE !?3,"AREA: ",ASUL(1,"AR","AP"),?15,ASUL(1,"AR","NM")
+5 WRITE !?3,"STATION: ",$GET(ASUL(2,"STA","CD")),?15,$GET(ASUL(2,"STA","NM")),?50,"ACCOUNT GROUP: ",$SELECT(ASUX("AG")=1:"PHARMACY",ASUX("AG")=3:"SUBSISTENCE",1:"GENERAL SUPPLIES")
+6 WRITE !!?3,"A",?5,"T",?7,"S",?17,"S",?51,"U",?55,"DATE",?63,"TR",?67,"QUANTITY",?80,"UNIT",?91,"TOTAL",?99,"DUE-IN",?108,"T",?118,"PO",?125,"USR CAT"
+7 WRITE !?3,"C",?5,"Y",?7,"O",?9,"INDEX",?17,"L",?19,"DESCRIPTION",?51,"I",?63,"CD",?80,"COST",?91,"VALUE",?99,"QUANTITY",?108,"I",?110,"SUB",?114,"SUB",?118,"OR",?130,"CD"
+8 WRITE !?3,"C",?5,"P",?7,"U",?9,"NUMBER",?17,"C",?33,"ORDER NUMBER",?53,"VOUCHER NO",?108,"R",?110,"ACT",?114,"STA",?118,"CAN"
+9 WRITE !,"------------------------------------------------------------------------------------------------------------------------------------",!!
+10 SET ASUC("LN")=9
+11 QUIT
P8 ;WRITE DESCRIPTION LINES
+1 IF '$DATA(ASUF("DESC"))
SET ASUF("DESC")=1
+2 IF ASUF("DESC")>2
SET ASUF("DESC")=ASUF("DESC")+1
+3 IF ASUF("DESC")=2
WRITE ?33,ASUV("NSN")
SET ASUF("DESC")=3
+4 IF ASUF("DESC")=1
WRITE ?19,$EXTRACT(ASUMX("DESC"),31,60)
SET ASUF("DESC")=2
+5 QUIT
CALCT ;
+1 SET ASUN("E#")=""
FOR
SET ASUN("E#")=$ORDER(^XTMP("ASUMA",ASUX("AS"),ASUX("AG"),ASUN("E#")))
IF ASUN("E#")=""
QUIT
Begin DoDot:1
+2 SET ASUA(0)=^XTMP("ASUMA",ASUX("AS"),ASUX("AG"),ASUN("E#"))
+3 IF $PIECE(ASUA(0),U)="A"
Begin DoDot:2
+4 SET ASUA("LIA")=$GET(ASUA("LIA"))+1
SET ASUA("VLA")=$GET(ASUA("VLA"))+$PIECE(ASUA(0),U,2)
End DoDot:2
+5 IF '$TEST
Begin DoDot:2
+6 SET ASUA("LIN")=$GET(ASUA("LIN"))+1
SET ASUA("VLN")=$GET(ASUA("VLN"))+$PIECE(ASUA(0),U,2)
End DoDot:2
End DoDot:1
+7 QUIT
CMPT ;EP;COMPUTE CONTENTS
+1 KILL ^XTMP("ASUR","R11")
SET ^XTMP("ASUR","R11",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
SET ASUTX=0
+2 IF $GET(ASUN("TYP"))']""
DO ^ASUURANG
+3 SET ASUHDA=$GET(ASUN("B#"))-1
+4 FOR
SET ASUHDA=$ORDER(^ASUH(ASUHDA))
IF ASUHDA>$GET(ASUN("E#"))
QUIT
IF ASUHDA'?1N.N
QUIT
Begin DoDot:1
+5 IF ASUHDA=0
QUIT
+6 DO READ^ASU0TRRD(.ASUHDA,"H")
IF $GET(ASUT)']""
QUIT
IF $EXTRACT(ASUT("TRCD"))="4"
QUIT
IF $EXTRACT(ASUT("TRCD"))="0"
QUIT
IF ASUT="UNK"
QUIT
+7 SET ^XTMP("ASUR","R11",ASUT(ASUT,"PT","STA"),ASUL(9,"ACG"),ASUT(ASUT,"PT","IDX"),ASUHDA)=ASUHDA
End DoDot:1
+8 QUIT
