- ASULDIRA ; IHS/ITSC/LMH -DIRECT ADD TABLE RECORD ;
- ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- ;This routine is a utility which provides entry points to add new
- ;entries into SAMS tables.
- SST(X) ;EP ; ADD NEW RECORD SUB STATION TABLE
- ;Error conditions passed back in 'Y'
- ; -1 : Failed IEN edit
- ; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
- K Y
- I X["PL" S X=999,X(1)="OEH 121 PROJECTS"
- 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 X(1)=$P($G(^ASUL(2,X,0)),U) S:X(1)']"" X(1)="UNKNOWN"
- S ^ASUL(18,X,0)=X(1)_U_$E(X,1,2)
- S ^ASUL(18,X,1)=$S($E(X,3,5)=999:"PL",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
- D SST^ASULDIRR(X)
- S DA=X,DIK="^ASUL(18," D IX^DIK K DIK,DA
- Q
- USR(X) ;EP ; ADD NEW RECORD USER TABLE
- ;Error conditions passed back in 'Y'
- ; -1 : Failed IEN edit
- ; -2 : IEN not for Area signed into KERNEL with (DUZ 2)
- K Y
- I $L(X)=3 S ASUL(19,"USR")=X D USR^ASULALGO(.X) 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
- S X(2)=$E(X,3,4) S:X(2)="00" X(2)=100
- I $G(^ASUL(22,+(X(2)),0))']"" S Y=-4 Q ;Not valid Program code
- I X'?6N S Y=-1 Q ;Failed IEN edit
- I $G(X(1))="" S X(1)=$G(ASUL(22,"PGM","NM")) S:X(1)']"" X(1)="UNKNOWN"
- S ^ASUL(19,X,0)=X(1)_U_ASUL(1,"AR","AP")_U_+($E(X,3,4))
- S ^ASUL(19,X,1)=ASUL(19,"USR")
- S $P(^ASUL(19,0),U,4)=$P(^ASUL(19,0),U,4)+1 ;Add one to User count
- S $P(^ASUL(19,0),U,3)=X ;Set last User updated piece
- D USR^ASULDIRR(X)
- S DA=X,DIK="^ASUL(19," D IX^DIK K DIK,DA
- Q
- REQ(X) ;EP ; ADD NEW RECORD REQUSITIONER TABLE
- ;Error conditions passed back in 'Y'
- ; -11 : Failed IEN edit
- ; -12 : IEN not for Area signed into KERNEL with (DUZ 2)
- K Y
- I $G(ASUL(18,"SST","E#"))']"" D
- .I X?9N D
- ..S ASUL(18,"SST","E#")=$E(X,1,5) D SST(ASUL(18,"SST","E#")) Q:Y>0
- ..S ASUL(19,"USR","E#")=$E(X,1,2)_$E(X,6,0) D USR(ASUL(19,"SST","E#")) Q:Y>0
- .E D
- ..S Y=-14 Q
- I $L(X)=3 D Q:+Y<0 S X=ASUL(18,"SST","E#")_$E(ASUL(19,"USR","E#"),3,6)
- .D USR^ASULDIRR(X)
- ;I $E(X,1,2)'=ASUL(1,"AR","AP") S Y=-12 Q ;Not for Area Signed on as
- I X'?9N S Y=-11 Q ;Failed IEN edit
- I $G(X(1))="" S X(1)=ASUL(19,"USR","NM")_" @ "_ASUL(18,"SST","NM")
- S ^ASUL(20,X,0)=X(1)_U_ASUL(19,"USR","E#")_U_ASUL(18,"SST","E#")_U_ASUL(1,"AR","AP")
- ;The following line put something into the 2nd piece which is not
- ;defined in the DD. The Var X(3) does seem to get defined during the
- ;running of the conversion.
- S ^ASUL(20,X,1)=$S($G(X(3))]"":X(3),ASUL(1,"AR","AP")=59:2,1:"1.5")
- ;Add one to the count of requsitioners
- S $P(^ASUL(20,0),U,4)=$P(^ASUL(20,0),U,4)+1
- ;Set last requsitioner updated piece
- S $P(^ASUL(20,0),U,3)=X
- ;S ^ASUL(20,X,2,0)="9002039.2I^0^0" ;LMH 2/22/2000
- D REQ^ASULDIRR(X)
- S DA=X,DIK="^ASUL(20," D IX^DIK K DIK,DA
- Q
- ASULDIRA ; IHS/ITSC/LMH -DIRECT ADD TABLE RECORD ;
- +1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
- +2 ;This routine is a utility which provides entry points to add new
- +3 ;entries into SAMS tables.
- SST(X) ;EP ; ADD NEW RECORD SUB STATION TABLE
- +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 KILL Y
- +5 IF X["PL"
- SET X=999
- SET X(1)="OEH 121 PROJECTS"
- +6 IF $LENGTH(X)=3
- SET X=ASUL(1,"AR","AP")_X
- +7 IF $LENGTH(X)=2
- SET X=ASUL(1,"AR","AP")_"0"_X
- +8 ;I $E(X,1,2)'=ASUL(1,"AR","AP") S Y=-2 Q ;Not for Area Signed on as
- +9 ;Failed IEN edit
- IF X'?5N
- SET Y=-1
- QUIT
- +10 IF $GET(X(1))=""
- SET X(1)=$PIECE($GET(^ASUL(2,X,0)),U)
- IF X(1)']""
- SET X(1)="UNKNOWN"
- +11 SET ^ASUL(18,X,0)=X(1)_U_$EXTRACT(X,1,2)
- +12 SET ^ASUL(18,X,1)=$SELECT($EXTRACT(X,3,5)=999:"PL",1:$EXTRACT(X,4,5))
- +13 ;Add one to the count of Sub Stations
- +14 SET $PIECE(^ASUL(18,0),U,4)=$PIECE(^ASUL(18,0),U,4)+1
- +15 ;Set last sub station updated piece
- +16 SET $PIECE(^ASUL(18,0),U,3)=X
- +17 DO SST^ASULDIRR(X)
- +18 SET DA=X
- SET DIK="^ASUL(18,"
- DO IX^DIK
- KILL DIK,DA
- +19 QUIT
- USR(X) ;EP ; ADD NEW RECORD USER TABLE
- +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 KILL Y
- +5 IF $LENGTH(X)=3
- SET ASUL(19,"USR")=X
- DO USR^ASULALGO(.X)
- SET X=ASUL(1,"AR","AP")_X
- +6 ;Not for Area Signed on as
- IF $EXTRACT(X,1,2)'=ASUL(1,"AR","AP")
- SET Y=-2
- QUIT
- +7 SET X(2)=$EXTRACT(X,3,4)
- IF X(2)="00"
- SET X(2)=100
- +8 ;Not valid Program code
- IF $GET(^ASUL(22,+(X(2)),0))']""
- SET Y=-4
- QUIT
- +9 ;Failed IEN edit
- IF X'?6N
- SET Y=-1
- QUIT
- +10 IF $GET(X(1))=""
- SET X(1)=$GET(ASUL(22,"PGM","NM"))
- IF X(1)']""
- SET X(1)="UNKNOWN"
- +11 SET ^ASUL(19,X,0)=X(1)_U_ASUL(1,"AR","AP")_U_+($EXTRACT(X,3,4))
- +12 SET ^ASUL(19,X,1)=ASUL(19,"USR")
- +13 ;Add one to User count
- SET $PIECE(^ASUL(19,0),U,4)=$PIECE(^ASUL(19,0),U,4)+1
- +14 ;Set last User updated piece
- SET $PIECE(^ASUL(19,0),U,3)=X
- +15 DO USR^ASULDIRR(X)
- +16 SET DA=X
- SET DIK="^ASUL(19,"
- DO IX^DIK
- KILL DIK,DA
- +17 QUIT
- REQ(X) ;EP ; ADD NEW RECORD REQUSITIONER TABLE
- +1 ;Error conditions passed back in 'Y'
- +2 ; -11 : Failed IEN edit
- +3 ; -12 : IEN not for Area signed into KERNEL with (DUZ 2)
- +4 KILL Y
- +5 IF $GET(ASUL(18,"SST","E#"))']""
- Begin DoDot:1
- +6 IF X?9N
- Begin DoDot:2
- +7 SET ASUL(18,"SST","E#")=$EXTRACT(X,1,5)
- DO SST(ASUL(18,"SST","E#"))
- IF Y>0
- QUIT
- +8 SET ASUL(19,"USR","E#")=$EXTRACT(X,1,2)_$EXTRACT(X,6,0)
- DO USR(ASUL(19,"SST","E#"))
- IF Y>0
- QUIT
- End DoDot:2
- +9 IF '$TEST
- Begin DoDot:2
- +10 SET Y=-14
- QUIT
- End DoDot:2
- End DoDot:1
- +11 IF $LENGTH(X)=3
- Begin DoDot:1
- +12 DO USR^ASULDIRR(X)
- End DoDot:1
- IF +Y<0
- QUIT
- SET X=ASUL(18,"SST","E#")_$EXTRACT(ASUL(19,"USR","E#"),3,6)
- +13 ;I $E(X,1,2)'=ASUL(1,"AR","AP") S Y=-12 Q ;Not for Area Signed on as
- +14 ;Failed IEN edit
- IF X'?9N
- SET Y=-11
- QUIT
- +15 IF $GET(X(1))=""
- SET X(1)=ASUL(19,"USR","NM")_" @ "_ASUL(18,"SST","NM")
- +16 SET ^ASUL(20,X,0)=X(1)_U_ASUL(19,"USR","E#")_U_ASUL(18,"SST","E#")_U_ASUL(1,"AR","AP")
- +17 ;The following line put something into the 2nd piece which is not
- +18 ;defined in the DD. The Var X(3) does seem to get defined during the
- +19 ;running of the conversion.
- +20 SET ^ASUL(20,X,1)=$SELECT($GET(X(3))]"":X(3),ASUL(1,"AR","AP")=59:2,1:"1.5")
- +21 ;Add one to the count of requsitioners
- +22 SET $PIECE(^ASUL(20,0),U,4)=$PIECE(^ASUL(20,0),U,4)+1
- +23 ;Set last requsitioner updated piece
- +24 SET $PIECE(^ASUL(20,0),U,3)=X
- +25 ;S ^ASUL(20,X,2,0)="9002039.2I^0^0" ;LMH 2/22/2000
- +26 DO REQ^ASULDIRR(X)
- +27 SET DA=X
- SET DIK="^ASUL(20,"
- DO IX^DIK
- KILL DIK,DA
- +28 QUIT