ASUJOLIB ; IHS/ITSC/LMH -SCREENMAN FOR ONLINE ISSUE ENTRY ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine will be used for the online issue book transaction
;entry
D:'$D(ASUK("DT")) DATE^ASUUDATE
D:'$D(ASUL(1)) ARE^ASULARST($P(^ASUSITE(1,0),U))
S ASUJ("E#","STA")=$G(ASUL(1,"AR","STA1"))
K DIR S DIR(0)="PAO^9002039.2:AENQ",DIR("A")="ENTER YOUR REQUISITIONER CODE: "
D ^DIR Q:$D(DUOUT) Q:$D(DIROUT) Q:$D(DTOUT)
Q:$G(Y)']""
S ASUJ=+Y
D CALCVOU
K DIR S DIR(0)="SA^Y:Yes;N:No",DIR("A")="DO YOU WANT TO LOOK AT ALL ENTRIES IN YOUR ISSUE BOOK? ",DIR("B")="Y"
D ^DIR Q:$D(DUOUT) Q:$D(DIROUT) Q:$D(DTOUT)
Q:$G(Y)']""
G:Y["Y" LOOPALL
ANOTHER ;
K DIC S DIC(0)="AENQ",DIC=9002036.8,D="I",DIC("A")="ENTER THE INDEX NUMBER OF THE ITEM YOU WANT TO ORDER: ",DIC("S")="I $P(^(0),U,15)=ASUJ"
D IX^DIC Q:$D(DUOUT) Q:$D(DIROUT) Q:$D(DTOUT) Q:$G(Y)']""
S (ASUJ("E#","RQI"),DA)=+Y,ASUJ("E#","IDX")=$P(^ASUT(8,DA,0),U,5)
S DDSFILE=9002036.8,DR="[ASUJIB ISSUE]",DDSPARM="CES" D ^DDS
K DIR S DIR(0)="SA^Y:Yes;N:No",DIR("A")="ORDER ANOTHER ITEM? ",DIR("B")="Y"
D ^DIR G:$D(DIRUT) EXIT G:X="N" EXIT
G ANOTHER
LOOPALL ;
S DA=ASUJ_"000000",X=$O(^ASUT(8,DA)) I $E(X,1,9)'=ASUJ W !!,"No entries in Issue Book for this Requsitioner" Q
F S DA=$O(^ASUT(8,DA)) Q:$E(DA,1,9)'=ASUJ D G:$G(ASUJ("ANS"))="N" EXIT
.S ASUJ("E#","RQI")=DA,ASUJ("E#","IDX")=ASUL(1,"AR","AP")_$E(DA,$L(DA)-5,$L(DA))
.S DDSFILE=9002036.8,DR="[ASUJIB ISSUE]",DDSPARM="CES"
.D ^DDS
.K DIR S DIR(0)="SA^Y:Yes;N:No",DIR("A")="CONTINUE WITH NEXT ITEM? ",DIR("B")="Y"
.D ^DIR
.I $D(DIRUT) S ASUJ("ANS")="N"
.S ASUJ("ANS")=$E(X)
EXIT ;
K DIR,DIC,ASUJ,DA,DDSFILE,DR,DDSPARM
Q
CALCVOU ;
S ASUJ("VOU")=$P($G(^ASUSITE(1,1)),U,8)
I ASUJ("VOU")=4999 W "Sorry, no Voucher Numbers available for Online Issues" H 5 Q
S $P(^ASUSITE(1,1),U,8)=ASUJ("VOU")+1,ASUP("LSMO")=$P(^ASUSITE(1,0),U,14)
S ASUJ("VOU")=$E(ASUP("LSMO"),3,4)_$E(ASUP("LSMO"),1,2)+1_$P($FN((ASUJ("VOU")*.0001),"",4),".",2)
Q
UCST ;EP ;CALCULATE UNIT COST FOR FORM
S ASUJ("OH","VAL")=$P(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,16)
S ASUJ("OH","QTY")=$P(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,17)
I ASUJ("OH","VAL")>0,ASUJ("OH","QTY")>0 D
.S (ASUJ("UCST"),Y)=$FN((ASUJ("OH","VAL")/ASUJ("OH","QTY")),"",2)
E D
.S ASUJMSG(1)="This item is not in stock. If you order it, it will be BackOrdered"
.S ASUJMSG(2)="The Unit Cost displayed is the Last Purchase Price"
.S ASUJMSG(3)="$$EOP" W *7 D HLP^ASUJHELP(.ASUJMSG) ;DFM P1 9/1/98
.S (ASUJ("UCST"),Y)=$FN($P(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,15),"",2) ;Last Purchase Price
Q
VAL ;EP ;CALCULATE ORDER VALUE FOR FORM
I '$D(ASUJ("UCST")) D UCST
S ASUJ("QTY")=$$GET^DDSVALF("QTY")
S ASUJ("VAL")=$FN((ASUJ("QTY")*ASUJ("UCST")),",",2)
D PUT^DDSVALF("VAL","","",ASUJ("VAL"))
Q
RVAL ;EP ;CALCULATE RECOMMED VALUE FOR FORM
I '$D(ASUJ("UCST")) D UCST
S ASUJ("RQTY")=$P(^ASUT(8,ASUJ("E#","RQI"),3),U,6)
S (ASUJ("RVAL"),Y)=$FN((ASUJ("RQTY")*ASUJ("UCST")),",",2)
Q
VOU ;EP ;CALCULATE VOUCHER NUMBER FOR FORM
D:'$D(ASUJ("VOU")) CALCVOU
S Y=ASUJ("VOU")
S $P(^ASUT(8,ASUJ("E#","RQI"),0),U,8)=ASUJ("VOU")
Q
FILE ;EP ;PLACE ORDER INTO ASUTRN ISSUE FILE
S ASUT="IBK" D DAYTIM^ASUUDATE
S ASUHDA=$O(^ASUT(3,9999999999),-1)+1
M ^ASUT(3,ASUHDA)=^ASUT(8,ASUJ("E#","RQI"))
S $P(^ASUT(3,ASUHDA,0),U)=ASUT(ASUT,"TRKY")
S $P(^ASUT(3,ASUHDA,3),U,6)="" ;BLANK OUT RECOMMEND QTY
S $P(^ASUT(8,ASUHDA,0),U,6)="" ;RESET ORDER QTY
S $P(^ASUT(8,ASUHDA,1),U,8)="" ;RESET VOUCHER NUMBER
S DA=ASUHDA,DIK="^ASUT(3," D IX^DIK ;Re xref new record
Q
CRMSTR ;EP ; -CREATE ISSUE BOOK TRANS
D:$G(ASUK("DT"))']"" DATE^ASUUDATE
W !!,"CREATE ONLINE ISSUE BOOK TRANS MASTER PROGRAM",!!
I $G(ASUF("STA"))'["S" D
.S ASUMK("E#","STA")=0
.F S ASUMK("E#","STA")=$O(^ASUMK(ASUMK("E#","STA"))) Q:ASUMK("E#","STA")'?1N.N D REQS
E D
.K DIR
.S DIR(0)="PAO^ASUMK(",DIR("A")="ENTER STATION FOR ISSUE BOOK : " D ^DIR
.Q:Y']""
.Q:Y<0
.S ASUMK("E#","STA")=+Y
.D REQS
K ASUC,ASUMK,ASUMS,ASUMX,ASUV,ASUT
Q
REQS ;
S (ASUL(2,"STA","E#"),ASUMS("E#","STA"))=ASUMK("E#","STA")
D STA^ASULARST(ASUL(2,"STA","E#"))
S ASUMK("E#","REQ")=0
F S ASUMK("E#","REQ")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"))) Q:ASUMK("E#","REQ")'?1N.N D
.S DA=ASUMK("E#","REQ")_000000,ASUHDA=DA+999999,DIK="ASUT(8,"
.F S DA=$O(^ASUT(8,DA)) Q:DA'?1N.N Q:DA>ASUHDA D ^DIK
.F X=19,20,22 K ASUL(X)
.D REQ^ASULDIRR(ASUMK("E#","REQ"))
.W !?10,"PROCESSING REQUSITIONER: ",ASUL(20,"REQ","NM")
.S ASUMK("E#","IDX")=0
.F S ASUMK("E#","IDX")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"))) Q:ASUMK("E#","IDX")'?1N.N Q:$E(ASUMK("E#","IDX"),3,9)="999999" D
..S ASUMS("E#","IDX")=ASUMK("E#","IDX")
..D ^ASUMSTRD,READ^ASUMKBIO
..S ASUMX("E#","IDX")=ASUMK("E#","IDX") D READ^ASUMXDIO
..I $G(Y)<0 W !?15,"NO ENTRY IN INDEX MASTER" Q
..W !?10,"PROCESSING INDEX: ",ASUMX("IDX")
..S ASUMS("E#","IDX")=ASUMX("E#","IDX")
..D ^ASUMSTRD
..I $G(Y)<0 W !?20,"NO INDEX ON STATION MASTER" Q
..S ASUT20=$G(^ASUL(20,ASUL(20,"REQ","E#"),2,1,0))
..I ASUT20']"" W !?30,"NO PRIMAR CAN AVAILABLE" Q
..S ASUL(20,"CAN")=$P(ASUT20,U)
..S ASUL(17,"SSA")=$P(ASUT20,U,2) D SSA^ASULDIRR(ASUL(17,"SSA"))
..S ASUHDA=ASUL(20,"REQ","E#")_ASUMX("IDX")
..Q:'$D(ASUHDA)
..S (ASUT(0),ASUT(1),ASUT(3))="",ASUT="OIB"
..S $P(ASUT(0),U)=ASUHDA
..S $P(ASUT(0),U,2)=ASUL(1,"AR","E#")
..S $P(ASUT(0),U,3)=ASUL(2,"STA","E#")
..S $P(ASUT(0),U,4)=ASUMX("ACC")
..S $P(ASUT(0),U,5)=ASUMX("E#","IDX")
..S $P(ASUT(0),U,6)=DUZ(2)
..S $P(ASUT(0),U,10)="Y" ;Status
..S $P(ASUT(0),U,11)=ASUL(17,"SSA","E#")
..S $P(ASUT(0),U,13)=ASUL(18,"SST","E#")
..S $P(ASUT(0),U,14)=ASUL(19,"USR","E#")
..S $P(ASUT(0),U,15)=ASUL(20,"REQ","E#")
..S $P(ASUT(0),U,16)=ASUMS("EOQ","TB")
..S $P(ASUT(1),U)=32
..S $P(ASUT(1),U,2)=ASUL(1,"AR","AP")
..S $P(ASUT(1),U,3)=ASUL(2,"STA","CD")
..S $P(ASUT(1),U,4)=ASUMX("ACC")
..S $P(ASUT(1),U,5)=ASUMX("IDX")
..S $P(ASUT(1),U,6)="" ;QTY REQ
..S $P(ASUT(1),U,7)="" ;VAL
..S $P(ASUT(1),U,8)="" ;VOU
..S $P(ASUT(1),U,10)="" ;DT REQ
..S $P(ASUT(1),U,11)=ASUL(17,"SSA")
..S $P(ASUT(1),U,13)=ASUL(18,"SST")
..S $P(ASUT(1),U,14)=ASUL(19,"USR")
..S $P(ASUT(1),U,15)=ASUL(20,"CAN")
..S $P(ASUT(1),U,16)=ASUMS("EOQ","TP")
..S $P(ASUT(1),U,18)="" ;F-P-N
..S $P(ASUT(3),U)="" ;POST
..S $P(ASUT(3),U,2)=3 ;ISSUE TYPE (REGULAR)
..S $P(ASUT(3),U,3)="" ;REQ TYP
..S $P(ASUT(3),U,4)="" ;REQ #
..S $P(ASUT(3),U,5)="" ;C/G
..S $P(ASUT(3),U,6)=ASUMK("ULQTY")
..I $D(^ASUT(3,ASUHDA,0)) D
...S DA=ASUHDA,DIK="^ASUT(8," D ^DIK ;Delete old entry and xrefs
..S ^ASUT(8,ASUHDA,0)=ASUT(0)
..S ^ASUT(8,ASUHDA,1)=ASUT(1)
..S ^ASUT(8,ASUHDA,3)=ASUT(3)
..S $P(^ASUT(8,0),U,4)=$P(^ASUT(8,0),U,4)+1,$P(^ASUT(8,0),U,3)=ASUHDA
..S DA=ASUHDA,DIK="^ASUT(8," D IX^DIK ;Re xref new record
.K ASUMK("E#","IDX")
K ASUT20
Q
TRANS ;EP ;SCREENMAN FOR ONLINE ISSUE TRANSACTION ENTRY
W !!,"NOT CURRENTLY AVAILABLE"
Q
ASUJOLIB ; IHS/ITSC/LMH -SCREENMAN FOR ONLINE ISSUE ENTRY ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine will be used for the online issue book transaction
+3 ;entry
+4 IF '$DATA(ASUK("DT"))
DO DATE^ASUUDATE
+5 IF '$DATA(ASUL(1))
DO ARE^ASULARST($PIECE(^ASUSITE(1,0),U))
+6 SET ASUJ("E#","STA")=$GET(ASUL(1,"AR","STA1"))
+7 KILL DIR
SET DIR(0)="PAO^9002039.2:AENQ"
SET DIR("A")="ENTER YOUR REQUISITIONER CODE: "
+8 DO ^DIR
IF $DATA(DUOUT)
QUIT
IF $DATA(DIROUT)
QUIT
IF $DATA(DTOUT)
QUIT
+9 IF $GET(Y)']""
QUIT
+10 SET ASUJ=+Y
+11 DO CALCVOU
+12 KILL DIR
SET DIR(0)="SA^Y:Yes;N:No"
SET DIR("A")="DO YOU WANT TO LOOK AT ALL ENTRIES IN YOUR ISSUE BOOK? "
SET DIR("B")="Y"
+13 DO ^DIR
IF $DATA(DUOUT)
QUIT
IF $DATA(DIROUT)
QUIT
IF $DATA(DTOUT)
QUIT
+14 IF $GET(Y)']""
QUIT
+15 IF Y["Y"
GOTO LOOPALL
ANOTHER ;
+1 KILL DIC
SET DIC(0)="AENQ"
SET DIC=9002036.8
SET D="I"
SET DIC("A")="ENTER THE INDEX NUMBER OF THE ITEM YOU WANT TO ORDER: "
SET DIC("S")="I $P(^(0),U,15)=ASUJ"
+2 DO IX^DIC
IF $DATA(DUOUT)
QUIT
IF $DATA(DIROUT)
QUIT
IF $DATA(DTOUT)
QUIT
IF $GET(Y)']""
QUIT
+3 SET (ASUJ("E#","RQI"),DA)=+Y
SET ASUJ("E#","IDX")=$PIECE(^ASUT(8,DA,0),U,5)
+4 SET DDSFILE=9002036.8
SET DR="[ASUJIB ISSUE]"
SET DDSPARM="CES"
DO ^DDS
+5 KILL DIR
SET DIR(0)="SA^Y:Yes;N:No"
SET DIR("A")="ORDER ANOTHER ITEM? "
SET DIR("B")="Y"
+6 DO ^DIR
IF $DATA(DIRUT)
GOTO EXIT
IF X="N"
GOTO EXIT
+7 GOTO ANOTHER
LOOPALL ;
+1 SET DA=ASUJ_"000000"
SET X=$ORDER(^ASUT(8,DA))
IF $EXTRACT(X,1,9)'=ASUJ
WRITE !!,"No entries in Issue Book for this Requsitioner"
QUIT
+2 FOR
SET DA=$ORDER(^ASUT(8,DA))
IF $EXTRACT(DA,1,9)'=ASUJ
QUIT
Begin DoDot:1
+3 SET ASUJ("E#","RQI")=DA
SET ASUJ("E#","IDX")=ASUL(1,"AR","AP")_$EXTRACT(DA,$LENGTH(DA)-5,$LENGTH(DA))
+4 SET DDSFILE=9002036.8
SET DR="[ASUJIB ISSUE]"
SET DDSPARM="CES"
+5 DO ^DDS
+6 KILL DIR
SET DIR(0)="SA^Y:Yes;N:No"
SET DIR("A")="CONTINUE WITH NEXT ITEM? "
SET DIR("B")="Y"
+7 DO ^DIR
+8 IF $DATA(DIRUT)
SET ASUJ("ANS")="N"
+9 SET ASUJ("ANS")=$EXTRACT(X)
End DoDot:1
IF $GET(ASUJ("ANS"))="N"
GOTO EXIT
EXIT ;
+1 KILL DIR,DIC,ASUJ,DA,DDSFILE,DR,DDSPARM
+2 QUIT
CALCVOU ;
+1 SET ASUJ("VOU")=$PIECE($GET(^ASUSITE(1,1)),U,8)
+2 IF ASUJ("VOU")=4999
WRITE "Sorry, no Voucher Numbers available for Online Issues"
HANG 5
QUIT
+3 SET $PIECE(^ASUSITE(1,1),U,8)=ASUJ("VOU")+1
SET ASUP("LSMO")=$PIECE(^ASUSITE(1,0),U,14)
+4 SET ASUJ("VOU")=$EXTRACT(ASUP("LSMO"),3,4)_$EXTRACT(ASUP("LSMO"),1,2)+1_$PIECE($FNUMBER((ASUJ("VOU")*.0001),"",4),".",2)
+5 QUIT
UCST ;EP ;CALCULATE UNIT COST FOR FORM
+1 SET ASUJ("OH","VAL")=$PIECE(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,16)
+2 SET ASUJ("OH","QTY")=$PIECE(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,17)
+3 IF ASUJ("OH","VAL")>0
IF ASUJ("OH","QTY")>0
Begin DoDot:1
+4 SET (ASUJ("UCST"),Y)=$FNUMBER((ASUJ("OH","VAL")/ASUJ("OH","QTY")),"",2)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET ASUJMSG(1)="This item is not in stock. If you order it, it will be BackOrdered"
+7 SET ASUJMSG(2)="The Unit Cost displayed is the Last Purchase Price"
+8 ;DFM P1 9/1/98
SET ASUJMSG(3)="$$EOP"
WRITE *7
DO HLP^ASUJHELP(.ASUJMSG)
+9 ;Last Purchase Price
SET (ASUJ("UCST"),Y)=$FNUMBER($PIECE(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,15),"",2)
End DoDot:1
+10 QUIT
VAL ;EP ;CALCULATE ORDER VALUE FOR FORM
+1 IF '$DATA(ASUJ("UCST"))
DO UCST
+2 SET ASUJ("QTY")=$$GET^DDSVALF("QTY")
+3 SET ASUJ("VAL")=$FNUMBER((ASUJ("QTY")*ASUJ("UCST")),",",2)
+4 DO PUT^DDSVALF("VAL","","",ASUJ("VAL"))
+5 QUIT
RVAL ;EP ;CALCULATE RECOMMED VALUE FOR FORM
+1 IF '$DATA(ASUJ("UCST"))
DO UCST
+2 SET ASUJ("RQTY")=$PIECE(^ASUT(8,ASUJ("E#","RQI"),3),U,6)
+3 SET (ASUJ("RVAL"),Y)=$FNUMBER((ASUJ("RQTY")*ASUJ("UCST")),",",2)
+4 QUIT
VOU ;EP ;CALCULATE VOUCHER NUMBER FOR FORM
+1 IF '$DATA(ASUJ("VOU"))
DO CALCVOU
+2 SET Y=ASUJ("VOU")
+3 SET $PIECE(^ASUT(8,ASUJ("E#","RQI"),0),U,8)=ASUJ("VOU")
+4 QUIT
FILE ;EP ;PLACE ORDER INTO ASUTRN ISSUE FILE
+1 SET ASUT="IBK"
DO DAYTIM^ASUUDATE
+2 SET ASUHDA=$ORDER(^ASUT(3,9999999999),-1)+1
+3 MERGE ^ASUT(3,ASUHDA)=^ASUT(8,ASUJ("E#","RQI"))
+4 SET $PIECE(^ASUT(3,ASUHDA,0),U)=ASUT(ASUT,"TRKY")
+5 ;BLANK OUT RECOMMEND QTY
SET $PIECE(^ASUT(3,ASUHDA,3),U,6)=""
+6 ;RESET ORDER QTY
SET $PIECE(^ASUT(8,ASUHDA,0),U,6)=""
+7 ;RESET VOUCHER NUMBER
SET $PIECE(^ASUT(8,ASUHDA,1),U,8)=""
+8 ;Re xref new record
SET DA=ASUHDA
SET DIK="^ASUT(3,"
DO IX^DIK
+9 QUIT
CRMSTR ;EP ; -CREATE ISSUE BOOK TRANS
+1 IF $GET(ASUK("DT"))']""
DO DATE^ASUUDATE
+2 WRITE !!,"CREATE ONLINE ISSUE BOOK TRANS MASTER PROGRAM",!!
+3 IF $GET(ASUF("STA"))'["S"
Begin DoDot:1
+4 SET ASUMK("E#","STA")=0
+5 FOR
SET ASUMK("E#","STA")=$ORDER(^ASUMK(ASUMK("E#","STA")))
IF ASUMK("E#","STA")'?1N.N
QUIT
DO REQS
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 KILL DIR
+8 SET DIR(0)="PAO^ASUMK("
SET DIR("A")="ENTER STATION FOR ISSUE BOOK : "
DO ^DIR
+9 IF Y']""
QUIT
+10 IF Y<0
QUIT
+11 SET ASUMK("E#","STA")=+Y
+12 DO REQS
End DoDot:1
+13 KILL ASUC,ASUMK,ASUMS,ASUMX,ASUV,ASUT
+14 QUIT
REQS ;
+1 SET (ASUL(2,"STA","E#"),ASUMS("E#","STA"))=ASUMK("E#","STA")
+2 DO STA^ASULARST(ASUL(2,"STA","E#"))
+3 SET ASUMK("E#","REQ")=0
+4 FOR
SET ASUMK("E#","REQ")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ")))
IF ASUMK("E#","REQ")'?1N.N
QUIT
Begin DoDot:1
+5 SET DA=ASUMK("E#","REQ")_000000
SET ASUHDA=DA+999999
SET DIK="ASUT(8,"
+6 FOR
SET DA=$ORDER(^ASUT(8,DA))
IF DA'?1N.N
QUIT
IF DA>ASUHDA
QUIT
DO ^DIK
+7 FOR X=19,20,22
KILL ASUL(X)
+8 DO REQ^ASULDIRR(ASUMK("E#","REQ"))
+9 WRITE !?10,"PROCESSING REQUSITIONER: ",ASUL(20,"REQ","NM")
+10 SET ASUMK("E#","IDX")=0
+11 FOR
SET ASUMK("E#","IDX")=$ORDER(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX")))
IF ASUMK("E#","IDX")'?1N.N
QUIT
IF $EXTRACT(ASUMK("E#","IDX"),3,9)="999999"
QUIT
Begin DoDot:2
+12 SET ASUMS("E#","IDX")=ASUMK("E#","IDX")
+13 DO ^ASUMSTRD
DO READ^ASUMKBIO
+14 SET ASUMX("E#","IDX")=ASUMK("E#","IDX")
DO READ^ASUMXDIO
+15 IF $GET(Y)<0
WRITE !?15,"NO ENTRY IN INDEX MASTER"
QUIT
+16 WRITE !?10,"PROCESSING INDEX: ",ASUMX("IDX")
+17 SET ASUMS("E#","IDX")=ASUMX("E#","IDX")
+18 DO ^ASUMSTRD
+19 IF $GET(Y)<0
WRITE !?20,"NO INDEX ON STATION MASTER"
QUIT
+20 SET ASUT20=$GET(^ASUL(20,ASUL(20,"REQ","E#"),2,1,0))
+21 IF ASUT20']""
WRITE !?30,"NO PRIMAR CAN AVAILABLE"
QUIT
+22 SET ASUL(20,"CAN")=$PIECE(ASUT20,U)
+23 SET ASUL(17,"SSA")=$PIECE(ASUT20,U,2)
DO SSA^ASULDIRR(ASUL(17,"SSA"))
+24 SET ASUHDA=ASUL(20,"REQ","E#")_ASUMX("IDX")
+25 IF '$DATA(ASUHDA)
QUIT
+26 SET (ASUT(0),ASUT(1),ASUT(3))=""
SET ASUT="OIB"
+27 SET $PIECE(ASUT(0),U)=ASUHDA
+28 SET $PIECE(ASUT(0),U,2)=ASUL(1,"AR","E#")
+29 SET $PIECE(ASUT(0),U,3)=ASUL(2,"STA","E#")
+30 SET $PIECE(ASUT(0),U,4)=ASUMX("ACC")
+31 SET $PIECE(ASUT(0),U,5)=ASUMX("E#","IDX")
+32 SET $PIECE(ASUT(0),U,6)=DUZ(2)
+33 ;Status
SET $PIECE(ASUT(0),U,10)="Y"
+34 SET $PIECE(ASUT(0),U,11)=ASUL(17,"SSA","E#")
+35 SET $PIECE(ASUT(0),U,13)=ASUL(18,"SST","E#")
+36 SET $PIECE(ASUT(0),U,14)=ASUL(19,"USR","E#")
+37 SET $PIECE(ASUT(0),U,15)=ASUL(20,"REQ","E#")
+38 SET $PIECE(ASUT(0),U,16)=ASUMS("EOQ","TB")
+39 SET $PIECE(ASUT(1),U)=32
+40 SET $PIECE(ASUT(1),U,2)=ASUL(1,"AR","AP")
+41 SET $PIECE(ASUT(1),U,3)=ASUL(2,"STA","CD")
+42 SET $PIECE(ASUT(1),U,4)=ASUMX("ACC")
+43 SET $PIECE(ASUT(1),U,5)=ASUMX("IDX")
+44 ;QTY REQ
SET $PIECE(ASUT(1),U,6)=""
+45 ;VAL
SET $PIECE(ASUT(1),U,7)=""
+46 ;VOU
SET $PIECE(ASUT(1),U,8)=""
+47 ;DT REQ
SET $PIECE(ASUT(1),U,10)=""
+48 SET $PIECE(ASUT(1),U,11)=ASUL(17,"SSA")
+49 SET $PIECE(ASUT(1),U,13)=ASUL(18,"SST")
+50 SET $PIECE(ASUT(1),U,14)=ASUL(19,"USR")
+51 SET $PIECE(ASUT(1),U,15)=ASUL(20,"CAN")
+52 SET $PIECE(ASUT(1),U,16)=ASUMS("EOQ","TP")
+53 ;F-P-N
SET $PIECE(ASUT(1),U,18)=""
+54 ;POST
SET $PIECE(ASUT(3),U)=""
+55 ;ISSUE TYPE (REGULAR)
SET $PIECE(ASUT(3),U,2)=3
+56 ;REQ TYP
SET $PIECE(ASUT(3),U,3)=""
+57 ;REQ #
SET $PIECE(ASUT(3),U,4)=""
+58 ;C/G
SET $PIECE(ASUT(3),U,5)=""
+59 SET $PIECE(ASUT(3),U,6)=ASUMK("ULQTY")
+60 IF $DATA(^ASUT(3,ASUHDA,0))
Begin DoDot:3
+61 ;Delete old entry and xrefs
SET DA=ASUHDA
SET DIK="^ASUT(8,"
DO ^DIK
End DoDot:3
+62 SET ^ASUT(8,ASUHDA,0)=ASUT(0)
+63 SET ^ASUT(8,ASUHDA,1)=ASUT(1)
+64 SET ^ASUT(8,ASUHDA,3)=ASUT(3)
+65 SET $PIECE(^ASUT(8,0),U,4)=$PIECE(^ASUT(8,0),U,4)+1
SET $PIECE(^ASUT(8,0),U,3)=ASUHDA
+66 ;Re xref new record
SET DA=ASUHDA
SET DIK="^ASUT(8,"
DO IX^DIK
End DoDot:2
+67 KILL ASUMK("E#","IDX")
End DoDot:1
+68 KILL ASUT20
+69 QUIT
TRANS ;EP ;SCREENMAN FOR ONLINE ISSUE TRANSACTION ENTRY
+1 WRITE !!,"NOT CURRENTLY AVAILABLE"
+2 QUIT
