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