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

ASUMKBIO.m

Go to the documentation of this file. 
  1. ASUMKBIO ; IHS/ITSC/LMH -SET FIELD VARIABLES ISSUE BOOK ; 
  1.  ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1.  ;This routine provides an entry points to
  1.  ;read (retreve) data from and write (store) data to the SAMS Issue
  1.  ;Book Master file. Entry points are also provided to lookup and add
  1.  ;records. A 'key' is be used to access each of the 3 levels.
  1.  ;The 1st is STATION, a Station Table pointer; The 2nd is REQUSITIONER
  1.  ;a Requsitioner Table pointer; the 3rd is INDEX NUMBER a ASUMST INDEX
  1.  ;master file pointer.
  1. READ ;EP;READ ISSUE BOOK
  1.  Q:$G(ASUMK("E#","STA"))']""
  1.  S ASUMK("STA")=$P(^ASUL(2,ASUMK("E#","STA"),1),U)
  1.  S ASUMK("STA","NM")=$P(^ASUL(2,ASUMK("E#","STA"),0),U)
  1.  Q:$G(ASUMK("E#","REQ"))']""
  1.  D REQ^ASULDIRR(ASUMK("E#","REQ"))
  1.  S ASUMK("E#","SST")=ASUL(18,"SST","E#")
  1.  S ASUMK("SST")=ASUL(18,"SST")
  1.  S ASUMK("SST","NM")=ASUL(18,"SST","NM")
  1.  S ASUMK("E#","USR")=ASUL(19,"USR","E#")
  1.  S ASUMK("USR")=ASUL(19,"USR")
  1.  S ASUMK("USR","NM")=ASUL(19,"USR","NM")
  1.  Q:$G(ASUMK("E#","IDX"))']""
  1.  S ASUMK("IDX")=$E(ASUMK("E#","IDX"),3,8)
  1.  S ASUMK(0)=$G(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"),0))
  1.  S ASUMK(1)=$G(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"),1))
  1.  S ASUMK(2)=$G(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"),2))
  1.  S ASUMK("ULQTY")=$P(ASUMK(0),U,2)
  1.  K ASUMK("TOT"),ASUMK("P6MO")
  1.  F ASUU(17)=0:1:11 D
  1.  .S:$G(ASUK("DT","MO"))']"" ASUK("DT","MO")=1
  1.  .S ASUQ("MO")=ASUK("DT","MO")+ASUU(17)
  1.  .S:ASUQ("MO")>12 ASUQ("MO")=ASUQ("MO")-12
  1.  .S ASULMO(ASUU(17)+1)=ASUQ("MO")
  1.  .S ASUMK(ASUQ("MO"),"DOC")=$P(ASUMK(1),U,ASUQ("MO"))
  1.  .S ASUMK("TOT","DOC")=$G(ASUMK("TOT","DOC"))+ASUMK(ASUQ("MO"),"DOC")
  1.  .S ASUMK(ASUQ("MO"),"QTY")=$P(ASUMK(2),U,ASUQ("MO"))
  1.  .S ASUMK("TOT","QTY")=$G(ASUMK("TOT","QTY"))+ASUMK(ASUQ("MO"),"QTY")
  1.  .I ASUU(17)>5 D
  1.  ..S ASUMK("P6MO","QTY")=$G(ASUMK("P6MO","QTY"))+ASUMK(ASUQ("MO"),"QTY")
  1.  ..S ASUMK("P6MO","DOC")=$G(ASUMK("P6MO","DOC"))+ASUMK(ASUQ("MO"),"DOC")
  1.  K ASUU(17)
  1.  I ASUMK("ULQTY")?1N.N D
  1.  .S ASUMK("PULQTY")=1
  1.  E  D
  1.  .S ASUMK("PULQTY")=0
  1.  .I ASUMK("E#","IDX")'=$G(ASUMS("E#","IDX")) D
  1.  ..S ASUV("MOLD")=6
  1.  .E  D
  1.  ..S Y=$E(ASUMS("ESTB"),1,3)+1700
  1.  ..S Y=ASUK("DT","YEAR")-Y
  1.  ..S X=$E(ASUMS("ESTB"),4,5)
  1.  ..S X=ASUK("DT","MO")-X
  1.  ..S ASUMK("MOLD")=(Y*12)+X
  1.  ..K X,Y
  1.  ..S:ASUMK("MOLD")>6 ASUMK("MOLD")=6
  1.  .I +$G(ASUMK("MOLD"))=0 S ASUMK("ULQTY")=0
  1.  .E  S ASUMK("ULQTY")=$FN(ASUMK("P6MO","QTY")/ASUMK("MOLD"),"",0)
  1.  .S ASUMK("ULQTY")=$FN(ASUMK("ULQTY")*ASUL(20,"ULVQ FCTR"),"",0)
  1.  S ASUMK("CFY","VAL")=$P(ASUMK(0),U,3)
  1.  S ASUMK("PFY","VAL")=$P(ASUMK(0),U,4)
  1.  S ASUMK("PPY","VAL")=$P(ASUMK(0),U,5)
  1.  K ASUQ("MO")
  1.  Q
  1. DISPLAY ;
  1.  S X=0 F Y=10:10 S X=$O(ASUMK(X)) Q:X']""  D
  1.  .W:$G(ASUMK(X))]"" ?Y,X," : ",ASUMK(X),"  "
  1.  .S X(1)="" F  S X(1)=$O(ASUMK(X,X(1))) Q:X(1)']""  D
  1.  ..W:X?1N.N "MO " W ?Y,X,",",X(1)," : ",ASUMK(X,X(1)),"  "
  1.  Q
  1. EN1 ;EP ; PRIMARY ENTRY POINT - ASUMY("E#","REQ") REQUIRED
  1.  I '$D(ASUMK("E#","REQ")) Q
  1.  I '$D(ASUMK("E#","STA")) Q
  1.  I '$D(ASUMK("E#","IDX")) Q
  1.  S ASUMK("CHGD")=0
  1.  I ASUMK("PULQTY") D
  1.  .I $P(ASUMK(0),U,2)'=ASUMK("ULQTY") S $P(ASUMK(0),U,2)=ASUMK("ULQTY"),ASUMK("CHGD")=1
  1.  F ASUMK("MO")=1:1:12 D
  1.  .I $P(ASUMK(1),U,ASUMK("MO"))'=ASUMK(ASUMK("MO"),"DOC") S $P(ASUMK(1),U,ASUMK("MO"))=ASUMK(ASUMK("MO"),"DOC"),ASUMK("CHGD")=1
  1.  .I $P(ASUMK(2),U,ASUMK("MO"))'=ASUMK(ASUMK("MO"),"QTY") S $P(ASUMK(2),U,ASUMK("MO"))=ASUMK(ASUMK("MO"),"QTY"),ASUMK("CHGD")=1
  1.  I $P(ASUMK(0),U,3)'=ASUMK("CFY","VAL") S $P(ASUMK(0),U,3)=ASUMK("CFY","VAL"),ASUMK("CHGD")=1
  1.  I $P(ASUMK(0),U,4)'=ASUMK("PFY","VAL") S $P(ASUMK(0),U,4)=ASUMK("PFY","VAL"),ASUMK("CHGD")=1
  1.  I $P(ASUMK(0),U,5)'=ASUMK("PPY","VAL") S $P(ASUMK(0),U,5)=ASUMK("PPY","VAL"),ASUMK("CHGD")=1
  1.  I ASUMK("CHGD") D
  1.  .I $D(^ASUMY(ASUMK("E#","REQ"),0)) D
  1.  ..S DA=ASUMK("E#","REQ"),DIK="^ASUMK(" D ^DIK ;Delete old record and xrefs
  1.  .S ^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"),0)=ASUMK(0)
  1.  .S ^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"),1)=ASUMK(1)
  1.  .S ^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,ASUMK("E#","IDX"),2)=ASUMK(2)
  1.  .S DA=ASUMK("E#","REQ"),DIK="^ASUMK(" D IX^DIK ;Re xref new record
  1.  Q:$G(ASUMK("NOKL"))
  1.  K ASUMK
  1.  Q
  1. WRITE(X) ;EP ;WITH PARAMETER PASSING
  1.  S ASUMK("E#","REQ")=X
  1.  G EN1
  1.  Q
  1. STA(X) ;EP ; DIRECT STA LOOKUP
  1.  I X?5N D STA^ASULARST(.X) Q:Y<0
  1.  I $D(^ASUMK(X,0)) D
  1.  .S (Y,ASUMK("E#","STA"))=X ;Record found for input parameter
  1.  E  D
  1.  .S ASUMK("E#","STA")=X ;IEN to use for LAYGO call
  1.  .S Y=0 ;No record found for Input parameter
  1.  Q
  1. REQ(X) ;EP ; DIRECT USER LOOKUP -MUST HAVE IEN FOR SUBSTATION
  1.  I $G(ASUMK("E#","STA"))']"" S Y=-10 Q  ;Station IEN not passed
  1.  I X'?9N D REQ^ASULDIRR(.X) Q:Y<0
  1.  I $D(^ASUMK(ASUMK("E#","STA"),1,X,0)) D
  1.  .S (Y,ASUMK("E#","REQ"))=X ;Record found for input parameter
  1.  E  D
  1.  .S ASUMK("E#","REQ")=X ;IEN to use for LAYGO call
  1.  .S Y=0 ;No record found for Input parameter
  1.  Q
  1. IDX(X) ;EP ; DIRECT INDEX LOOKUP -MUST HAVE IEN FOR SST & USR
  1.  I $G(ASUMK("E#","STA"))']"" S Y=-10 Q  ;Sub Station IEN not passed
  1.  I $G(ASUMK("E#","REQ"))']"" S Y=-11 Q  ;Usr IEN not passed
  1.  I X?1N.N D DIX^ASUMDIRM(.X) Q:Y<0
  1.  I $D(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,X,0)) D
  1.  .S (Y,ASUMK("E#","IDX"))=X ;Record found for input parameter
  1.  E  D
  1.  .S ASUMK("E#","IDX")=X ;IEN to use for LAYGO call
  1.  .S Y=0 ;No record found for Input parameter
  1.  Q
  1. ADDSTA(X) ;EP ; DIRECT STATION ADD
  1.  ;Error conditions passed back in 'Y'
  1.  ;  -7 : IEN not for Area signed into KERNEL with (DUZ 2)
  1.  ;  -8 : Failed IEN edit
  1.  ;  -10 : Station IEN Index to be added to not in ASUMS variable
  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 $E(X,1,2)'=ASUL(1,"AR","AP") S Y=-7 Q  ;Not for Area Signed on as
  1.  I X'?5N S Y=-8 Q  ;Failed IEN edit
  1.  I $D(^ASUMK(X,0)) S Y=0 Q  ;Station already on file
  1.  S ASUMK("E#","STA")=X
  1.  S ^ASUMK(X,0)=X ;Pointer to Station table
  1.  S ^ASUMK(X,1,0)="^9002033.02PA"
  1.  ;Add one to the count of Stations
  1.  S $P(^ASUMK(0),U,4)=$P(^ASUMK(0),U,4)+1
  1.  ;Set last Station updated piece
  1.  S $P(^ASUMK(0),U,3)=X
  1.  S DA=X
  1.  S DIK="^ASUMK("
  1.  D IX^DIK K DIK,DA
  1.  Q
  1. ADDREQ(X) ;EP ; DIRECT USER ADD -MUST HAVE IEN FOR SUBSTATION
  1.  I $G(ASUMK("E#","STA"))']"" S Y=-10 Q  ;Station IEN not available
  1.  I $L(X)=4 S X=$G(ASUL(2,"E#","SST"))_X
  1.  I $E(X,1,2)'=ASUL(1,"AR","AP") S Y=-7 Q  ;Not for Area Signed on as
  1.  I X'?9N S Y=-8 Q  ;Failed IEN edit
  1.  I $D(^ASUMK(ASUMK("E#","STA"),1,X,0)) S Y=0 Q  ;Requsitioner on file
  1.  S ASUMK("E#","REQ")=X
  1.  S ^ASUMK(ASUMK("E#","STA"),1,X,0)=X
  1.  S ^ASUMK(ASUMK("E#","STA"),1,X,1,0)="^9002033.21PA"
  1.  ;Add one to the count of Requsitioner for this Station
  1.  S $P(^ASUMK(ASUMK("E#","STA"),1,0),U,4)=$P(^ASUMK(ASUMK("E#","STA"),1,0),U,4)+1
  1.  ;Set last Requsitioner updated piece
  1.  S $P(^ASUMK(ASUMK("E#","STA"),1,0),U,3)=X
  1.  S DA=X,DA(1)=ASUMK("E#","STA")
  1.  S DIK="^ASUMK(DA(1),1,"
  1.  D IX^DIK K DIK,DA
  1.  Q
  1. ADDIDX(X) ;EP ; DIRECT INDEX ADD -MUST HAVE IEN FOR STA & REQ
  1.  I $G(ASUMK("E#","STA"))']"" S Y=-10 Q  ;Station IEN not available
  1.  I $G(ASUMK("E#","REQ"))']"" S Y=-11 Q  ;Requsitioner IEN not available
  1.  I X'?1N.N D DIX^ASUMDIRM(.X) Q:Y<0
  1.  S ASUMK("E#","IDX")=X
  1.  I $D(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,X,0)) S Y=0 Q  ;IDX on file
  1.  S ^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,X,0)=X
  1.  S ^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,X,1)=""
  1.  S ^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,X,2)=""
  1.  S $P(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,0),U,4)=$P(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,0),U,4)+1 ;Add one to the count of IDX for this Requsitioner
  1.  S $P(^ASUMK(ASUMK("E#","STA"),1,ASUMK("E#","REQ"),1,0),U,3)=X ;Set last IDX updated piece
  1.  S DA=X,DA(1)=ASUMK("E#","REQ"),DA(2)=ASUMK("E#","STA")
  1.  S DIK="^ASUMK(DA(2),1,DA(1),1,"
  1.  D IX^DIK K DIK,DA
  1.  Q