ACRFUTL1 ;IHS/OIRM/DSD/AEF - VARIOUS UTILITY SUBROUTINES [ 07/20/2006 8:00 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**5,13,16,19,20**;NOV 05, 2001
;
NOTA(X) ;----- ALLOW/DISALLOW TRAVEL ADVANCE
; USED BY INPUT TRANSFORM ON FMS DOCUMENT FIELD TRAVEL ADVANCE
; ALLOWED
;
; INPUT:
; X = DOCUMENT IEN
;
; OUTPUT:
; 0 = TRAVEL ADVANCE NOT ALLOWED
; 1 = TRAVEL ADVANCE ALLOWED
;
N ACRCAN,Y
S Y=1
;
;----- IF ATM AUTHORIZED, NO TRAVEL ADVANCE ALLOWED
I $P($G(^ACRDOC(X,"TO")),U,22) S Y=0
;
;----- DON'T ALLOW TRAVEL ADVANCE FOR HEADQUARTERS EAST
S ACRCAN=$P($G(^ACRDOC(X,"REQ")),U,10)
I ACRCAN S ACRCAN=$P($G(^AUTTCAN(ACRCAN,0)),U)
;I $E(ACRCAN,1,3)="J94" S Y=0 ;COMMENTED OUT TO UNBLOCK TRAVEL ADVANCES AT HQE
;
Q Y
;
NAME(X) ;EP -- RETURNS EXTERNAL PERSON FILE 200 NAME ;ACR*2.1*5.15
;
; X = PERSON FILE 200 IEN
;
N Y,Z
S Y=""
;I X S Y=$P($G(^VA(200,X,0)),U) ;ACR*2.1*19.02 IM16848
I X S Y=$$NAME2^ACRFUTL1(X) ;ACR*2.1*19.02 IM16848
Q Y
NAME2(X) ;EP; EXTRINSIC FUNCTION ;ACR*2.1*19.02 IM16848
; X = IEN TO NEW PERSON FILE
; RETURNS NAME IN LAST,FIRST MIDDLE SUFFIX DEGREE FORMAT
; FROM NAME COMPONENTS FILE
;
I '+X Q ""
N Y,YY,Z
K XUNAME
S XUNAME("FILE")=200
S XUNAME("FIELD")=.01
S XUNAME("IENS")=X
;PARAMETER 2: F=FAMILY NAME FIRST G=GIVEN NAME FIRST
;PARAMETER 3: P=INCLUDE PREFIX D=INCLUDE DEGREE
S Y=$$NAMEFMT^XLFNAME1(.XUNAME,"F","D")
; Need comma after last name, prompting the following code.
; Just in case utility doesn't return a name, go get the value from New Person.
I Y']"" D
.S Y=$P($G(^VA(200,XUNAME("IENS")),0),U)
.I Y=0 S Y=""
;
I Y="" Q ""
S Z=$O(^VA(20,"BB",+XUNAME("FILE"),+$G(XUNAME("FIELD")),XUNAME("IENS")_",",0))
I Z="" Q ""
S Z=$P(^VA(20,Z,1),U) ; Last name
S YY=$P(Y,Z_" ",2,99) ; Everything after last name
S Y=Z_","_YY ; Last name, everything else
Q Y
;
NAME3(X) ;EP; EXTRINSIC FUNCTION ;ACR*2.1*19.02 IM16848
; X = IEN TO NEW PERSON FILE
; RETURNS NAME IN FIRST MIDDLE LAST SUFFIX DEGREE FORMAT
; FROM NAME COMPONENTS FILE
;
I '+X Q ""
N Y
K XUNAME
S XUNAME("FILE")=200
S XUNAME("FIELD")=.01
S XUNAME("IENS")=X
;PARAMETER 2: F=FAMILY NAME FIRST G=GIVEN NAME FIRST
;PARAMETER 3: P=INCLUDE PREFIX D=INCLUDE DEGREE
S Y=$$NAMEFMT^XLFNAME1(.XUNAME,"G","D")
Q Y
;
NAMEFT(X) ;EP; EXTRINSIC FUNCTION
; X = FREE TEXT NAME
; ATTEMPTS TO RETURN LAST,FIRST
;
N Y,P1,P2,PL
S Y=""
I X']"" Q Y
I $E(X)=" " Q Y
I $E(X)="-" Q Y
S X=$$UPPER^ACRFUTL(X) ;MAKE SURE IS UPPER CASE
I X'[" " Q ","_X ;SINGLE NAME, PRESUMED FIRST
S PL=$L(X," ") ;Number of spaces in name
I X["," D
.S PL=PL-1 S X=$TR(X,",") ;Disregard commas
S P2=$P(X," ",PL,PL+1) ;Get piece(s) after last space
S P1=$P(X," ",1,PL-1) ;Get rest of pieces
S Y=P2_","_P1
Q Y
;
FYFUN(X) ;EP -- RETURNS FISCAL YEAR OF FUNDS ; ACR*2.1*13.05 IM10810
;
; X = FMS DEPARTMENT ACCOUNT IEN
;
N Y
S Y=""
I X S Y=$P($G(^ACRLOCB(X,"DT")),U)
Q Y
OBJDA(X) ;EP -- RETURNS IEN OF OBJECT CLASS CODE ;ACR*2.1*16.06 IM15505
;
; X = EXTERNAL FORM OF OBJECT CLASS CODE
;
N Y
S Y=""
I X,$D(^AUTTOBJC("C",X)) S Y=$O(^AUTTOBJC("C",X,0))
Q Y
;
; New code ACR*2.1*20.14
SCREEN() ;EP -- RETURNS IF USER CAN USE SCREENMAN
; INPUT none
; OUTPUT Y = USER USE SCREENMAN?
; 1 = YES
; 0 = NO
N Y
S Y=0 ; Default to no screenman
I +$G(^ACRSYS(1,"DT1")) S Y=1 ; ARMS system defaults forces screenman
I '+Y D
. I +$P($G(^ACRSYS(1,"DT")),U,40) D ; ARMS SYSTEM DEFAULTS allows screenman
. . I +$P($G(^ACRAU(DUZ,1)),U,13) D ; ARMS User says use Screenman
. . . S Y=1
Q Y
;
; New code ACR*2.1*20.14
FORM(X) ;EP -- IS THERE A FORM FOR THIS INPUT TEMPLATE?
; INPUT X = DR (Input Template and Form name should be the same)
; OUTPUT Y = IS THERE A FORM?
; 1 = YES
; 0 = NO
N Y
S Y=0
I $G(X)="" Q 0
S X=$TR(X,"[]","")
I $D(^DIST(.403,"B",X)) S Y=1
Q Y
;
PA(X) ;EP -- PURCHASING AGENT
;
; INPUT: X = DOCUMENT IEN
; RETURNS: Y = PURCHASING AGENT POINTER TO NEW PERSON FILE
N Y
S Y=""
I X S Y=$P($G(^ACRDOC(X,"PA")),U)
Q Y
;
STRIPTB(X) ;EP - STRIP TRAILING BLANKS FROM STRING - ACR*2.1*20.14
N I,ACRLEN
I X="" Q X
F I=$L(X):-1:1 D Q:$G(ACRLEN)
.Q:$E(X,I)=" "
.S ACRLEN=I
S X=$E(X,1,ACRLEN)
Q X
;
STRIPLB(X) ;EP - STRIP LEADING BLANKS FROM STRING - ACR*2.1*20.14
N I,ACRLEN
I X="" Q X
S ACRLEN=$L(X," ")
F I=1:1:ACRLEN D Q:$P(X," ",I)'=""
.Q:$P(X," ",I)'=""
S X=$P(X," ",I,ACRLEN)
Q X
; New code ACR*2.1*PCARD
CC(X) ;EP -- IS THIS A REQUEST FOR CREDIT CARD PURCHASE/PAY WITH CC
; INPUT X = DOCUMENT IEN
; OUTPUT Y = IS THERE A FORM?
; 1 = YES
; 0 = NO
N Y,Z
S Z=""
I $G(X)]"" S Z=$P(^ACRDOC(X,0),U,4)
S Y=$S(Z=35:1,1:0)
Q Y
ACRFUTL1 ;IHS/OIRM/DSD/AEF - VARIOUS UTILITY SUBROUTINES [ 07/20/2006 8:00 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**5,13,16,19,20**;NOV 05, 2001
+2 ;
NOTA(X) ;----- ALLOW/DISALLOW TRAVEL ADVANCE
+1 ; USED BY INPUT TRANSFORM ON FMS DOCUMENT FIELD TRAVEL ADVANCE
+2 ; ALLOWED
+3 ;
+4 ; INPUT:
+5 ; X = DOCUMENT IEN
+6 ;
+7 ; OUTPUT:
+8 ; 0 = TRAVEL ADVANCE NOT ALLOWED
+9 ; 1 = TRAVEL ADVANCE ALLOWED
+10 ;
+11 NEW ACRCAN,Y
+12 SET Y=1
+13 ;
+14 ;----- IF ATM AUTHORIZED, NO TRAVEL ADVANCE ALLOWED
+15 IF $PIECE($GET(^ACRDOC(X,"TO")),U,22)
SET Y=0
+16 ;
+17 ;----- DON'T ALLOW TRAVEL ADVANCE FOR HEADQUARTERS EAST
+18 SET ACRCAN=$PIECE($GET(^ACRDOC(X,"REQ")),U,10)
+19 IF ACRCAN
SET ACRCAN=$PIECE($GET(^AUTTCAN(ACRCAN,0)),U)
+20 ;I $E(ACRCAN,1,3)="J94" S Y=0 ;COMMENTED OUT TO UNBLOCK TRAVEL ADVANCES AT HQE
+21 ;
+22 QUIT Y
+23 ;
NAME(X) ;EP -- RETURNS EXTERNAL PERSON FILE 200 NAME ;ACR*2.1*5.15
+1 ;
+2 ; X = PERSON FILE 200 IEN
+3 ;
+4 NEW Y,Z
+5 SET Y=""
+6 ;I X S Y=$P($G(^VA(200,X,0)),U) ;ACR*2.1*19.02 IM16848
+7 ;ACR*2.1*19.02 IM16848
IF X
SET Y=$$NAME2^ACRFUTL1(X)
+8 QUIT Y
NAME2(X) ;EP; EXTRINSIC FUNCTION ;ACR*2.1*19.02 IM16848
+1 ; X = IEN TO NEW PERSON FILE
+2 ; RETURNS NAME IN LAST,FIRST MIDDLE SUFFIX DEGREE FORMAT
+3 ; FROM NAME COMPONENTS FILE
+4 ;
+5 IF '+X
QUIT ""
+6 NEW Y,YY,Z
+7 KILL XUNAME
+8 SET XUNAME("FILE")=200
+9 SET XUNAME("FIELD")=.01
+10 SET XUNAME("IENS")=X
+11 ;PARAMETER 2: F=FAMILY NAME FIRST G=GIVEN NAME FIRST
+12 ;PARAMETER 3: P=INCLUDE PREFIX D=INCLUDE DEGREE
+13 SET Y=$$NAMEFMT^XLFNAME1(.XUNAME,"F","D")
+14 ; Need comma after last name, prompting the following code.
+15 ; Just in case utility doesn't return a name, go get the value from New Person.
+16 IF Y']""
Begin DoDot:1
+17 SET Y=$PIECE($GET(^VA(200,XUNAME("IENS")),0),U)
+18 IF Y=0
SET Y=""
End DoDot:1
+19 ;
+20 IF Y=""
QUIT ""
+21 SET Z=$ORDER(^VA(20,"BB",+XUNAME("FILE"),+$GET(XUNAME("FIELD")),XUNAME("IENS")_",",0))
+22 IF Z=""
QUIT ""
+23 ; Last name
SET Z=$PIECE(^VA(20,Z,1),U)
+24 ; Everything after last name
SET YY=$PIECE(Y,Z_" ",2,99)
+25 ; Last name, everything else
SET Y=Z_","_YY
+26 QUIT Y
+27 ;
NAME3(X) ;EP; EXTRINSIC FUNCTION ;ACR*2.1*19.02 IM16848
+1 ; X = IEN TO NEW PERSON FILE
+2 ; RETURNS NAME IN FIRST MIDDLE LAST SUFFIX DEGREE FORMAT
+3 ; FROM NAME COMPONENTS FILE
+4 ;
+5 IF '+X
QUIT ""
+6 NEW Y
+7 KILL XUNAME
+8 SET XUNAME("FILE")=200
+9 SET XUNAME("FIELD")=.01
+10 SET XUNAME("IENS")=X
+11 ;PARAMETER 2: F=FAMILY NAME FIRST G=GIVEN NAME FIRST
+12 ;PARAMETER 3: P=INCLUDE PREFIX D=INCLUDE DEGREE
+13 SET Y=$$NAMEFMT^XLFNAME1(.XUNAME,"G","D")
+14 QUIT Y
+15 ;
NAMEFT(X) ;EP; EXTRINSIC FUNCTION
+1 ; X = FREE TEXT NAME
+2 ; ATTEMPTS TO RETURN LAST,FIRST
+3 ;
+4 NEW Y,P1,P2,PL
+5 SET Y=""
+6 IF X']""
QUIT Y
+7 IF $EXTRACT(X)=" "
QUIT Y
+8 IF $EXTRACT(X)="-"
QUIT Y
+9 ;MAKE SURE IS UPPER CASE
SET X=$$UPPER^ACRFUTL(X)
+10 ;SINGLE NAME, PRESUMED FIRST
IF X'[" "
QUIT ","_X
+11 ;Number of spaces in name
SET PL=$LENGTH(X," ")
+12 IF X[","
Begin DoDot:1
+13 ;Disregard commas
SET PL=PL-1
SET X=$TRANSLATE(X,",")
End DoDot:1
+14 ;Get piece(s) after last space
SET P2=$PIECE(X," ",PL,PL+1)
+15 ;Get rest of pieces
SET P1=$PIECE(X," ",1,PL-1)
+16 SET Y=P2_","_P1
+17 QUIT Y
+18 ;
FYFUN(X) ;EP -- RETURNS FISCAL YEAR OF FUNDS ; ACR*2.1*13.05 IM10810
+1 ;
+2 ; X = FMS DEPARTMENT ACCOUNT IEN
+3 ;
+4 NEW Y
+5 SET Y=""
+6 IF X
SET Y=$PIECE($GET(^ACRLOCB(X,"DT")),U)
+7 QUIT Y
OBJDA(X) ;EP -- RETURNS IEN OF OBJECT CLASS CODE ;ACR*2.1*16.06 IM15505
+1 ;
+2 ; X = EXTERNAL FORM OF OBJECT CLASS CODE
+3 ;
+4 NEW Y
+5 SET Y=""
+6 IF X
IF $DATA(^AUTTOBJC("C",X))
SET Y=$ORDER(^AUTTOBJC("C",X,0))
+7 QUIT Y
+8 ;
+9 ; New code ACR*2.1*20.14
SCREEN() ;EP -- RETURNS IF USER CAN USE SCREENMAN
+1 ; INPUT none
+2 ; OUTPUT Y = USER USE SCREENMAN?
+3 ; 1 = YES
+4 ; 0 = NO
+5 NEW Y
+6 ; Default to no screenman
SET Y=0
+7 ; ARMS system defaults forces screenman
IF +$GET(^ACRSYS(1,"DT1"))
SET Y=1
+8 IF '+Y
Begin DoDot:1
+9 ; ARMS SYSTEM DEFAULTS allows screenman
IF +$PIECE($GET(^ACRSYS(1,"DT")),U,40)
Begin DoDot:2
+10 ; ARMS User says use Screenman
IF +$PIECE($GET(^ACRAU(DUZ,1)),U,13)
Begin DoDot:3
+11 SET Y=1
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT Y
+13 ;
+14 ; New code ACR*2.1*20.14
FORM(X) ;EP -- IS THERE A FORM FOR THIS INPUT TEMPLATE?
+1 ; INPUT X = DR (Input Template and Form name should be the same)
+2 ; OUTPUT Y = IS THERE A FORM?
+3 ; 1 = YES
+4 ; 0 = NO
+5 NEW Y
+6 SET Y=0
+7 IF $GET(X)=""
QUIT 0
+8 SET X=$TRANSLATE(X,"[]","")
+9 IF $DATA(^DIST(.403,"B",X))
SET Y=1
+10 QUIT Y
+11 ;
PA(X) ;EP -- PURCHASING AGENT
+1 ;
+2 ; INPUT: X = DOCUMENT IEN
+3 ; RETURNS: Y = PURCHASING AGENT POINTER TO NEW PERSON FILE
+4 NEW Y
+5 SET Y=""
+6 IF X
SET Y=$PIECE($GET(^ACRDOC(X,"PA")),U)
+7 QUIT Y
+8 ;
STRIPTB(X) ;EP - STRIP TRAILING BLANKS FROM STRING - ACR*2.1*20.14
+1 NEW I,ACRLEN
+2 IF X=""
QUIT X
+3 FOR I=$LENGTH(X):-1:1
Begin DoDot:1
+4 IF $EXTRACT(X,I)=" "
QUIT
+5 SET ACRLEN=I
End DoDot:1
IF $GET(ACRLEN)
QUIT
+6 SET X=$EXTRACT(X,1,ACRLEN)
+7 QUIT X
+8 ;
STRIPLB(X) ;EP - STRIP LEADING BLANKS FROM STRING - ACR*2.1*20.14
+1 NEW I,ACRLEN
+2 IF X=""
QUIT X
+3 SET ACRLEN=$LENGTH(X," ")
+4 FOR I=1:1:ACRLEN
Begin DoDot:1
+5 IF $PIECE(X," ",I)'=""
QUIT
End DoDot:1
IF $PIECE(X," ",I)'=""
QUIT
+6 SET X=$PIECE(X," ",I,ACRLEN)
+7 QUIT X
+8 ; New code ACR*2.1*PCARD
CC(X) ;EP -- IS THIS A REQUEST FOR CREDIT CARD PURCHASE/PAY WITH CC
+1 ; INPUT X = DOCUMENT IEN
+2 ; OUTPUT Y = IS THERE A FORM?
+3 ; 1 = YES
+4 ; 0 = NO
+5 NEW Y,Z
+6 SET Z=""
+7 IF $GET(X)]""
SET Z=$PIECE(^ACRDOC(X,0),U,4)
+8 SET Y=$SELECT(Z=35:1,1:0)
+9 QUIT Y
