ACRFUTL1.m

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