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

ASULARST.m

Go to the documentation of this file. 
  1. ASULARST ; IHS/ITSC/LMH -AREA & STATION TABLE LOOKUP ;  
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;This routine is a utility which provides entry points to do lookups
  1.  ;and verification for Area Code and Station Code.
  1.  Q:$D(ASUL(1,"AR","AP"))
  1.  D CLS^ASUUHDG W *7 D:'$D(ASUL(1,"AR","E#")) SETAREA I $D(ASUL(1,"AR","AP")) I ASUL(1,"AR","AP")=U Q
  1.  W !?14,"Reminder, Area Code you are signed on with is : ",ASUL(1,"AR","E#"),!
  1.  W !!?35-($L(ASUL(1,"AR","NM"))/2),ASUL(1,"AR","NM"),!!
  1.  W !?10,"If this is correct, enter <cr> to continue."
  1.  W !?10,"Otherwise, enter '^', exit form the KERNEL S.A.M.S. MENU"
  1.  W !?15,"and then re-enter with the correct Area.",!!
  1.  S DIR(0)="E" D ^DIR K DIR
  1.  I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) S ASUL(1,"AR","E#")=U
  1.  S ASUL(1,"AR","AP")=ASUL(1,"AR","E#")
  1.  K ASUL(1,"AR","E#")
  1.  Q
  1. SETAREA ;EP ;SET ASUL(1,"AR","E#") BASED ON DUZ(2) THEN SET ASUL(1) ARRAY
  1.  D LOOKUP S ASUF("LOOKA")=0 D AREA K ASUF("LOOKA")
  1.  Q
  1. LOOKUP ;EP ;LOOKUP AREA BASED ON DUZ(2)
  1.  I '$D(DUZ(2)) S (X,ASUL(1,"AR","AP"))=$P(^ASUSITE(1,0),U) D ARE(ASUL(1,"AR","AP")) Q
  1.  D:'$D(U) ^XBKVAR
  1.  S (X,ASUL(1,"AR","E#"))=$E($P(^AUTTAREA($P(^AUTTLOC(DUZ(2),0),U,4),0),U,4),2,3)
  1.  S ASUK("LOC")=$P(^AUTTLOC(DUZ(2),0),U,2)
  1.  S ASUK("ASUFAC")=$P(^AUTTLOC(DUZ(2),0),U,10)
  1.  I ASUL(1,"AR","E#")']"" W "No Accounting Point stored in your SITE file; contact site manager",!,"Program can not continue -Aborting",! S ASUL(1,"AR","AP")="^" Q
  1.  Q
  1. ARPRINT ;EP; Write out Area Name and save Area Lookup table EIN
  1.  D:$G(ASUL(1,"AR","NM"))']"" ARL
  1.  W " ",ASUL(1,"AR","NM") Q
  1. AREA ;EP -Lookup Area Name. X=AREA CODE
  1.  S ASUF("LOOKA")=$G(ASUF("LOOKA"))
  1.  S:ASUF("LOOKA")="" ASUF("LOOKA")=1
  1. ARL ;
  1.  I '$D(ASUL(1,"AR","AP")) D  ;Q:ASUF("LOOKA")=0
  1.  .I ASUF("LOOKA"),'$D(X) D SETAREA S ASUF("LOOKA")=0 Q
  1.  .S ASUL(1,"AR","AP")=X
  1.  D ARE(X)
  1.  S ASUF("LOOKA")=$G(ASUF("LOOKA"))
  1.  D:ASUF("LOOKA") LOOKUP
  1.  Q
  1. FINDAREA ;EP ;FIND AREA FROM TABLE 01
  1.  N DIR
  1.  S DIR(0)="PO^9002039.01:EM",DIR("A")="SELECT AREA" D ^DIR
  1.  Q:$D(DIRUT)  Q:+Y<0
  1.  S X=+Y
  1.  G AREX
  1. ARE(X) ;EP ;LOOKUP AREA IN TABLE 01
  1. AREX ;
  1.  S (ASUL(1,"AR","E#"),ASUL(1,"AR","AP"))=X
  1.  I $D(^ASUL(1,X,0)) D
  1.  .S ASUL(1,"AR","NM")=$P(^ASUL(1,X,0),U)
  1.  .S ASUL(1,"AR","STA1")=$P(^ASUL(1,X,1),U)
  1.  .S ASUL(1,"AR","WHSE")=$P(^ASUL(1,X,1),U,2)
  1.  .S ASUL(1,"AR","DLTM")=$P(^ASUL(1,X,1),U,3)
  1.  E  D
  1.  .S ASUL(1,"AR","NM")="NOT FOUND",(ASUL(1,"AR","STA1"),ASUL(1,"AR","WHSE"))=""
  1.  Q
  1. STPRINT ;
  1.  S:'$D(X1) X1=$G(ASUK("STA","CD"))
  1.  D STA(X1) W " ",ASUL(2,"STA","NM") Q
  1. STAT ;EP -Lookup Station Name. X=AREA CODE, X1=STATION CODE.
  1.  I '$D(ASUL(1,"AR","AP")) D
  1.  .I '$D(X) D
  1.  ..D SETAREA
  1.  .E  D
  1.  ..D ARE(X)
  1.  I $G(ASUL(2,"STA","E#"))']"" D  Q:ASUL(2,"STA","E#")']""
  1.  .I '$D(X1) S ASUL(2,"STA","E#")="",ASUL(2,"STA","NM")="UNKNOWN" Q
  1.  .S ASUL(2,"STA","E#")=X1
  1.  D:'$D(ASUL(1,"AR","E#")) SETAREA
  1.  D STA(X1)
  1.  Q
  1. STA(X) ;EP ; DIRECT STATION TABLE LOOKUP
  1.  I $L(X)=3 S X=ASUL(1,"AR","AP")_X
  1.  I $L(X)=2 S X=ASUL(1,"AR","AP")_"0"_X
  1.  I X'?5N D  Q
  1.  .S Y=-4 Q  ;Input paramater did not pass Station IEN edit
  1.  I $D(^ASUL(2,X,0)) D
  1.  .S (Y,ASUL(2,"STA","E#"))=X ;Record found for input parameter
  1.  .S ASUL(2,"STA","CD")=$P(^ASUL(2,X,1),U)
  1.  .S ASUL(2,"STA","NM")=$P(^ASUL(2,X,0),U)
  1.  .S ASUL(2,"STA","TYP")=$P(^ASUL(2,X,1),U,2)
  1.  .S ASUL(2,"STA","CTP")=$P(^ASUL(2,X,1),U,3)
  1.  .S ASUL(2,"STA","TP#")=$P(^ASUL(2,X,1),U,4)
  1.  .S ASUL(2,"STA","EOQTB")=$P(^ASUL(2,X,1),U,6)
  1.  .S:ASUL(2,"STA","EOQTB")']"" ASUL(2,"STA","EOQTB")=50
  1.  E  D
  1.  .S ASUL(2,"STA","E#")=X ;IEN to use for LAYGO call
  1.  .S ASUL(2,"STA","CD")="N/F",ASUL(2,"STA","NM")="UNKNOWN",ASUL(2,"STA","EOQTB")=50
  1.  .S Y=-1 ;No record found for Input parameter
  1.  Q
  1. TRN(X) ;EP ;TRANSACTION CODE
  1.  K ASUL(11)
  1.  I X?1N.N,$D(^ASUL(11,+X)) S ASUL(11,"TRN","E#")=+X
  1.  E  S:$E(X)'="T" X="T"_X S ASUL(11,"TRN","E#")=$O(^ASUL(11,"B",X,""))
  1.  I $G(ASUL(11,"TRN","E#"))']"" S Y=-1 Q
  1.  E  S Y=$G(^ASUL(11,ASUL(11,"TRN","E#"),0))
  1.  S ASUL(11,"TRN","KEY")=$P(Y,U,1)
  1.  S ASUL(11,"TRN","CDE")=$E(Y,2,3)
  1.  S ASUL(11,"TRN","NAME")=$P(Y,U,2)
  1.  N Z S (Z,ASUL(11,"TRN","TYPE"))=$P(Y,U,3)
  1.  S ASUL(11,"TRN","TYPN")=$S(Z=1:"DUE IN",Z=2:"RECEIPT",Z=3:"ISSUE",Z=4:"INDEX",Z=5:"STATION",Z=6:"ADJUSTMENT",Z=7:"TRANSFER DUE IN",Z=8:"TRANSFER IN",Z=9:"TRANSFER OUT",Z=0:"DIRECT ISSUE",1:"TRANSFER ISSUE")
  1.  S (Z,ASUL(11,"TRN","EXT"))=$P(Y,U,4)
  1.  S ASUL(11,"TRN","EXTN")=$S(Z=0:"ADD",Z=1:"CHANGE",Z=2:"DELETE",Z=3:"USER LEVEL",Z=4:"PURCHASED",Z=5:"UNREQUIRED",Z=6:"DONATED",Z=7:"EXCESS",Z=8:"STOCK REPLENISHMENT",Z=9:"NON REPLENISHMENT",1:"")
  1.  S ASUL(11,"TRN","DRCR")=$P(Y,U,5)
  1.  S ASUL(11,"TRN","DBCR")=$S(ASUL(11,"TRN","TYPE")=4:"",ASUL(11,"TRN","TYPE")=5:"",ASUL(11,"TRN","DRCR")=-1:"CREDIT",1:"DEBIT")
  1.  S ASUL(11,"TRN","REV")=$P(Y,U,6)
  1.  S ASUL(11,"TRN","TAG")=$P(Y,U,7)
  1.  S ASUL(11,"TRN","FIL")=$P(Y,U,8)
  1.  Q