ASUUSCRN ; IHS/ITSC/LMH -GENERIC SCREEN FOR AREA ROUTINE ; [ 07/18/2000 7:23 AM ]
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine provides screening logic for internal record numbers
;(E#) for all SAMS files which has them defined as requiring an
;Area's Accounting Point as the first two digits.
;IHS/ITSC/MRS 7/17/2000-Modified to return DUZ(2) unchanged from DUZ(2)
; sub-routine. No exit flag needs to be set at this point.
EN1 ;EP ;PRIMARY ENTRY POINT
;W !,"Now in Screening routine - X = ",$G(X)," Y = ",$G(Y)
D:'$D(DUZ(2)) AREA Q:'$D(ASUL(1))
I '$D(ASUL(1,"AR","AP")) D
.S:$D(X) X("OLD")=X
.D SETAREA^ASULARST
.S:$D(X("OLD")) X=X("OLD")
.K X("OLD")
I ASUL(1,"AR","WHSE")=3 S X("INDR")="I 1" G TEST ;Regional Warehouse may look at all areas
I $D(Y) D G TEST
.I $E(Y,1,2)=ASUL(1,"AR","AP") D
..S X("INDR")="I 1"
.E D
..S X("INDR")="I 0"
S DIC("S")=$G(DO("SCR")) K:DIC("S")']"" DIC("S")
D
.I $D(X) D
..I $E(X,1,2)=ASUL(1,"AR","AP") S X("INDR")="I 1"
.E D
..S X("INDR")="I 0"
AREA ;ALSO LOCAL ENTRY FROM EN1 IF '$D(DUZ(2))
N Z
S Z=$P($G(^ASUSITE(1,0)),U) I Z]"" D Q:'$D(DUZ(2))
.D DUZ(Z)
E D
.W !,"No Site file entry"
D ARE^ASULARST(Z) W:'$D(ASUL(1)) !,"Not able to find Area"
Q
DUZ(X) ;
;Modified to return DUZ(2) unchanged
;No exit flag apparently needs to be set at this point MRS:7/17/2000
Q
;N Y
;S Y(1)=$O(^AUTTLOC("C",X_"0000")) I Y(1)]"" D
;.S Y=$O(^AUTTLOC("C",Y(1),"")) S DUZ(2)=Y
;Q
SST(Y) ;EP ;PASSING X
D EN1
K:'$T Y
Q
IDX ;EP ;FOR INDEX NUMBER
I $D(X) I X["999999" S X("INDR")="I 0" G TEST
G EN1
TEST ;
X X("INDR") K X("INDR")
Q
ARE ;EP ;REGIONAL CHECK
Q:ASUL(1,"AR","WHSE")=3 ;Regional Warehouse may look at all areas
S DO("SCR")="I $P(^(0),U,2)'=$G(ASUL(1,""AR"",""AP"")"
Q
CHK() ;EP;CALLED BY; ^DD(9002039.18
;KERNEL ONLY
N Y
S Y=''$D(DUZ(2))
I 'Y W !,*7,"Use SAMS package menu options, not VA Fileman"
Q Y
;
SCR(X) ;EP;CALLED BY; ^DD(9002039.18 ;ASUTBL SUB STATION ;SCREEN FOR AREA
N Y,Z
Q:'$D(ASUL(1)) 0
Q:$G(ASUL(1,"AR","WHSE"))=3 1
I X?1N.N Q:$G(ASUL(1,"AR","AP"))'=$E(X,1,2) 0
Q 1
;
FSCR() ;EP;CALLED BY; ^DD(9002031; ASUMST STATION
;^DD(9002036; ASUHST HISTORY TRANSACTIONS
;^DD(9002036.1; ASUTRN DUE IN; ASUTRN DUE IS
;^DD(9002036.2; ASUTRN RECEIPTS
;^DD(9002036.3; ASUTRN ISSUES
;^DD(9002036.4; ASUTRN INDEX
;^DD(9002036.5; ASUTRN STATION
;^DD(9002036.6; ASUTRN ADJUSTMENT
;^DD(9002036.7; ASUTRN DIRECT ISSUE
;^DD(9002036.8; ASUJIB ISSUE BOOK
;^DD(9002039.01; ASUTBL AREA
;^DD(9002039.02; ASUTBL STATION
;^DD(9002039.18; ASUTBL SUB STATION
;^DD(9002039.19; ASUTBL USER
;^DD(9002039.21; ASUTBL BUDGET
; LOOKUP SCREEN MOST FILES
; SCREENS ENTRIES FROM LOOKUP, PRINT, INQUIRY, SEARCH AND OTHER
; ACTIONS
;
D:'$D(ASUL(1)) AREA Q:'$D(ASUL(1)) 0
Q:$G(ASUL(1,"AR","AP"))=65 1
Q:$G(ASUL(1,"AR","WHSE"))=3 1
Q:$P(^(0),U,2)'=$G(ASUL(1,"AR","AP")) 0
Q 1
FSCX() ;EP;^DD(9002032;ASUMST INDEX; LOOKUP SCREEN FOR INDEX MASTER
;
; SCREENS ENTRIES FROM LOOKUP, PRINT, INQUIRY, SEARCH AND OTHER
; ACTIONS
;
D:'$D(ASUL(1)) AREA Q:'$D(ASUL(1)) 0
Q:$G(ASUL(1,"AR","WHSE"))=3 1
S:$P(^(0),U,11)']"" $P(^(0),U,11)=$E($G(Y),1,2)
Q:$P(^(0),U,11)'=$G(ASUL(1,"AR","AP")) 0
Q:$E($G(Y),3,8)=999999 0
Q 1
FSCU() ;EP;CALLED BY; ^DD(9002039.2; ASUTBL REQUSITIONER
;-- LOOKUP SCREEN FOR REQUSITIONER FILE
;
; SCREENS ENTRIES FROM LOOKUP, PRINT, INQUIRY, SEARCH AND OTHER
; ACTIONS
;
D:'$D(ASUL(1)) AREA Q:'$D(ASUL(1)) 0
Q:$G(ASUL(1,"AR","WHSE"))=3 1
Q:$P(^(0),U,4)'=$G(ASUL(1,"AR","AP")) 0
Q 1
ASUUSCRN ; IHS/ITSC/LMH -GENERIC SCREEN FOR AREA ROUTINE ; [ 07/18/2000 7:23 AM ]
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine provides screening logic for internal record numbers
+3 ;(E#) for all SAMS files which has them defined as requiring an
+4 ;Area's Accounting Point as the first two digits.
+5 ;IHS/ITSC/MRS 7/17/2000-Modified to return DUZ(2) unchanged from DUZ(2)
+6 ; sub-routine. No exit flag needs to be set at this point.
EN1 ;EP ;PRIMARY ENTRY POINT
+1 ;W !,"Now in Screening routine - X = ",$G(X)," Y = ",$G(Y)
+2 IF '$DATA(DUZ(2))
DO AREA
IF '$DATA(ASUL(1))
QUIT
+3 IF '$DATA(ASUL(1,"AR","AP"))
Begin DoDot:1
+4 IF $DATA(X)
SET X("OLD")=X
+5 DO SETAREA^ASULARST
+6 IF $DATA(X("OLD"))
SET X=X("OLD")
+7 KILL X("OLD")
End DoDot:1
+8 ;Regional Warehouse may look at all areas
IF ASUL(1,"AR","WHSE")=3
SET X("INDR")="I 1"
GOTO TEST
+9 IF $DATA(Y)
Begin DoDot:1
+10 IF $EXTRACT(Y,1,2)=ASUL(1,"AR","AP")
Begin DoDot:2
+11 SET X("INDR")="I 1"
End DoDot:2
+12 IF '$TEST
Begin DoDot:2
+13 SET X("INDR")="I 0"
End DoDot:2
End DoDot:1
GOTO TEST
+14 SET DIC("S")=$GET(DO("SCR"))
IF DIC("S")']""
KILL DIC("S")
+15 Begin DoDot:1
+16 IF $DATA(X)
Begin DoDot:2
+17 IF $EXTRACT(X,1,2)=ASUL(1,"AR","AP")
SET X("INDR")="I 1"
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 SET X("INDR")="I 0"
End DoDot:2
End DoDot:1
AREA ;ALSO LOCAL ENTRY FROM EN1 IF '$D(DUZ(2))
+1 NEW Z
+2 SET Z=$PIECE($GET(^ASUSITE(1,0)),U)
IF Z]""
Begin DoDot:1
+3 DO DUZ(Z)
End DoDot:1
IF '$DATA(DUZ(2))
QUIT
+4 IF '$TEST
Begin DoDot:1
+5 WRITE !,"No Site file entry"
End DoDot:1
+6 DO ARE^ASULARST(Z)
IF '$DATA(ASUL(1))
WRITE !,"Not able to find Area"
+7 QUIT
DUZ(X) ;
+1 ;Modified to return DUZ(2) unchanged
+2 ;No exit flag apparently needs to be set at this point MRS:7/17/2000
+3 QUIT
+4 ;N Y
+5 ;S Y(1)=$O(^AUTTLOC("C",X_"0000")) I Y(1)]"" D
+6 ;.S Y=$O(^AUTTLOC("C",Y(1),"")) S DUZ(2)=Y
+7 ;Q
SST(Y) ;EP ;PASSING X
+1 DO EN1
+2 IF '$TEST
KILL Y
+3 QUIT
IDX ;EP ;FOR INDEX NUMBER
+1 IF $DATA(X)
IF X["999999"
SET X("INDR")="I 0"
GOTO TEST
+2 GOTO EN1
TEST ;
+1 XECUTE X("INDR")
KILL X("INDR")
+2 QUIT
ARE ;EP ;REGIONAL CHECK
+1 ;Regional Warehouse may look at all areas
IF ASUL(1,"AR","WHSE")=3
QUIT
+2 SET DO("SCR")="I $P(^(0),U,2)'=$G(ASUL(1,""AR"",""AP"")"
+3 QUIT
CHK() ;EP;CALLED BY; ^DD(9002039.18
+1 ;KERNEL ONLY
+2 NEW Y
+3 SET Y=''$DATA(DUZ(2))
+4 IF 'Y
WRITE !,*7,"Use SAMS package menu options, not VA Fileman"
+5 QUIT Y
+6 ;
SCR(X) ;EP;CALLED BY; ^DD(9002039.18 ;ASUTBL SUB STATION ;SCREEN FOR AREA
+1 NEW Y,Z
+2 IF '$DATA(ASUL(1))
QUIT 0
+3 IF $GET(ASUL(1,"AR","WHSE"))=3
QUIT 1
+4 IF X?1N.N
IF $GET(ASUL(1,"AR","AP"))'=$EXTRACT(X,1,2)
QUIT 0
+5 QUIT 1
+6 ;
FSCR() ;EP;CALLED BY; ^DD(9002031; ASUMST STATION
+1 ;^DD(9002036; ASUHST HISTORY TRANSACTIONS
+2 ;^DD(9002036.1; ASUTRN DUE IN; ASUTRN DUE IS
+3 ;^DD(9002036.2; ASUTRN RECEIPTS
+4 ;^DD(9002036.3; ASUTRN ISSUES
+5 ;^DD(9002036.4; ASUTRN INDEX
+6 ;^DD(9002036.5; ASUTRN STATION
+7 ;^DD(9002036.6; ASUTRN ADJUSTMENT
+8 ;^DD(9002036.7; ASUTRN DIRECT ISSUE
+9 ;^DD(9002036.8; ASUJIB ISSUE BOOK
+10 ;^DD(9002039.01; ASUTBL AREA
+11 ;^DD(9002039.02; ASUTBL STATION
+12 ;^DD(9002039.18; ASUTBL SUB STATION
+13 ;^DD(9002039.19; ASUTBL USER
+14 ;^DD(9002039.21; ASUTBL BUDGET
+15 ; LOOKUP SCREEN MOST FILES
+16 ; SCREENS ENTRIES FROM LOOKUP, PRINT, INQUIRY, SEARCH AND OTHER
+17 ; ACTIONS
+18 ;
+19 IF '$DATA(ASUL(1))
DO AREA
IF '$DATA(ASUL(1))
QUIT 0
+20 IF $GET(ASUL(1,"AR","AP"))=65
QUIT 1
+21 IF $GET(ASUL(1,"AR","WHSE"))=3
QUIT 1
+22 IF $PIECE(^(0),U,2)'=$GET(ASUL(1,"AR","AP"))
QUIT 0
+23 QUIT 1
FSCX() ;EP;^DD(9002032;ASUMST INDEX; LOOKUP SCREEN FOR INDEX MASTER
+1 ;
+2 ; SCREENS ENTRIES FROM LOOKUP, PRINT, INQUIRY, SEARCH AND OTHER
+3 ; ACTIONS
+4 ;
+5 IF '$DATA(ASUL(1))
DO AREA
IF '$DATA(ASUL(1))
QUIT 0
+6 IF $GET(ASUL(1,"AR","WHSE"))=3
QUIT 1
+7 IF $PIECE(^(0),U,11)']""
SET $PIECE(^(0),U,11)=$EXTRACT($GET(Y),1,2)
+8 IF $PIECE(^(0),U,11)'=$GET(ASUL(1,"AR","AP"))
QUIT 0
+9 IF $EXTRACT($GET(Y),3,8)=999999
QUIT 0
+10 QUIT 1
FSCU() ;EP;CALLED BY; ^DD(9002039.2; ASUTBL REQUSITIONER
+1 ;-- LOOKUP SCREEN FOR REQUSITIONER FILE
+2 ;
+3 ; SCREENS ENTRIES FROM LOOKUP, PRINT, INQUIRY, SEARCH AND OTHER
+4 ; ACTIONS
+5 ;
+6 IF '$DATA(ASUL(1))
DO AREA
IF '$DATA(ASUL(1))
QUIT 0
+7 IF $GET(ASUL(1,"AR","WHSE"))=3
QUIT 1
+8 IF $PIECE(^(0),U,4)'=$GET(ASUL(1,"AR","AP"))
QUIT 0
+9 QUIT 1
