ASUMDIRA ; IHS/ITSC/LMH -DIRECT ADD RECORD ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine is a utility which provides entry points to verify and
;assign internal entry numbers and add new entries into SAMS Station
;(in ^ASUMS) and Index (in ^ASUMX) Master files and the Sub Station
;table (in ^ASUL(18)).
DIS(X) ;EP ; ADD NEW RECORD STATION MASTER
;Error conditions passed back in 'Y'
; -1 : Failed IEN edit
; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
I $G(X)']"" S X=$G(ASUL(2,"STA","E#"))
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=-2 Q ;Not for Area Signed on as
I X'?5N S Y=-1 Q ;Failed IEN edit
S ^ASUMS(X,0)=X_U_$E(X,1,2)
S ^ASUMS(X,1,0)="^9002031.02PA^"
;Add one to the count of Stations
S $P(^ASUMS(0),U,4)=$P(^ASUMS(0),U,4)+1
;Set last station updated piece
S $P(^ASUMS(0),U,3)=X
S DA=X,DIK="^ASUMS(" D IX^DIK K DIK,DA
S Y=+X
Q
SST(X) ;EP ; ADD NEW RECORD SUB STATION
;Error conditions passed back in 'Y'
; -1 : Failed IEN edit
; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
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=-2 Q ;Not for Area Signed on as
I X'?5N S Y=-1 Q ;Failed IEN edit
I $G(X(1))="" S Y=-3 Q
S ^ASUL(18,X,0)=X(1)_U_$E(X,1,2)
S ^ASUL(18,X,1)=$E(X,4,5)
;Add one to the count of Sub Stations
S $P(^ASUL(18,0),U,4)=$P(^ASUL(18,0),U,4)+1
;Set last sub station updated piece
S $P(^ASUL(18,0),U,3)=X
S DA=X,DIK="^ASUL(18," D IX^DIK K DIK,DA
Q
DISX(X) ;EP ; ADD NEW RECORD STATION MASTER
;Error conditions passed back in 'Y'
; -1 : Failed IEN edit
; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
; -3 : No Index Master found for Index # add requested for
; -4 : Station Index master already on file
; -7 : Station IEN Index to be added to not in ASUMS variable
; -9 : Index # requested was assigned to a deleted item not yet
; available for re-use
I '$D(ASUMS("E#","STA")) S ASUMS("E#","STA")=$G(ASUL(2,"STA","E#"))
I $L(X)=6 S X=ASUL(1,"AR","AP")_X
I $E(X,1,2)'=ASUL(1,"AR","AP") S Y=-2 Q ;Not for Area Signed on as
I X'?8N S Y=-1 Q ;Failed IEN edit
I '$D(^ASUMX(X,0)) S Y=-3 Q ;No Index master
I $P(^ASUMX(X,0),U)']"" S Y=-8 Q ;Deleted Index master
I $D(^ASUMS(ASUMS("E#","STA"),1,X,0)) D Q:Y<0
.I $P(^ASUMS(ASUMS("E#","STA"),1,X,0),U)[999999 D ;Deleted Station Index
..I ASUK("DT","YRMO")-$P(^ASUMS(ASUMS("E#","STA"),1,X,0),U,2)<300 S Y=-9
..E K ^ASUMS(ASUMS("E#","STA"),1,X)
.E S Y=-4 ;Station Index master already on file
S ASUMS("E#","IDX")=X
S ^ASUMS(ASUMS("E#","STA"),1,X,0)=X,^ASUMS(ASUMS("E#","STA"),1,X,1,0)="^9002031.232A^12^12",^ASUMS(ASUMS("E#","STA"),1,X,2)=""
F V=0:1:12 S ^ASUMS(ASUMS("E#","STA"),1,X,1,V,0)=V
;Add one to the count of index records for this Station
S $P(^ASUMS(ASUMS("E#","STA"),1,0),U,4)=$P(^ASUMS(ASUMS("E#","STA"),1,0),U,4)+1
;Set last index updated piece
S $P(^ASUMS(ASUMS("E#","STA"),1,0),U,3)=X
S DA=X,DA(1)=ASUMS("E#","STA"),DIK="^ASUMS(DA(1),1," D IX^DIK K DIK,DA
Q
DIX(Z) ;EP ; ADD NEW RECORD INDEX MASTER
;Error conditions passed back in 'Y'
; -1 : Failed IEN edit
; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
N X
S X=$G(Z(Z,"PT","IDX"))
I X="" D
.S X=Z(Z,"AR")_Z(Z,"IDX")
;S X=Z(Z,"IDX") S:X']"" X=Z(Z,"PT","IDX")
;I $L(X)=6 S X=ASUL(1,"AR","AP")_X
I $E(X,1,2)'=ASUL(1,"AR","AP") S Y=-2 Q
I X'?8N S Y=-1 Q
S ^ASUMX(X,0)=Z(Z,"IDX")_U_Z(Z,"DESC")_U_Z(Z,"BCD")_U_Z(Z,"AR U/I")_U_Z(Z,"NSN")_U_Z(Z,"ACC")_U_Z(Z,"SOBJ")_U_Z(Z,"CAT")_U_Z(Z,"DTS")_U_U_Z(Z,"AR")
S ^ASUMX(X,2)=U_U_U_U_Z(Z,"PT","ACC")_U_Z(Z,"PT","SOBJ")_U_Z(Z,"PT","CAT")
;Add one to the count of index records
S $P(^ASUMX(0),U,4)=$P(^ASUMX(0),U,4)+1
;Set last index updated piece
S $P(^ASUMX(0),U,3)=X
S DA=X,DIK="^ASUMX(" D IX^DIK K DIK,DA
Q
ASUMDIRA ; IHS/ITSC/LMH -DIRECT ADD RECORD ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine is a utility which provides entry points to verify and
+3 ;assign internal entry numbers and add new entries into SAMS Station
+4 ;(in ^ASUMS) and Index (in ^ASUMX) Master files and the Sub Station
+5 ;table (in ^ASUL(18)).
DIS(X) ;EP ; ADD NEW RECORD STATION MASTER
+1 ;Error conditions passed back in 'Y'
+2 ; -1 : Failed IEN edit
+3 ; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
+4 IF $GET(X)']""
SET X=$GET(ASUL(2,"STA","E#"))
+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=-2
QUIT
+8 ;Failed IEN edit
IF X'?5N
SET Y=-1
QUIT
+9 SET ^ASUMS(X,0)=X_U_$EXTRACT(X,1,2)
+10 SET ^ASUMS(X,1,0)="^9002031.02PA^"
+11 ;Add one to the count of Stations
+12 SET $PIECE(^ASUMS(0),U,4)=$PIECE(^ASUMS(0),U,4)+1
+13 ;Set last station updated piece
+14 SET $PIECE(^ASUMS(0),U,3)=X
+15 SET DA=X
SET DIK="^ASUMS("
DO IX^DIK
KILL DIK,DA
+16 SET Y=+X
+17 QUIT
SST(X) ;EP ; ADD NEW RECORD SUB STATION
+1 ;Error conditions passed back in 'Y'
+2 ; -1 : Failed IEN edit
+3 ; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
+4 IF $LENGTH(X)=3
SET X=ASUL(1,"AR","AP")_X
+5 IF $LENGTH(X)=2
SET X=ASUL(1,"AR","AP")_"0"_X
+6 ;Not for Area Signed on as
IF $EXTRACT(X,1,2)'=ASUL(1,"AR","AP")
SET Y=-2
QUIT
+7 ;Failed IEN edit
IF X'?5N
SET Y=-1
QUIT
+8 IF $GET(X(1))=""
SET Y=-3
QUIT
+9 SET ^ASUL(18,X,0)=X(1)_U_$EXTRACT(X,1,2)
+10 SET ^ASUL(18,X,1)=$EXTRACT(X,4,5)
+11 ;Add one to the count of Sub Stations
+12 SET $PIECE(^ASUL(18,0),U,4)=$PIECE(^ASUL(18,0),U,4)+1
+13 ;Set last sub station updated piece
+14 SET $PIECE(^ASUL(18,0),U,3)=X
+15 SET DA=X
SET DIK="^ASUL(18,"
DO IX^DIK
KILL DIK,DA
+16 QUIT
DISX(X) ;EP ; ADD NEW RECORD STATION MASTER
+1 ;Error conditions passed back in 'Y'
+2 ; -1 : Failed IEN edit
+3 ; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
+4 ; -3 : No Index Master found for Index # add requested for
+5 ; -4 : Station Index master already on file
+6 ; -7 : Station IEN Index to be added to not in ASUMS variable
+7 ; -9 : Index # requested was assigned to a deleted item not yet
+8 ; available for re-use
+9 IF '$DATA(ASUMS("E#","STA"))
SET ASUMS("E#","STA")=$GET(ASUL(2,"STA","E#"))
+10 IF $LENGTH(X)=6
SET X=ASUL(1,"AR","AP")_X
+11 ;Not for Area Signed on as
IF $EXTRACT(X,1,2)'=ASUL(1,"AR","AP")
SET Y=-2
QUIT
+12 ;Failed IEN edit
IF X'?8N
SET Y=-1
QUIT
+13 ;No Index master
IF '$DATA(^ASUMX(X,0))
SET Y=-3
QUIT
+14 ;Deleted Index master
IF $PIECE(^ASUMX(X,0),U)']""
SET Y=-8
QUIT
+15 IF $DATA(^ASUMS(ASUMS("E#","STA"),1,X,0))
Begin DoDot:1
+16 ;Deleted Station Index
IF $PIECE(^ASUMS(ASUMS("E#","STA"),1,X,0),U)[999999
Begin DoDot:2
+17 IF ASUK("DT","YRMO")-$PIECE(^ASUMS(ASUMS("E#","STA"),1,X,0),U,2)<300
SET Y=-9
+18 IF '$TEST
KILL ^ASUMS(ASUMS("E#","STA"),1,X)
End DoDot:2
+19 ;Station Index master already on file
IF '$TEST
SET Y=-4
End DoDot:1
IF Y<0
QUIT
+20 SET ASUMS("E#","IDX")=X
+21 SET ^ASUMS(ASUMS("E#","STA"),1,X,0)=X
SET ^ASUMS(ASUMS("E#","STA"),1,X,1,0)="^9002031.232A^12^12"
SET ^ASUMS(ASUMS("E#","STA"),1,X,2)=""
+22 FOR V=0:1:12
SET ^ASUMS(ASUMS("E#","STA"),1,X,1,V,0)=V
+23 ;Add one to the count of index records for this Station
+24 SET $PIECE(^ASUMS(ASUMS("E#","STA"),1,0),U,4)=$PIECE(^ASUMS(ASUMS("E#","STA"),1,0),U,4)+1
+25 ;Set last index updated piece
+26 SET $PIECE(^ASUMS(ASUMS("E#","STA"),1,0),U,3)=X
+27 SET DA=X
SET DA(1)=ASUMS("E#","STA")
SET DIK="^ASUMS(DA(1),1,"
DO IX^DIK
KILL DIK,DA
+28 QUIT
DIX(Z) ;EP ; ADD NEW RECORD INDEX MASTER
+1 ;Error conditions passed back in 'Y'
+2 ; -1 : Failed IEN edit
+3 ; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
+4 NEW X
+5 SET X=$GET(Z(Z,"PT","IDX"))
+6 IF X=""
Begin DoDot:1
+7 SET X=Z(Z,"AR")_Z(Z,"IDX")
End DoDot:1
+8 ;S X=Z(Z,"IDX") S:X']"" X=Z(Z,"PT","IDX")
+9 ;I $L(X)=6 S X=ASUL(1,"AR","AP")_X
+10 IF $EXTRACT(X,1,2)'=ASUL(1,"AR","AP")
SET Y=-2
QUIT
+11 IF X'?8N
SET Y=-1
QUIT
+12 SET ^ASUMX(X,0)=Z(Z,"IDX")_U_Z(Z,"DESC")_U_Z(Z,"BCD")_U_Z(Z,"AR U/I")_U_Z(Z,"NSN")_U_Z(Z,"ACC")_U_Z(Z,"SOBJ")_U_Z(Z,"CAT")_U_Z(Z,"DTS")_U_U_Z(Z,"AR")
+13 SET ^ASUMX(X,2)=U_U_U_U_Z(Z,"PT","ACC")_U_Z(Z,"PT","SOBJ")_U_Z(Z,"PT","CAT")
+14 ;Add one to the count of index records
+15 SET $PIECE(^ASUMX(0),U,4)=$PIECE(^ASUMX(0),U,4)+1
+16 ;Set last index updated piece
+17 SET $PIECE(^ASUMX(0),U,3)=X
+18 SET DA=X
SET DIK="^ASUMX("
DO IX^DIK
KILL DIK,DA
+19 QUIT
