Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ASUJOLIB

ASUJOLIB.m

Go to the documentation of this file. 
  1. ASUJOLIB ; IHS/ITSC/LMH -SCREENMAN FOR ONLINE ISSUE ENTRY ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;This routine will be used for the online issue book transaction
  1.  ;entry
  1.  D:'$D(ASUK("DT")) DATE^ASUUDATE
  1.  D:'$D(ASUL(1)) ARE^ASULARST($P(^ASUSITE(1,0),U))
  1.  S ASUJ("E#","STA")=$G(ASUL(1,"AR","STA1"))
  1.  K DIR S DIR(0)="PAO^9002039.2:AENQ",DIR("A")="ENTER YOUR REQUISITIONER CODE: "
  1.  D ^DIR Q:$D(DUOUT)  Q:$D(DIROUT)  Q:$D(DTOUT)
  1.  Q:$G(Y)']""
  1.  S ASUJ=+Y
  1.  D CALCVOU
  1.  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"
  1.  D ^DIR Q:$D(DUOUT)  Q:$D(DIROUT)  Q:$D(DTOUT)
  1.  Q:$G(Y)']""
  1.  G:Y["Y" LOOPALL
  1. ANOTHER ;
  1.  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"
  1.  D IX^DIC Q:$D(DUOUT)  Q:$D(DIROUT)  Q:$D(DTOUT)  Q:$G(Y)']""
  1.  S (ASUJ("E#","RQI"),DA)=+Y,ASUJ("E#","IDX")=$P(^ASUT(8,DA,0),U,5)
  1.  S DDSFILE=9002036.8,DR="[ASUJIB ISSUE]",DDSPARM="CES" D ^DDS
  1.  K DIR S DIR(0)="SA^Y:Yes;N:No",DIR("A")="ORDER ANOTHER ITEM? ",DIR("B")="Y"
  1.  D ^DIR G:$D(DIRUT) EXIT G:X="N" EXIT
  1.  G ANOTHER
  1. LOOPALL ;
  1.  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
  1.  F  S DA=$O(^ASUT(8,DA)) Q:$E(DA,1,9)'=ASUJ  D  G:$G(ASUJ("ANS"))="N" EXIT
  1.  .S ASUJ("E#","RQI")=DA,ASUJ("E#","IDX")=ASUL(1,"AR","AP")_$E(DA,$L(DA)-5,$L(DA))
  1.  .S DDSFILE=9002036.8,DR="[ASUJIB ISSUE]",DDSPARM="CES"
  1.  .D ^DDS
  1.  .K DIR S DIR(0)="SA^Y:Yes;N:No",DIR("A")="CONTINUE WITH NEXT ITEM? ",DIR("B")="Y"
  1.  .D ^DIR
  1.  .I $D(DIRUT) S ASUJ("ANS")="N"
  1.  .S ASUJ("ANS")=$E(X)
  1. EXIT ;
  1.  K DIR,DIC,ASUJ,DA,DDSFILE,DR,DDSPARM
  1.  Q
  1. CALCVOU ;
  1.  S ASUJ("VOU")=$P($G(^ASUSITE(1,1)),U,8)
  1.  I ASUJ("VOU")=4999 W "Sorry, no Voucher Numbers available for Online Issues" H 5 Q
  1.  S $P(^ASUSITE(1,1),U,8)=ASUJ("VOU")+1,ASUP("LSMO")=$P(^ASUSITE(1,0),U,14)
  1.  S ASUJ("VOU")=$E(ASUP("LSMO"),3,4)_$E(ASUP("LSMO"),1,2)+1_$P($FN((ASUJ("VOU")*.0001),"",4),".",2)
  1.  Q
  1. UCST ;EP ;CALCULATE UNIT COST FOR FORM
  1.  S ASUJ("OH","VAL")=$P(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,16)
  1.  S ASUJ("OH","QTY")=$P(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,17)
  1.  I ASUJ("OH","VAL")>0,ASUJ("OH","QTY")>0 D
  1.  .S (ASUJ("UCST"),Y)=$FN((ASUJ("OH","VAL")/ASUJ("OH","QTY")),"",2)
  1.  E  D
  1.  .S ASUJMSG(1)="This item is not in stock. If you order it, it will be BackOrdered"
  1.  .S ASUJMSG(2)="The Unit Cost displayed is the Last Purchase Price"
  1.  .S ASUJMSG(3)="$$EOP" W *7 D HLP^ASUJHELP(.ASUJMSG) ;DFM P1 9/1/98
  1.  .S (ASUJ("UCST"),Y)=$FN($P(^ASUMS(ASUJ("E#","STA"),1,ASUJ("E#","IDX"),0),U,15),"",2) ;Last Purchase Price
  1.  Q
  1. VAL ;EP ;CALCULATE ORDER VALUE FOR FORM
  1.  I '$D(ASUJ("UCST")) D UCST
  1.  S ASUJ("QTY")=$$GET^DDSVALF("QTY")
  1.  S ASUJ("VAL")=$FN((ASUJ("QTY")*ASUJ("UCST")),",",2)
  1.  D PUT^DDSVALF("VAL","","",ASUJ("VAL"))
  1.  Q
  1. RVAL ;EP ;CALCULATE RECOMMED VALUE FOR FORM
  1.  I '$D(ASUJ("UCST")) D UCST
  1.  S ASUJ("RQTY")=$P(^ASUT(8,ASUJ("E#","RQI"),3),U,6)
  1.  S (ASUJ("RVAL"),Y)=$FN((ASUJ("RQTY")*ASUJ("UCST")),",",2)
  1.  Q
  1. VOU ;EP ;CALCULATE VOUCHER NUMBER FOR FORM
  1.  D:'$D(ASUJ("VOU")) CALCVOU
  1.  S Y=ASUJ("VOU")
  1.  S $P(^ASUT(8,ASUJ("E#","RQI"),0),U,8)=ASUJ("VOU")
  1.  Q
  1. FILE ;EP ;PLACE ORDER INTO ASUTRN ISSUE FILE
  1.  S ASUT="IBK" D DAYTIM^ASUUDATE
  1.  S ASUHDA=$O(^ASUT(3,9999999999),-1)+1
  1.  M ^ASUT(3,ASUHDA)=^ASUT(8,ASUJ("E#","RQI"))
  1.  S $P(^ASUT(3,ASUHDA,0),U)=ASUT(ASUT,"TRKY")
  1.  S $P(^ASUT(3,ASUHDA,3),U,6)="" ;BLANK OUT RECOMMEND QTY
  1.  S $P(^ASUT(8,ASUHDA,0),U,6)="" ;RESET ORDER QTY
  1.  S $P(^ASUT(8,ASUHDA,1),U,8)="" ;RESET VOUCHER NUMBER
  1.  S DA=ASUHDA,DIK="^ASUT(3," D IX^DIK ;Re xref new record
  1.  Q
  1. CRMSTR ;EP ; -CREATE ISSUE BOOK TRANS
  1.  D:$G(ASUK("DT"))']"" DATE^ASUUDATE
  1.  W !!,"CREATE ONLINE ISSUE BOOK TRANS MASTER PROGRAM",!!
  1.  I $G(ASUF("STA"))'["S" D
  1.  .S ASUMK("E#","STA")=0
  1.  .F  S ASUMK("E#","STA")=$O(^ASUMK(ASUMK("E#","STA"))) Q:ASUMK("E#","STA")'?1N.N  D REQS
  1.  E  D
  1.  .K DIR
  1.  .S DIR(0)="PAO^ASUMK(",DIR("A")="ENTER STATION FOR ISSUE BOOK : " D ^DIR
  1.  .Q:Y']""
  1.  .Q:Y<0
  1.  .S ASUMK("E#","STA")=+Y
  1.  .D REQS
  1.  K ASUC,ASUMK,ASUMS,ASUMX,ASUV,ASUT
  1.  Q
  1. REQS ;
  1.  S (ASUL(2,"STA","E#"),ASUMS("E#","STA"))=ASUMK("E#","STA")
  1.  D STA^ASULARST(ASUL(2,"STA","E#"))
  1.  S ASUMK("E#","REQ")=0
  1.  F  S ASUMK("E#","REQ")=$O(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"))) Q:ASUMK("E#","REQ")'?1N.N  D
  1.  .S DA=ASUMK("E#","REQ")_000000,ASUHDA=DA+999999,DIK="ASUT(8,"
  1.  .F  S DA=$O(^ASUT(8,DA)) Q:DA'?1N.N  Q:DA>ASUHDA  D ^DIK
  1.  .F X=19,20,22 K ASUL(X)
  1.  .D REQ^ASULDIRR(ASUMK("E#","REQ"))
  1.  .W !?10,"PROCESSING REQUSITIONER: ",ASUL(20,"REQ","NM")
  1.  .S ASUMK("E#","IDX")=0
  1.  .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
  1.  ..S ASUMS("E#","IDX")=ASUMK("E#","IDX")
  1.  ..D ^ASUMSTRD,READ^ASUMKBIO
  1.  ..S ASUMX("E#","IDX")=ASUMK("E#","IDX") D READ^ASUMXDIO
  1.  ..I $G(Y)<0 W !?15,"NO ENTRY IN INDEX MASTER" Q
  1.  ..W !?10,"PROCESSING INDEX: ",ASUMX("IDX")
  1.  ..S ASUMS("E#","IDX")=ASUMX("E#","IDX")
  1.  ..D ^ASUMSTRD
  1.  ..I $G(Y)<0 W !?20,"NO INDEX ON STATION MASTER" Q
  1.  ..S ASUT20=$G(^ASUL(20,ASUL(20,"REQ","E#"),2,1,0))
  1.  ..I ASUT20']"" W !?30,"NO PRIMAR CAN AVAILABLE" Q
  1.  ..S ASUL(20,"CAN")=$P(ASUT20,U)
  1.  ..S ASUL(17,"SSA")=$P(ASUT20,U,2) D SSA^ASULDIRR(ASUL(17,"SSA"))
  1.  ..S ASUHDA=ASUL(20,"REQ","E#")_ASUMX("IDX")
  1.  ..Q:'$D(ASUHDA)
  1.  ..S (ASUT(0),ASUT(1),ASUT(3))="",ASUT="OIB"
  1.  ..S $P(ASUT(0),U)=ASUHDA
  1.  ..S $P(ASUT(0),U,2)=ASUL(1,"AR","E#")
  1.  ..S $P(ASUT(0),U,3)=ASUL(2,"STA","E#")
  1.  ..S $P(ASUT(0),U,4)=ASUMX("ACC")
  1.  ..S $P(ASUT(0),U,5)=ASUMX("E#","IDX")
  1.  ..S $P(ASUT(0),U,6)=DUZ(2)
  1.  ..S $P(ASUT(0),U,10)="Y" ;Status
  1.  ..S $P(ASUT(0),U,11)=ASUL(17,"SSA","E#")
  1.  ..S $P(ASUT(0),U,13)=ASUL(18,"SST","E#")
  1.  ..S $P(ASUT(0),U,14)=ASUL(19,"USR","E#")
  1.  ..S $P(ASUT(0),U,15)=ASUL(20,"REQ","E#")
  1.  ..S $P(ASUT(0),U,16)=ASUMS("EOQ","TB")
  1.  ..S $P(ASUT(1),U)=32
  1.  ..S $P(ASUT(1),U,2)=ASUL(1,"AR","AP")
  1.  ..S $P(ASUT(1),U,3)=ASUL(2,"STA","CD")
  1.  ..S $P(ASUT(1),U,4)=ASUMX("ACC")
  1.  ..S $P(ASUT(1),U,5)=ASUMX("IDX")
  1.  ..S $P(ASUT(1),U,6)="" ;QTY REQ
  1.  ..S $P(ASUT(1),U,7)="" ;VAL
  1.  ..S $P(ASUT(1),U,8)="" ;VOU
  1.  ..S $P(ASUT(1),U,10)="" ;DT REQ
  1.  ..S $P(ASUT(1),U,11)=ASUL(17,"SSA")
  1.  ..S $P(ASUT(1),U,13)=ASUL(18,"SST")
  1.  ..S $P(ASUT(1),U,14)=ASUL(19,"USR")
  1.  ..S $P(ASUT(1),U,15)=ASUL(20,"CAN")
  1.  ..S $P(ASUT(1),U,16)=ASUMS("EOQ","TP")
  1.  ..S $P(ASUT(1),U,18)="" ;F-P-N
  1.  ..S $P(ASUT(3),U)="" ;POST
  1.  ..S $P(ASUT(3),U,2)=3 ;ISSUE TYPE (REGULAR)
  1.  ..S $P(ASUT(3),U,3)="" ;REQ TYP
  1.  ..S $P(ASUT(3),U,4)="" ;REQ #
  1.  ..S $P(ASUT(3),U,5)="" ;C/G
  1.  ..S $P(ASUT(3),U,6)=ASUMK("ULQTY")
  1.  ..I $D(^ASUT(3,ASUHDA,0)) D
  1.  ...S DA=ASUHDA,DIK="^ASUT(8," D ^DIK ;Delete old entry and xrefs
  1.  ..S ^ASUT(8,ASUHDA,0)=ASUT(0)
  1.  ..S ^ASUT(8,ASUHDA,1)=ASUT(1)
  1.  ..S ^ASUT(8,ASUHDA,3)=ASUT(3)
  1.  ..S $P(^ASUT(8,0),U,4)=$P(^ASUT(8,0),U,4)+1,$P(^ASUT(8,0),U,3)=ASUHDA
  1.  ..S DA=ASUHDA,DIK="^ASUT(8," D IX^DIK ;Re xref new record
  1.  .K ASUMK("E#","IDX")
  1.  K ASUT20
  1.  Q
  1. TRANS ;EP ;SCREENMAN FOR ONLINE ISSUE TRANSACTION ENTRY
  1.  W !!,"NOT CURRENTLY AVAILABLE"
  1.  Q