ACRFSYS ;IHS/OIRM/DSD/AEF/MRS - VARIOUS ARMS SYSTEM UTILITY SUBROUTINES [ 10/27/2004 4:18 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**13**;NOV 05, 2001
;NEW ROUTINE ACR*2.1*13.06
AREA(X) ;EP -- RETURNS INTERNAL AREA SYSTEM FOR FMS SUPPLIES AND SERVICES FILE
;
; Used by Function ACRFSSAREA, which is used by trigger on
; COMMON ACCOUNTING NUMBER field of FMS Supplies and Services file
; to trigger the AREA SYSTEM field.
;
; Input:
; X = IEN OF FMS SUPPLIES AND SERVICES FILE ENTRY
;
; Output:
; X = INTERNAL AREA IN FMS SYSTEM DEFAULTS FILE
;
I $P($G(^ACRSS(X,0)),U,5)="" S X="" Q X
I $P($G(^ACRCAN($P($G(^ACRSS(X,0)),U,5),0)),U,7)="" S X="" Q X
I $P($G(^AUTTLCOD($P($G(^ACRCAN($P($G(^ACRSS(X,0)),U,5),0)),U,7),0)),U,3)="" S X="" Q X
S X=$P($G(^AUTTACPT($P($G(^AUTTLCOD($P($G(^ACRCAN($P($G(^ACRSS(X,0)),U,5),0)),U,7),0)),U,3),0)),U,2)
S X=$O(^ACRSYS("B",X,0))
I 'X S X=""
Q X
;
SYS(X) ;EP -- RETURNS FMS SYSTEM DEFAULTS ENTRY IEN FOR PURCHASING OFFICE
;
; X = FMS PURCHASING OFFICE IEN
;
N Y
S Y=1
I 'X Q Y
I '$P($G(^ACRPO(X,0)),U,19) Q Y
S Y=$P(^ACRPO(X,0),U,19)
Q Y
;
ARMSDIR(X) ;EP;
;----- EXTRINSIC FUNCTION TO RETURN ARMS DEFAULT DIRECTORY FROM
; FMS SYSTEMS DEFAULTS FILE
; X= SYSTEM NUMBER IN FMS SYSTEM DEFAULT FILE CURRENTLY ALWAYS 1
; UNTIL SYSTEM BECOMES FULLY MULTIREGIONAL
; WRITES ERROR MESSAGE WHEN DIRECTORY PATH IS UNDEFINED IN
; ^ACRSYS(X,402),U,3)
;
N Y
S Y=$P($G(^ACRSYS(X,402)),U,3)
I Y']"" D
.W !?5,*7,"ARMS DIRECTORY IS UNDEFINED IN THE FMS SYSTEM DEFAULTS,"
.W ?5,"FILE, PLEASE NOTIFY ARMS MANAGER"
Q Y
;
ODDPATH(X) ;EP; EXTRINSIC FUNCTION
;RETURNS OPEN DOCUMENT EXPORT/IMPORT PATH NAME
; X= SYSTEM NUMBER IN FMS SYSTEM DEFAULT FILE
; CURRENTLY ALWAYS 1
; UNTIL SYSTEM BECOMES FULLY MULTIREGIONAL
;
N Y,Z
S Z=$P($G(^ACRSYS(X,301)),U)
I Z']"" D Q Z
.W !?5,*7,"OPEN DOCUMENT DOWNLOAD DIRECTORY IS UNDEFINED IN THE"
.W !?5,"FMS SYSTEM DEFAULTS FILE, PLEASE NOTIFY ARMS MANAGER"
D JCMD^ACRFUTL("cd "_Z,.Y)
I Y D
. W !,"No such directory "_Z
. S Z=""
. D PAUSE^ACRFWARN
Q Z
ACRFSYS ;IHS/OIRM/DSD/AEF/MRS - VARIOUS ARMS SYSTEM UTILITY SUBROUTINES [ 10/27/2004 4:18 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**13**;NOV 05, 2001
+2 ;NEW ROUTINE ACR*2.1*13.06
AREA(X) ;EP -- RETURNS INTERNAL AREA SYSTEM FOR FMS SUPPLIES AND SERVICES FILE
+1 ;
+2 ; Used by Function ACRFSSAREA, which is used by trigger on
+3 ; COMMON ACCOUNTING NUMBER field of FMS Supplies and Services file
+4 ; to trigger the AREA SYSTEM field.
+5 ;
+6 ; Input:
+7 ; X = IEN OF FMS SUPPLIES AND SERVICES FILE ENTRY
+8 ;
+9 ; Output:
+10 ; X = INTERNAL AREA IN FMS SYSTEM DEFAULTS FILE
+11 ;
+12 IF $PIECE($GET(^ACRSS(X,0)),U,5)=""
SET X=""
QUIT X
+13 IF $PIECE($GET(^ACRCAN($PIECE($GET(^ACRSS(X,0)),U,5),0)),U,7)=""
SET X=""
QUIT X
+14 IF $PIECE($GET(^AUTTLCOD($PIECE($GET(^ACRCAN($PIECE($GET(^ACRSS(X,0)),U,5),0)),U,7),0)),U,3)=""
SET X=""
QUIT X
+15 SET X=$PIECE($GET(^AUTTACPT($PIECE($GET(^AUTTLCOD($PIECE($GET(^ACRCAN($PIECE($GET(^ACRSS(X,0)),U,5),0)),U,7),0)),U,3),0)),U,2)
+16 SET X=$ORDER(^ACRSYS("B",X,0))
+17 IF 'X
SET X=""
+18 QUIT X
+19 ;
SYS(X) ;EP -- RETURNS FMS SYSTEM DEFAULTS ENTRY IEN FOR PURCHASING OFFICE
+1 ;
+2 ; X = FMS PURCHASING OFFICE IEN
+3 ;
+4 NEW Y
+5 SET Y=1
+6 IF 'X
QUIT Y
+7 IF '$PIECE($GET(^ACRPO(X,0)),U,19)
QUIT Y
+8 SET Y=$PIECE(^ACRPO(X,0),U,19)
+9 QUIT Y
+10 ;
ARMSDIR(X) ;EP;
+1 ;----- EXTRINSIC FUNCTION TO RETURN ARMS DEFAULT DIRECTORY FROM
+2 ; FMS SYSTEMS DEFAULTS FILE
+3 ; X= SYSTEM NUMBER IN FMS SYSTEM DEFAULT FILE CURRENTLY ALWAYS 1
+4 ; UNTIL SYSTEM BECOMES FULLY MULTIREGIONAL
+5 ; WRITES ERROR MESSAGE WHEN DIRECTORY PATH IS UNDEFINED IN
+6 ; ^ACRSYS(X,402),U,3)
+7 ;
+8 NEW Y
+9 SET Y=$PIECE($GET(^ACRSYS(X,402)),U,3)
+10 IF Y']""
Begin DoDot:1
+11 WRITE !?5,*7,"ARMS DIRECTORY IS UNDEFINED IN THE FMS SYSTEM DEFAULTS,"
+12 WRITE ?5,"FILE, PLEASE NOTIFY ARMS MANAGER"
End DoDot:1
+13 QUIT Y
+14 ;
ODDPATH(X) ;EP; EXTRINSIC FUNCTION
+1 ;RETURNS OPEN DOCUMENT EXPORT/IMPORT PATH NAME
+2 ; X= SYSTEM NUMBER IN FMS SYSTEM DEFAULT FILE
+3 ; CURRENTLY ALWAYS 1
+4 ; UNTIL SYSTEM BECOMES FULLY MULTIREGIONAL
+5 ;
+6 NEW Y,Z
+7 SET Z=$PIECE($GET(^ACRSYS(X,301)),U)
+8 IF Z']""
Begin DoDot:1
+9 WRITE !?5,*7,"OPEN DOCUMENT DOWNLOAD DIRECTORY IS UNDEFINED IN THE"
+10 WRITE !?5,"FMS SYSTEM DEFAULTS FILE, PLEASE NOTIFY ARMS MANAGER"
End DoDot:1
QUIT Z
+11 DO JCMD^ACRFUTL("cd "_Z,.Y)
+12 IF Y
Begin DoDot:1
+13 WRITE !,"No such directory "_Z
+14 SET Z=""
+15 DO PAUSE^ACRFWARN
End DoDot:1
+16 QUIT Z
