ASURD73P ; IHS/ITSC/LMH -RPT 73 OUTAGE/LOW INV/DUE OUT ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine formats and prints report 73, Outage - Low Inventory -
;Due Out Report.
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 73
D:'$D(IO) 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^ASURD73P",ZTDESC="SAMS RPT 73" 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 U^ASUUZIS D:'$D(ASUK("DT")) ^ASUUDATE
S Y=$P($G(^XTMP("ASUR","R73",0)),U,2) X ^DD("DD")
S ASUX("DT")=Y S:ASUX("DT")']"" ASUX("DT")=$G(ASUK("DT"))
I Y']"" D CMPT
S Y=$O(^XTMP("ASUR","R73",0)) I Y']"" W !,"NO DATA FOR REPORT #73",?27,ASUK("DT") G K
S ASUC("LN")=IOSL+1,(ASUC("QTY","D/I","TOT"),ASUC("B/O"),ASUMS("E#","STA"),ASUC("ACCTOT"),ASUC("GTOT"))=0
S (ASUV("D/I","PO#"),ASUV("QTY","D/I"))=""
S (ASUX("ACC"),ASUX("IDX"),ASUX("STA"))=0
;F ASUC("TR")=1:1 S ASUX("STA")=$O(^XTMP("ASUR","R73",ASUX("STA"))) Q:ASUX("STA")="" D Q:$D(DUOUT)
S ASUX("STA")=$G(ASUL(2,"STA","E#")) Q:ASUX("STA")']"" D
.Q:$E(ASUX("STA"),1,2)'=ASUL(1,"AR","AP")
.F S ASUX("ACC")=$O(^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"))) Q:ASUX("ACC")="" D Q:$D(DUOUT)
..F ASUU(12)=1:1 S ASUX("IDX")=$O(^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"),ASUX("IDX"))) Q:ASUX("IDX")="" D Q:$D(DUOUT)
...S ASUX(0,"IDX")=^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"),ASUX("IDX"),0)
...S ASUC("LN")=ASUC("LN")+2
...I ASUC("LN")>(IOSL-4) D HEADER Q:$D(DUOUT)
...W !!?1,$E($P(ASUX(0,"IDX"),U,3),1,5),".",$E($P(ASUX(0,"IDX"),U,3),6,6),?10,$P(ASUX(0,"IDX"),U,4)
...W ?46,$P(ASUX(0,"IDX"),U,6),?50,$J($P(ASUX(0,"IDX"),U,7),4),?60,$J($P(ASUX(0,"IDX"),U,8),4)
...S ASUX("TRL")=0
...F ASUU(13)=1:1 S ASUX("TRL")=$O(^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"),ASUX("IDX"),ASUX("TRL"))) Q:ASUX("TRL")="" D S ASUC("LI")=ASUU(13)
....S ASUX(0,"TRL")=^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"),ASUX("IDX"),ASUX("TRL"))
....D P2
...I $G(ASUC("LI"))=1 S ASUX(0,"TRL")="",ASUU(13)=2 D P2
...W ! I $P(ASUX(0,"IDX"),U,10)]"" D
....W ?8,":",$P(ASUX(0,"IDX"),U,11)
....W ?19,":",$P(ASUX(0,"IDX"),U,10)
....W ?118,":",$P(ASUX(0,"IDX"),U,12),":"
...D PRINTTOT Q:$D(DUOUT)
..K ASUV("B/O"),ASUV("D/I") S ASUC("ACCTOT")=ASUU(12)-1
..W !!,"TOTAL GL ACCOUNT 125.",ASUX("ACC")," LINE ITMES: ",$J(ASUC("ACCTOT"),8) S ASUC("GTOT")=ASUC("GTOT")+ASUC("ACCTOT")
..S ASUC("LN")=IOSL-4
.W !!,"TOTAL LINE ITEMS ALL GL ACCOUNTS: ",$J(ASUC("GTOT"),8),!
K ;
K ASUU(12),ASUU(13),ASUMX,ASUMS,ASUX,ASUC,ASUV
K ASUC("LI"),ASUC("ACCTOT"),ASUC("GTOT")
F X=3:1:22 K ASUL(X) ;Clear Table Lookup fields
K ASUMS,X,Y
D PAZ^ASUURHDR
I ASUK("PTRSEL")]"" W @(IOF) Q
D C^ASUUZIS
Q
S ASUC("PG")=$G(ASUC("PG"))+1,ASUC("LN")=0
D:ASUC("PG")>1 PAZ^ASUURHDR Q:$D(DUOUT) W @IOF
W !?5,"REPORT #73 STOCK OUTAGE -LOW INVENTORY -DUE OUT REPORT"
W ?70,ASUX("DT"),?85,"PAGE",?90,ASUC("PG") ;; CHG 03-21-95 CSC
D STA^ASULARST(ASUX("STA"))
W !?5,"STATION: ",ASUL(2,"STA","CD"),?23,ASUL(2,"STA","NM")
D ACC^ASULDIRF(ASUX("ACC"))
W !?5,"GL ACCOUNT 125.",ASUL(9,"ACC"),?23,ASUL(9,"ACC","NM")
W !!?60,"QTY DUE",?85,"DUE DUE DUE OUT EOQ"
W !?7,"INDEX",?61,"ON",?68,"IN PO",?85,"IN",?93,"OUT",?102,"TO TYPE"
W !?2,"NUMBER DESCRIPTION",?46,"UI",?50,"PAMIQ",?59,"HAND",?68,"QTY"
W ?77,"NO.",?85,"DATE QTY",?99,"LOC USER CODE",!
S ASUC("LN")=10
Q
P2 ;Print Totals and Lines
S ASUV("QTY","D/I")=$P(ASUX(0,"TRL"),U)
S ASUV("D/I","PO#")=$P(ASUX(0,"TRL"),U,2)
S ASUV("D/I","DT")=$P(ASUX(0,"TRL"),U,3)
S ASUV("B/O","QTY")=$P(ASUX(0,"TRL"),U,4)
S ASUV("B/O","LOC")=$E($P(ASUX(0,"TRL"),U,5),4,5)
I $P(ASUX(0,"TRL"),U,6)]"" D
.S ASUV("B/O","RQN")=$P(^ASUL(20,$P(ASUX(0,"TRL"),U,6),0),U,2)
.S ASUV("B/O","USR")=$P(^ASUL(19,ASUV("B/O","RQN"),1),U)
PRINTLIN ;EP; PRINT TRANS LINE
S ASUC("QTY","D/I","TOT")=ASUC("QTY","D/I","TOT")+ASUV("QTY","D/I")
S ASUC("B/O")=ASUC("B/O")+ASUV("B/O","QTY")
I ASUU(13)>1 D Q:$D(DUOUT)
.W ! S ASUC("LN")=ASUC("LN")+1
.I ASUC("LN")>(IOSL-2) D HEADER Q:$D(DUOUT)
W:ASUU(13)=2 ?10,$P(ASUX(0,"IDX"),U,5)
W ?67,$J(ASUV("QTY","D/I"),5)
W ?75,ASUV("D/I","PO#")
W:ASUV("D/I","DT")]"" ?84,$E(ASUV("D/I","DT"),4,5)_"-"_$E(ASUV("D/I","DT"),6,7)_"-"_$E(ASUV("D/I","DT"),2,3)
W:ASUV("B/O","QTY")]"" ?92,$J($FN(ASUV("B/O","QTY"),",",0),5),?100,ASUV("B/O","LOC"),?104,ASUV("B/O","USR")
W:ASUU(13)=1 ?111,$P(ASUX(0,"IDX"),U,9)
Q
PRINTTOT ;EP; PRINT TOTAL LINE
S ASUC("LN")=ASUC("LN")+2 I ASUC("LN")>(IOSL-6) D HEADER Q:$D(DUOUT)
W !?40,"TOTAL",?59,$J($P(ASUX(0,"IDX"),U,8),5)
W:ASUC("QTY","D/I","TOT")>0 ?67,$J(ASUC("QTY","D/I","TOT"),5)
W:ASUC("B/O")>0 ?92,$J(ASUC("B/O"),5)
S (ASUC("QTY","D/I","TOT"),ASUC("B/O"))=0
Q
CMPT ;EP ;SORT,DUEIN,BKORDER RTN;
K ^XTMP("ASUR","R73") S ^XTMP("ASUR","R73",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
S ASUMS("E#","STA")=$G(ASUL(2,"STA","E#")) Q:ASUMS("E#","STA")']""
S ASUMS("E#","IDX")=0 F S ASUMS("E#","IDX")=$O(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"))) Q:ASUMS("E#","IDX")'?1N.N D
.Q:$P(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),0),U)[999999
.S ASUV("IDX")=ASUMS("E#","IDX") D ^ASUMSTRD I ASUF("DLIDX") S ASUMS("E#","IDX")=ASUV("IDX") Q
.Q:ASUMS("EOQ","TP")="S"
.S ASUMX("E#","IDX")=ASUMS("E#","IDX") D READ^ASUMXDIO
.I ASUMS("QTY","O/H")<ASUMS("PMIQ")!(ASUMS("QTY","O/H")<1) D
..S (ASUV("D/I"),ASUV("B/O"))=0 S:ASUMS("QTY","O/H")="" ASUMS("QTY","O/H")=0
..F ASUV("DI#")=1:1:3 I ASUMS("D/I","QTY",ASUV("DI#"))>0 D
...S ASUV("D/I")=ASUV("D/I")+1,$P(ASUAD(ASUV("D/I")),U)=ASUMS("D/I","QTY",ASUV("DI#"))
...S $P(ASUAD(ASUV("D/I")),U,2)=ASUMS("D/I","PO#",ASUV("DI#")),$P(ASUAD(ASUV("D/I")),U,3)=ASUMS("D/I","DT",ASUV("DI#"))
..S (ASUMB("E#","REQ"),ASUV("B/O"))="0"
..F S ASUMB("E#","REQ")=$O(^ASUMB("C",ASUMX("E#","IDX"),ASUMB("E#","REQ"))) Q:ASUMB("E#","REQ")="" D
...S ASUV("B/O")=$G(ASUV("B/O"))+1,ASUMB(1)=^ASUMB(ASUMB("E#","REQ"),1,ASUMX("E#","IDX"),1)
...S ASUMB("USR")=ASUMB("E#","REQ"),ASUMB("QTYB/O")=$P(ASUMB(1),U,3),ASUMB("LOC")=$P(ASUMB(1),U,14)
...S ASUAB(ASUV("B/O"))=ASUMB("QTYB/O")_U_ASUMB("LOC")_U_ASUMB("USR")
..S ASUX(0,"IDX")=ASUMS("STA")_U_ASUMX("ACC")_U_ASUMX("IDX")_U_ASUMX("DESC",1)_U_ASUMX("DESC",2)_U
..S ASUX(0,"IDX")=ASUX(0,"IDX")_ASUMX("AR U/I")_U_ASUMS("PMIQ")_U_ASUMS("QTY","O/H")_U_ASUMS("EOQ","TP")_U
..S ASUX(0,"IDX")=ASUX(0,"IDX")_ASUMS("R73","REM")_U_ASUMS("R73","PER")_U_ASUMS("R73","DT")
..S ^XTMP("ASUR","R73",ASUMS("STA"),ASUMX("ACC"),"0"_ASUMX("IDX"),0)=ASUX(0,"IDX"),ASUX(0,"IDX")=""
..I ASUV("D/I")>ASUV("B/O") D
...S ASUX("TRL")=ASUV("D/I")
..E D
...S ASUX("TRL")=ASUV("B/O")
..I ASUX("TRL")=0 S ASUX("TRL")=1
..F ASUU(12)=1:1:ASUX("TRL") D
..I '$D(ASUAD(ASUU(12))) S ASUX(0,"IDX")="^^"
..E S ASUX(0,"IDX")=ASUAD(ASUU(12))
..I $D(ASUAB(ASUU(12))) S ASUX(0,"IDX")=ASUX(0,"IDX")_U_ASUAB(ASUU(12))
..S ^XTMP("ASUR","R73",ASUMS("STA"),ASUMX("ACC"),"0"_ASUMX("IDX"),ASUU(12))=ASUX(0,"IDX"),ASUX(0,"IDX")=""
.K ASUAB,ASUAD
E D
.;S ^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),3)=""
K ASUAB,ASUAD
K ASUMX,ASUMS,ASUV("D/I"),ASUV("B/O"),ASUU(12)
Q
I '$D(DUZ) W !!,"USER NOT DEFINED -USE KERNEL" Q
I '$D(U) D ^XBKVAR
S ASUMS("E#","STA")="",DIR(0)="S^",ASUV("R73PER")=$P(^VA(200,DUZ,0),U),X=DT,ASUV("ST")="",ASUU(10)="",ASUU(11)=""
D H^%DTC,YX^%DTC S ASUV("R73DTE")=Y
F ASUC("TR")=1:1 S ASUV("ST")=$O(^ASUMS("B",ASUV("ST"))) Q:ASUV("ST")="" D CHECKI
I ASUU(11)=1 S ASUMS("E#","STA")=$O(^ASUMS("B",ASUU(10),"")) G FINDIDX
G READSTA
CHECKI ;
S ASUMS("E#","STA")=$O(^ASUMS("B",ASUV("ST"),"")) Q:$P(^ASUMS(ASUMS("E#","STA"),1,0),U,4)=0
S ASUU(11)=ASUU(11)+1,DIR(0)=DIR(0)_ASUU(11)_":"_ASUV("ST")_";"
S ASUU(10)=ASUV("ST")
Q
READSTA ;
S DIR("A")="ENTER STATION FOR REMARKS " D ^DIR Q:$D(DUOUT) Q:$D(DTOUT) Q:X=""
S ASUMS("E#","STA")=$O(^ASUMS("B",Y(0),""))
FINDIDX ;
S DIC="^ASUMS(ASUMS(""E#"",""STA""),1,"
S DIC(0)="ANMQ",DIC("A")="ENTER INDEX NUMBER FOR REMARKS "
D ^DIC
G:$D(DUOUT) ASK G:$D(DTOUT) ASK G:'$D(Y) ASK G:Y<0 ASK
S DA=+Y,DIE="^ASUMS(ASUMS(""E#"",""STA""),1,"
S DR=".09;.091///^S X=ASUV(""R73PER"");.092///^S X=ASUV(""R73DTE"")"
D ^DIE
ASK ;
K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="ENTER ANOTHER REPORT 73 REMARK " D ^DIR
G:$D(DUOUT) DONE G:$D(DTOUT) DONE
I Y=1 G FINDIDX
DONE ;
K ASUMS("E#","STA"),ASUV("R73PER"),ASUV("ST"),ASUV("R73DTE"),ASUC("TR"),DIR,DIC,DIE,DR
Q
ASURD73P ; IHS/ITSC/LMH -RPT 73 OUTAGE/LOW INV/DUE OUT ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine formats and prints report 73, Outage - Low Inventory -
+3 ;Due Out Report.
EN ;EP;PRIMARY ENTRY POINT FOR REPORT 73
+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^ASURD73P"
SET ZTDESC="SAMS RPT 73"
DO O^ASUUZIS
+5 IF POP
SET IOP=$IO
DO ^%ZIS
QUIT
+6 IF ASUK(ASUK("PTR"),"Q")
QUIT
PSER ;EP;FOR TASKMAN QUEUE OF PRINT
+1 DO U^ASUUZIS
IF '$DATA(ASUK("DT"))
DO ^ASUUDATE
+2 SET Y=$PIECE($GET(^XTMP("ASUR","R73",0)),U,2)
XECUTE ^DD("DD")
+3 SET ASUX("DT")=Y
IF ASUX("DT")']""
SET ASUX("DT")=$GET(ASUK("DT"))
+4 IF Y']""
DO CMPT
+5 SET Y=$ORDER(^XTMP("ASUR","R73",0))
IF Y']""
WRITE !,"NO DATA FOR REPORT #73",?27,ASUK("DT")
GOTO K
+6 SET ASUC("LN")=IOSL+1
SET (ASUC("QTY","D/I","TOT"),ASUC("B/O"),ASUMS("E#","STA"),ASUC("ACCTOT"),ASUC("GTOT"))=0
+7 SET (ASUV("D/I","PO#"),ASUV("QTY","D/I"))=""
+8 SET (ASUX("ACC"),ASUX("IDX"),ASUX("STA"))=0
+9 ;F ASUC("TR")=1:1 S ASUX("STA")=$O(^XTMP("ASUR","R73",ASUX("STA"))) Q:ASUX("STA")="" D Q:$D(DUOUT)
+10 SET ASUX("STA")=$GET(ASUL(2,"STA","E#"))
IF ASUX("STA")']""
QUIT
Begin DoDot:1
+11 IF $EXTRACT(ASUX("STA"),1,2)'=ASUL(1,"AR","AP")
QUIT
+12 FOR
SET ASUX("ACC")=$ORDER(^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC")))
IF ASUX("ACC")=""
QUIT
Begin DoDot:2
+13 FOR ASUU(12)=1:1
SET ASUX("IDX")=$ORDER(^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"),ASUX("IDX")))
IF ASUX("IDX")=""
QUIT
Begin DoDot:3
+14 SET ASUX(0,"IDX")=^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"),ASUX("IDX"),0)
+15 SET ASUC("LN")=ASUC("LN")+2
+16 IF ASUC("LN")>(IOSL-4)
DO HEADER
IF $DATA(DUOUT)
QUIT
+17 WRITE !!?1,$EXTRACT($PIECE(ASUX(0,"IDX"),U,3),1,5),".",$EXTRACT($PIECE(ASUX(0,"IDX"),U,3),6,6),?10,$PIECE(ASUX(0,"IDX"),U,4)
+18 WRITE ?46,$PIECE(ASUX(0,"IDX"),U,6),?50,$JUSTIFY($PIECE(ASUX(0,"IDX"),U,7),4),?60,$JUSTIFY($PIECE(ASUX(0,"IDX"),U,8),4)
+19 SET ASUX("TRL")=0
+20 FOR ASUU(13)=1:1
SET ASUX("TRL")=$ORDER(^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"),ASUX("IDX"),ASUX("TRL")))
IF ASUX("TRL")=""
QUIT
Begin DoDot:4
+21 SET ASUX(0,"TRL")=^XTMP("ASUR","R73",ASUX("STA"),ASUX("ACC"),ASUX("IDX"),ASUX("TRL"))
+22 DO P2
End DoDot:4
SET ASUC("LI")=ASUU(13)
+23 IF $GET(ASUC("LI"))=1
SET ASUX(0,"TRL")=""
SET ASUU(13)=2
DO P2
+24 WRITE !
IF $PIECE(ASUX(0,"IDX"),U,10)]""
Begin DoDot:4
+25 WRITE ?8,":",$PIECE(ASUX(0,"IDX"),U,11)
+26 WRITE ?19,":",$PIECE(ASUX(0,"IDX"),U,10)
+27 WRITE ?118,":",$PIECE(ASUX(0,"IDX"),U,12),":"
End DoDot:4
+28 DO PRINTTOT
IF $DATA(DUOUT)
QUIT
End DoDot:3
IF $DATA(DUOUT)
QUIT
+29 KILL ASUV("B/O"),ASUV("D/I")
SET ASUC("ACCTOT")=ASUU(12)-1
+30 WRITE !!,"TOTAL GL ACCOUNT 125.",ASUX("ACC")," LINE ITMES: ",$JUSTIFY(ASUC("ACCTOT"),8)
SET ASUC("GTOT")=ASUC("GTOT")+ASUC("ACCTOT")
+31 SET ASUC("LN")=IOSL-4
End DoDot:2
IF $DATA(DUOUT)
QUIT
+32 WRITE !!,"TOTAL LINE ITEMS ALL GL ACCOUNTS: ",$JUSTIFY(ASUC("GTOT"),8),!
End DoDot:1
K ;
+1 KILL ASUU(12),ASUU(13),ASUMX,ASUMS,ASUX,ASUC,ASUV
+2 KILL ASUC("LI"),ASUC("ACCTOT"),ASUC("GTOT")
+3 ;Clear Table Lookup fields
FOR X=3:1:22
KILL ASUL(X)
+4 KILL ASUMS,X,Y
+5 DO PAZ^ASUURHDR
+6 IF ASUK("PTRSEL")]""
WRITE @(IOF)
QUIT
+7 DO C^ASUUZIS
+8 QUIT
+1 SET ASUC("PG")=$GET(ASUC("PG"))+1
SET ASUC("LN")=0
+2 IF ASUC("PG")>1
DO PAZ^ASUURHDR
IF $DATA(DUOUT)
QUIT
WRITE @IOF
+3 WRITE !?5,"REPORT #73 STOCK OUTAGE -LOW INVENTORY -DUE OUT REPORT"
+4 ;; CHG 03-21-95 CSC
WRITE ?70,ASUX("DT"),?85,"PAGE",?90,ASUC("PG")
+5 DO STA^ASULARST(ASUX("STA"))
+6 WRITE !?5,"STATION: ",ASUL(2,"STA","CD"),?23,ASUL(2,"STA","NM")
+7 DO ACC^ASULDIRF(ASUX("ACC"))
+8 WRITE !?5,"GL ACCOUNT 125.",ASUL(9,"ACC"),?23,ASUL(9,"ACC","NM")
+9 WRITE !!?60,"QTY DUE",?85,"DUE DUE DUE OUT EOQ"
+10 WRITE !?7,"INDEX",?61,"ON",?68,"IN PO",?85,"IN",?93,"OUT",?102,"TO TYPE"
+11 WRITE !?2,"NUMBER DESCRIPTION",?46,"UI",?50,"PAMIQ",?59,"HAND",?68,"QTY"
+12 WRITE ?77,"NO.",?85,"DATE QTY",?99,"LOC USER CODE",!
+13 SET ASUC("LN")=10
+14 QUIT
P2 ;Print Totals and Lines
+1 SET ASUV("QTY","D/I")=$PIECE(ASUX(0,"TRL"),U)
+2 SET ASUV("D/I","PO#")=$PIECE(ASUX(0,"TRL"),U,2)
+3 SET ASUV("D/I","DT")=$PIECE(ASUX(0,"TRL"),U,3)
+4 SET ASUV("B/O","QTY")=$PIECE(ASUX(0,"TRL"),U,4)
+5 SET ASUV("B/O","LOC")=$EXTRACT($PIECE(ASUX(0,"TRL"),U,5),4,5)
+6 IF $PIECE(ASUX(0,"TRL"),U,6)]""
Begin DoDot:1
+7 SET ASUV("B/O","RQN")=$PIECE(^ASUL(20,$PIECE(ASUX(0,"TRL"),U,6),0),U,2)
+8 SET ASUV("B/O","USR")=$PIECE(^ASUL(19,ASUV("B/O","RQN"),1),U)
End DoDot:1
PRINTLIN ;EP; PRINT TRANS LINE
+1 SET ASUC("QTY","D/I","TOT")=ASUC("QTY","D/I","TOT")+ASUV("QTY","D/I")
+2 SET ASUC("B/O")=ASUC("B/O")+ASUV("B/O","QTY")
+3 IF ASUU(13)>1
Begin DoDot:1
+4 WRITE !
SET ASUC("LN")=ASUC("LN")+1
+5 IF ASUC("LN")>(IOSL-2)
DO HEADER
IF $DATA(DUOUT)
QUIT
End DoDot:1
IF $DATA(DUOUT)
QUIT
+6 IF ASUU(13)=2
WRITE ?10,$PIECE(ASUX(0,"IDX"),U,5)
+7 WRITE ?67,$JUSTIFY(ASUV("QTY","D/I"),5)
+8 WRITE ?75,ASUV("D/I","PO#")
+9 IF ASUV("D/I","DT")]""
WRITE ?84,$EXTRACT(ASUV("D/I","DT"),4,5)_"-"_$EXTRACT(ASUV("D/I","DT"),6,7)_"-"_$EXTRACT(ASUV("D/I","DT"),2,3)
+10 IF ASUV("B/O","QTY")]""
WRITE ?92,$JUSTIFY($FNUMBER(ASUV("B/O","QTY"),",",0),5),?100,ASUV("B/O","LOC"),?104,ASUV("B/O","USR")
+11 IF ASUU(13)=1
WRITE ?111,$PIECE(ASUX(0,"IDX"),U,9)
+12 QUIT
PRINTTOT ;EP; PRINT TOTAL LINE
+1 SET ASUC("LN")=ASUC("LN")+2
IF ASUC("LN")>(IOSL-6)
DO HEADER
IF $DATA(DUOUT)
QUIT
+2 WRITE !?40,"TOTAL",?59,$JUSTIFY($PIECE(ASUX(0,"IDX"),U,8),5)
+3 IF ASUC("QTY","D/I","TOT")>0
WRITE ?67,$JUSTIFY(ASUC("QTY","D/I","TOT"),5)
+4 IF ASUC("B/O")>0
WRITE ?92,$JUSTIFY(ASUC("B/O"),5)
+5 SET (ASUC("QTY","D/I","TOT"),ASUC("B/O"))=0
+6 QUIT
CMPT ;EP ;SORT,DUEIN,BKORDER RTN;
+1 KILL ^XTMP("ASUR","R73")
SET ^XTMP("ASUR","R73",0)=ASUK("DT","FM")+10000_U_ASUK("DT","FM")
+2 SET ASUMS("E#","STA")=$GET(ASUL(2,"STA","E#"))
IF ASUMS("E#","STA")']""
QUIT
+3 SET ASUMS("E#","IDX")=0
FOR
SET ASUMS("E#","IDX")=$ORDER(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX")))
IF ASUMS("E#","IDX")'?1N.N
QUIT
Begin DoDot:1
+4 IF $PIECE(^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),0),U)[999999
QUIT
+5 SET ASUV("IDX")=ASUMS("E#","IDX")
DO ^ASUMSTRD
IF ASUF("DLIDX")
SET ASUMS("E#","IDX")=ASUV("IDX")
QUIT
+6 IF ASUMS("EOQ","TP")="S"
QUIT
+7 SET ASUMX("E#","IDX")=ASUMS("E#","IDX")
DO READ^ASUMXDIO
+8 IF ASUMS("QTY","O/H")<ASUMS("PMIQ")!(ASUMS("QTY","O/H")<1)
Begin DoDot:2
+9 SET (ASUV("D/I"),ASUV("B/O"))=0
IF ASUMS("QTY","O/H")=""
SET ASUMS("QTY","O/H")=0
+10 FOR ASUV("DI#")=1:1:3
IF ASUMS("D/I","QTY",ASUV("DI#"))>0
Begin DoDot:3
+11 SET ASUV("D/I")=ASUV("D/I")+1
SET $PIECE(ASUAD(ASUV("D/I")),U)=ASUMS("D/I","QTY",ASUV("DI#"))
+12 SET $PIECE(ASUAD(ASUV("D/I")),U,2)=ASUMS("D/I","PO#",ASUV("DI#"))
SET $PIECE(ASUAD(ASUV("D/I")),U,3)=ASUMS("D/I","DT",ASUV("DI#"))
End DoDot:3
+13 SET (ASUMB("E#","REQ"),ASUV("B/O"))="0"
+14 FOR
SET ASUMB("E#","REQ")=$ORDER(^ASUMB("C",ASUMX("E#","IDX"),ASUMB("E#","REQ")))
IF ASUMB("E#","REQ")=""
QUIT
Begin DoDot:3
+15 SET ASUV("B/O")=$GET(ASUV("B/O"))+1
SET ASUMB(1)=^ASUMB(ASUMB("E#","REQ"),1,ASUMX("E#","IDX"),1)
+16 SET ASUMB("USR")=ASUMB("E#","REQ")
SET ASUMB("QTYB/O")=$PIECE(ASUMB(1),U,3)
SET ASUMB("LOC")=$PIECE(ASUMB(1),U,14)
+17 SET ASUAB(ASUV("B/O"))=ASUMB("QTYB/O")_U_ASUMB("LOC")_U_ASUMB("USR")
End DoDot:3
+18 SET ASUX(0,"IDX")=ASUMS("STA")_U_ASUMX("ACC")_U_ASUMX("IDX")_U_ASUMX("DESC",1)_U_ASUMX("DESC",2)_U
+19 SET ASUX(0,"IDX")=ASUX(0,"IDX")_ASUMX("AR U/I")_U_ASUMS("PMIQ")_U_ASUMS("QTY","O/H")_U_ASUMS("EOQ","TP")_U
+20 SET ASUX(0,"IDX")=ASUX(0,"IDX")_ASUMS("R73","REM")_U_ASUMS("R73","PER")_U_ASUMS("R73","DT")
+21 SET ^XTMP("ASUR","R73",ASUMS("STA"),ASUMX("ACC"),"0"_ASUMX("IDX"),0)=ASUX(0,"IDX")
SET ASUX(0,"IDX")=""
+22 IF ASUV("D/I")>ASUV("B/O")
Begin DoDot:3
+23 SET ASUX("TRL")=ASUV("D/I")
End DoDot:3
+24 IF '$TEST
Begin DoDot:3
+25 SET ASUX("TRL")=ASUV("B/O")
End DoDot:3
+26 IF ASUX("TRL")=0
SET ASUX("TRL")=1
+27 FOR ASUU(12)=1:1:ASUX("TRL")
Begin DoDot:3
End DoDot:3
+28 IF '$DATA(ASUAD(ASUU(12)))
SET ASUX(0,"IDX")="^^"
+29 IF '$TEST
SET ASUX(0,"IDX")=ASUAD(ASUU(12))
+30 IF $DATA(ASUAB(ASUU(12)))
SET ASUX(0,"IDX")=ASUX(0,"IDX")_U_ASUAB(ASUU(12))
+31 SET ^XTMP("ASUR","R73",ASUMS("STA"),ASUMX("ACC"),"0"_ASUMX("IDX"),ASUU(12))=ASUX(0,"IDX")
SET ASUX(0,"IDX")=""
End DoDot:2
+32 KILL ASUAB,ASUAD
End DoDot:1
+33 IF '$TEST
Begin DoDot:1
+34 ;S ^ASUMS(ASUMS("E#","STA"),1,ASUMS("E#","IDX"),3)=""
End DoDot:1
+35 KILL ASUAB,ASUAD
+36 KILL ASUMX,ASUMS,ASUV("D/I"),ASUV("B/O"),ASUU(12)
+37 QUIT
+1 IF '$DATA(DUZ)
WRITE !!,"USER NOT DEFINED -USE KERNEL"
QUIT
+2 IF '$DATA(U)
DO ^XBKVAR
+3 SET ASUMS("E#","STA")=""
SET DIR(0)="S^"
SET ASUV("R73PER")=$PIECE(^VA(200,DUZ,0),U)
SET X=DT
SET ASUV("ST")=""
SET ASUU(10)=""
SET ASUU(11)=""
+4 DO H^%DTC
DO YX^%DTC
SET ASUV("R73DTE")=Y
+5 FOR ASUC("TR")=1:1
SET ASUV("ST")=$ORDER(^ASUMS("B",ASUV("ST")))
IF ASUV("ST")=""
QUIT
DO CHECKI
+6 IF ASUU(11)=1
SET ASUMS("E#","STA")=$ORDER(^ASUMS("B",ASUU(10),""))
GOTO FINDIDX
+7 GOTO READSTA
CHECKI ;
+1 SET ASUMS("E#","STA")=$ORDER(^ASUMS("B",ASUV("ST"),""))
IF $PIECE(^ASUMS(ASUMS("E#","STA"),1,0),U,4)=0
QUIT
+2 SET ASUU(11)=ASUU(11)+1
SET DIR(0)=DIR(0)_ASUU(11)_":"_ASUV("ST")_";"
+3 SET ASUU(10)=ASUV("ST")
+4 QUIT
READSTA ;
+1 SET DIR("A")="ENTER STATION FOR REMARKS "
DO ^DIR
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
IF X=""
QUIT
+2 SET ASUMS("E#","STA")=$ORDER(^ASUMS("B",Y(0),""))
FINDIDX ;
+1 SET DIC="^ASUMS(ASUMS(""E#"",""STA""),1,"
+2 SET DIC(0)="ANMQ"
SET DIC("A")="ENTER INDEX NUMBER FOR REMARKS "
+3 DO ^DIC
+4 IF $DATA(DUOUT)
GOTO ASK
IF $DATA(DTOUT)
GOTO ASK
IF '$DATA(Y)
GOTO ASK
IF Y<0
GOTO ASK
+5 SET DA=+Y
SET DIE="^ASUMS(ASUMS(""E#"",""STA""),1,"
+6 SET DR=".09;.091///^S X=ASUV(""R73PER"");.092///^S X=ASUV(""R73DTE"")"
+7 DO ^DIE
ASK ;
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="ENTER ANOTHER REPORT 73 REMARK "
DO ^DIR
+2 IF $DATA(DUOUT)
GOTO DONE
IF $DATA(DTOUT)
GOTO DONE
+3 IF Y=1
GOTO FINDIDX
DONE ;
+1 KILL ASUMS("E#","STA"),ASUV("R73PER"),ASUV("ST"),ASUV("R73DTE"),ASUC("TR"),DIR,DIC,DIE,DR
+2 QUIT
