ACRFUTL ;IHS/OIRM/DSD/AEF - VARIOUS UTILITY SUBROUTINES [ 10/27/2004 4:17 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,13,14**;NOV 05, 2001
;
PAD(X,S,L,C) ;EP
;----- PAD MACHINE - PAD CHARACTER STRING
;
; X = DATA STRING
; S = L=PADLEFT, R=PADRIGHT
; L = LENGTH
; C = PAD CHARACTER
;
I $L(X)>L S X=$E(X,1,L) Q X
S X=$TR(X," ","~")
I S="R" D
. S X=X_$J("",L-$L(X))
I S="L" D
. S X=$J("",L-$L(X))_X
I C]"" S X=$TR(X," ",C)
S X=$TR(X,"~"," ")
Q X
;
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
TCMD(X,Y) ;EP
;----- ENTRY POINT FOR USING $$TERMINAL^%HOSTCMD
; (ALSO REPLACES HOSTCMD^AFSLCKZC CALL)
;
; RETURNS 0 IF VALID, 1 IF INVALID
;
S Y=$$TERMINAL^%HOSTCMD(X)
Q
JCMD(X,Y) ;EP
;----- ENTRY POINT FOR USING $$JOBWAIT^%HOSTCMD
;
; RUNS IN BACKGROUND - WILL WORK IN CACHE'
; RETURNS 0 IF VALID, 1 IF INVALID
;
S Y=$$JOBWAIT^%HOSTCMD(X)
Q
JDATE() ;EP -- RETURNS TODAY'S JULIAN DATE
;
N X,X1,X2
D ^XBKVAR
S X1=DT
S X2=$E(DT,1,3)_"0101"
D ^%DTC
S X=X+1
S X=$$PAD(X,"L",3,0)
Q X
QUE(ZTRTN,ZTSAVE,ZTDESC) ;EP;
;----- QUEUEING CODE FROM WITHIN ROUTINES
;
N %ZIS,IO,POP,ZTIO,ZTSK
S %ZIS="Q"
D ^%ZIS
Q:POP
I $D(IO("Q")) D Q
. K IO("Q")
. S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
. D ^%ZTLOAD
. W !,"Task #",$G(ZTSK)," queued"
D @ZTRTN
Q
NOW() ;EP -- RETURNS CURRENT DATE/TIME
;
N %,%H,%I,X
D ^XBKVAR
D NOW^%DTC
S Y=DT
X ^DD("DD")
Q Y_" "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)
;
SLDATE(X) ;EP
;----- RETURNS DATE IN MM/DD/YYYY FORMAT
;
; X = INTERNAL FILEMANAGER DATE IN YYYMMDD FORMAT
;
N Y
S Y=""
I X D
. Q:$L(X)'=7
. S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)
Q Y
DOL(X) ;EP -- FORMAT DOLLAR AMOUNT ;
;
; RETURNS X IN 999.99 FORMAT
;
I X["(" S X=$TR(X,"()",""),X="-"_X
S X=$FN(X,"P",2)
S X=$TR(X," ","")
I X["(" S X=$TR(X,"()",""),X="-"_X
Q X
FY(X) ;EP -- CALCULATE FISCAL YEAR
;
; RETURNS FISCAL YEAR IN X
;
N MON
S MON=$E(X,4,5)
S X=$E(X,1,3)
S X=1700+X
I +MON>9 S X=X+1
Q X
UPPER(X) ;EP -- CONVERT STRING TO UPPERCASE ;
;
X ^%ZOSF("UPPERCASE")
Q Y
;
HFS(ZISH1,ZISH2,ZISH3,%FILE) ;EP ;
;----- CREATE AND OPEN UNIX FILE - SILENT & NO "FILE"
;
; *NOTE: OPEN^%ZISH IS EXTRINSIC FUNCTION WHEN IT HAS ONLY 3 PARAMS
; MUST 'DO' THE CALL WHEN PASSING 4 OR MORE
;
; ENTERS WITH: ZISH1= PATH
; ZISH2= FILENAME
; ZISH3= "R" OR "W"
; RETURNS: %FILE = DEVICE NUMBER (or UNDEFINED)
;
;
N X,Y
;S Y=$$OPEN^%ZISHMSM(ZISH1,ZISH2,ZISH3) ;ACR*2.1*13.01 IM13574
S Y=$$OPEN^%ZISH(ZISH1,ZISH2,ZISH3) ;ACR*2.1*13.01 IM13574
Q:Y
S %FILE=IO
Q
DOC(X) ;EP -- CONVERT REQUISITION NUMBER
;
; INPUT:
; X = REQUISITION NUMBER
;
; RETURNS: THE 10 DIGIT REQUISITION NUMBER WITHOUT THE DASHES
;
S X=$TR(X,"-","")
S X=$E(X,2,11)
Q X
HOST() ;EP -- RETURNS HOST NAME ; ACR*2.1*13.02 IM13574
N Y
S Y=""
S Y=$P(^AUTTSITE(1,0),U,14)
S Y=$TR(Y,"-")
Q Y
PSSN(X,DUZ,IOST,ACRSSNOK) ;EP ;ACR*2.1*3.36
;----- OUTPUT TRANSFORM FOR TRAVEL ORDER/TRAVEL VOUCHER/TRAINING
; REQUEST PRINT TEMPLATES
;
; INPUT VARIABLES:
; X = EMPLOYEE IEN
; DUZ = PERSON PRINTING REPORT
; IOST = PRINT SUBTYPE
; ACRSSNOK = VARIABLE SET IN ACRFPRNT AUTOPRINT ROUTINE
;
; OUTPUT:
; Y = SSN IN 999-99-9999 OR ***-**-**** FORMAT
;
; PRINT LOGIC:
; NEVER PRINT TO TERMINAL SCREEN
; ALWAYS PRINT SSN IF DOCUMENT IS AUTOPRINTED DUE TO APPROVAL
; IF NOT AUTOPRINTED, ONLY PRINT IF THE USER HAS SECURITY KEY
;
N Y
S Y="*********"
I "S-P-"[$E($G(IOST),1,2) D
. Q:'$G(ACRSSNOK)&'$D(^XUSEC("ACRFZ SSN",+$G(DUZ)))
. I $P($G(^VA(200,+$G(X),1)),U,9) S Y=$P(^(1),U,9)
S Y=$E(Y,1,3)_"-"_$E(Y,4,5)_"-"_$E(Y,6,9)
Q Y
ASKAP(ACRAP) ;EP; NEW SUB-ROUTINE ACR*2.1*13.02
;----- SELECT ACCOUNTING POINT FROM LIST
; ------RETURNS INTERNAL AND EXTERNAL VALUES
;
N DIC,X,Y
S ACRAP=""
S DIC="^AUTTACPT("
S DIC(0)="AEMQ"
D ^DIC
Q:$D(DTOUT)!($D(DUOUT))!(+Y'>0)
S ACRAP=Y
Q
;
AP(X) ;EP; NEW SUB-ROUTINE ACR*2.1*13.02
;------------EXTRINSIC FUNCTION FOR ACCOUNTING POINT
;
N Y
Q $P($G(^AUTTACPT(X,0)),U)
;
EXPDN(X) ;EP -- RETURN EXPANDED DOCUMENT NUMBER - ACR*2.1*14.01 IM12272
;
; INPUT:
; X = DOCUMENT IEN
;
; OUTPUT:
; Y = EXPANDED DOCUMENT NUMBER
; IN FORMAT:
; "HHS"_"I"_CONTRACTLOCATION_4FY_DOCNO
;
; NOTE: If "< UNKNOWN XXX >" is returned it is most likely
; due to the following:
; UNKNOWN 001 = discrepancy in the fiscal year of
; the document and the expanded number could not be
; calculated based on the available data. In this
; case, the expanded number should be manually
; entered into the expanded document number field of
; the FMS DOCUMENT file for the document.
;
N Y,Z
S Y=""
S Z=$G(^ACRSYS(1,601))
I X,+Z,$P(Z,U,2) D
. S Z=$G(^ACRDOC(X,0))
. S Y=$P(Z,U,2) ;PO/CONTRACT NO
. I "148^600^130"[$$REF(X) D
. . S Y=$P(Z,U) ;DOCUMENT NO
. S Z=$P($G(^ACRDOC(X,"X")),U) ;IF EXPDN ALREADY EXISTS
. I Z]"" S Y=Z Q
. Q:Y']""
. S Z=$P($G(^ACRDOC(X,0)),U,15) ;ORIG DOCNO IF MOD
. I Z S X=Z
. S Z=$P($G(^ACRSYS(1,601)),U)
. I Z S Z=$P($G(^ACRCLC(+Z,0)),U) ;CONTRACT LOCATION CODE
. Q:Z']""
. Q:$E($$DOCYR(X),4)'=$E(Y)
. S Z="HHS"_"I"_Z_$$DOCYR(X)_$E(Y,2,10)
. Q:$L(Z)'=20
. Q:$D(^ACRDOC("B",Z))
. S Y=Z
Q Y
DOCYR(X) ;EP -- RETURN DOCUMENT YEAR - ACR*2.1*14.01 IM12272
;
; This subroutine calculates the document year based
; on code logic in the DOC3^ACRFDOCN routine:
; If the fiscal year in which the document is created is
; greater than the fiscal year of funds (in the FMS
; DEPARTMENT ACCOUNT file), use the fiscal year in which
; the document is created, otherwise use the fiscal year
; of funds.
;
; INPUT:
; X = DOCUMENT IEN
;
; OUTPUT:
; Y = DOCUMENT YEAR
;
N Y,Z
S Y=""
I X D
. S Y=$P($G(^ACRLOCB($$DEPT(X),"DT")),U) ;FYFUN
. S Z=$P($G(^ACRDOC(X,"PO")),U) ;DATE OF PO
. I Z="" S Z=$P($G(^ACRDOC(X,0)),U,3) ;DOCUMENT DATE
. S Z=$$FY(Z)
. I Z>Y S Y=Z
Q Y
YEAR(X) ;EP -- RETURN 4 DIGIT YEAR OF DATE - ACR*2.1*14.01 IM12272
;
; INPUT:
; X = YEAR IN INTERNAL FILEMAN FORMAT
;
; OUTPUT:
; Y = 4 DIGIT YEAR
;
N Y
S Y=""
I X D
. Q:$L(X)'=7
. S Y=$E(X,1,3)+1700
Q Y
DEPT(X) ;EP -- RETURN INTERNAL DEPARTMENT ACCOUNT OF DOCUMENT ;ACR*2.1*14.01 IM12272
;
; INPUT:
; X = DOCUMENT IEN
;
; OUTPUT:
; Y = INTERNAL DEPARTMENT ACCOUNT
;
N Y
S Y=""
I X S Y=$P($G(^ACRDOC(X,0)),U,6)
Q Y
REF(X) ;EP -- RETURN EXTERNAL DOCUMENT REFERENCE CODE ;ACR*2.1*14.01 IM12272
;
; INPUT:
; X = DOCUMENT IEN
;
; OUTPUT:
; Y = EXTERNAL DOCUMENT REFERENCE CODE
;
N Y
S Y=""
I X S Y=$P($G(^ACRDOC(X,0)),U,13)
I Y S Y=$P($G(^AUTTDOCR(Y,0)),U)
Q Y
ACRFUTL ;IHS/OIRM/DSD/AEF - VARIOUS UTILITY SUBROUTINES [ 10/27/2004 4:17 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,13,14**;NOV 05, 2001
+2 ;
PAD(X,S,L,C) ;EP
+1 ;----- PAD MACHINE - PAD CHARACTER STRING
+2 ;
+3 ; X = DATA STRING
+4 ; S = L=PADLEFT, R=PADRIGHT
+5 ; L = LENGTH
+6 ; C = PAD CHARACTER
+7 ;
+8 IF $LENGTH(X)>L
SET X=$EXTRACT(X,1,L)
QUIT X
+9 SET X=$TRANSLATE(X," ","~")
+10 IF S="R"
Begin DoDot:1
+11 SET X=X_$JUSTIFY("",L-$LENGTH(X))
End DoDot:1
+12 IF S="L"
Begin DoDot:1
+13 SET X=$JUSTIFY("",L-$LENGTH(X))_X
End DoDot:1
+14 IF C]""
SET X=$TRANSLATE(X," ",C)
+15 SET X=$TRANSLATE(X,"~"," ")
+16 QUIT X
+17 ;
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
TCMD(X,Y) ;EP
+1 ;----- ENTRY POINT FOR USING $$TERMINAL^%HOSTCMD
+2 ; (ALSO REPLACES HOSTCMD^AFSLCKZC CALL)
+3 ;
+4 ; RETURNS 0 IF VALID, 1 IF INVALID
+5 ;
+6 SET Y=$$TERMINAL^%HOSTCMD(X)
+7 QUIT
JCMD(X,Y) ;EP
+1 ;----- ENTRY POINT FOR USING $$JOBWAIT^%HOSTCMD
+2 ;
+3 ; RUNS IN BACKGROUND - WILL WORK IN CACHE'
+4 ; RETURNS 0 IF VALID, 1 IF INVALID
+5 ;
+6 SET Y=$$JOBWAIT^%HOSTCMD(X)
+7 QUIT
JDATE() ;EP -- RETURNS TODAY'S JULIAN DATE
+1 ;
+2 NEW X,X1,X2
+3 DO ^XBKVAR
+4 SET X1=DT
+5 SET X2=$EXTRACT(DT,1,3)_"0101"
+6 DO ^%DTC
+7 SET X=X+1
+8 SET X=$$PAD(X,"L",3,0)
+9 QUIT X
QUE(ZTRTN,ZTSAVE,ZTDESC) ;EP;
+1 ;----- QUEUEING CODE FROM WITHIN ROUTINES
+2 ;
+3 NEW %ZIS,IO,POP,ZTIO,ZTSK
+4 SET %ZIS="Q"
+5 DO ^%ZIS
+6 IF POP
QUIT
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 KILL IO("Q")
+9 SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
+10 DO ^%ZTLOAD
+11 WRITE !,"Task #",$GET(ZTSK)," queued"
End DoDot:1
QUIT
+12 DO @ZTRTN
+13 QUIT
NOW() ;EP -- RETURNS CURRENT DATE/TIME
+1 ;
+2 NEW %,%H,%I,X
+3 DO ^XBKVAR
+4 DO NOW^%DTC
+5 SET Y=DT
+6 XECUTE ^DD("DD")
+7 QUIT Y_" "_$EXTRACT($PIECE(%,".",2),1,2)_":"_$EXTRACT($PIECE(%,".",2),3,4)
+8 ;
SLDATE(X) ;EP
+1 ;----- RETURNS DATE IN MM/DD/YYYY FORMAT
+2 ;
+3 ; X = INTERNAL FILEMANAGER DATE IN YYYMMDD FORMAT
+4 ;
+5 NEW Y
+6 SET Y=""
+7 IF X
Begin DoDot:1
+8 IF $LENGTH(X)'=7
QUIT
+9 SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_($EXTRACT(X,1,3)+1700)
End DoDot:1
+10 QUIT Y
DOL(X) ;EP -- FORMAT DOLLAR AMOUNT ;
+1 ;
+2 ; RETURNS X IN 999.99 FORMAT
+3 ;
+4 IF X["("
SET X=$TRANSLATE(X,"()","")
SET X="-"_X
+5 SET X=$FNUMBER(X,"P",2)
+6 SET X=$TRANSLATE(X," ","")
+7 IF X["("
SET X=$TRANSLATE(X,"()","")
SET X="-"_X
+8 QUIT X
FY(X) ;EP -- CALCULATE FISCAL YEAR
+1 ;
+2 ; RETURNS FISCAL YEAR IN X
+3 ;
+4 NEW MON
+5 SET MON=$EXTRACT(X,4,5)
+6 SET X=$EXTRACT(X,1,3)
+7 SET X=1700+X
+8 IF +MON>9
SET X=X+1
+9 QUIT X
UPPER(X) ;EP -- CONVERT STRING TO UPPERCASE ;
+1 ;
+2 XECUTE ^%ZOSF("UPPERCASE")
+3 QUIT Y
+4 ;
HFS(ZISH1,ZISH2,ZISH3,%FILE) ;EP ;
+1 ;----- CREATE AND OPEN UNIX FILE - SILENT & NO "FILE"
+2 ;
+3 ; *NOTE: OPEN^%ZISH IS EXTRINSIC FUNCTION WHEN IT HAS ONLY 3 PARAMS
+4 ; MUST 'DO' THE CALL WHEN PASSING 4 OR MORE
+5 ;
+6 ; ENTERS WITH: ZISH1= PATH
+7 ; ZISH2= FILENAME
+8 ; ZISH3= "R" OR "W"
+9 ; RETURNS: %FILE = DEVICE NUMBER (or UNDEFINED)
+10 ;
+11 ;
+12 NEW X,Y
+13 ;S Y=$$OPEN^%ZISHMSM(ZISH1,ZISH2,ZISH3) ;ACR*2.1*13.01 IM13574
+14 ;ACR*2.1*13.01 IM13574
SET Y=$$OPEN^%ZISH(ZISH1,ZISH2,ZISH3)
+15 IF Y
QUIT
+16 SET %FILE=IO
+17 QUIT
DOC(X) ;EP -- CONVERT REQUISITION NUMBER
+1 ;
+2 ; INPUT:
+3 ; X = REQUISITION NUMBER
+4 ;
+5 ; RETURNS: THE 10 DIGIT REQUISITION NUMBER WITHOUT THE DASHES
+6 ;
+7 SET X=$TRANSLATE(X,"-","")
+8 SET X=$EXTRACT(X,2,11)
+9 QUIT X
HOST() ;EP -- RETURNS HOST NAME ; ACR*2.1*13.02 IM13574
+1 NEW Y
+2 SET Y=""
+3 SET Y=$PIECE(^AUTTSITE(1,0),U,14)
+4 SET Y=$TRANSLATE(Y,"-")
+5 QUIT Y
PSSN(X,DUZ,IOST,ACRSSNOK) ;EP ;ACR*2.1*3.36
+1 ;----- OUTPUT TRANSFORM FOR TRAVEL ORDER/TRAVEL VOUCHER/TRAINING
+2 ; REQUEST PRINT TEMPLATES
+3 ;
+4 ; INPUT VARIABLES:
+5 ; X = EMPLOYEE IEN
+6 ; DUZ = PERSON PRINTING REPORT
+7 ; IOST = PRINT SUBTYPE
+8 ; ACRSSNOK = VARIABLE SET IN ACRFPRNT AUTOPRINT ROUTINE
+9 ;
+10 ; OUTPUT:
+11 ; Y = SSN IN 999-99-9999 OR ***-**-**** FORMAT
+12 ;
+13 ; PRINT LOGIC:
+14 ; NEVER PRINT TO TERMINAL SCREEN
+15 ; ALWAYS PRINT SSN IF DOCUMENT IS AUTOPRINTED DUE TO APPROVAL
+16 ; IF NOT AUTOPRINTED, ONLY PRINT IF THE USER HAS SECURITY KEY
+17 ;
+18 NEW Y
+19 SET Y="*********"
+20 IF "S-P-"[$EXTRACT($GET(IOST),1,2)
Begin DoDot:1
+21 IF '$GET(ACRSSNOK)&'$DATA(^XUSEC("ACRFZ SSN",+$GET(DUZ)))
QUIT
+22 IF $PIECE($GET(^VA(200,+$GET(X),1)),U,9)
SET Y=$PIECE(^(1),U,9)
End DoDot:1
+23 SET Y=$EXTRACT(Y,1,3)_"-"_$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,9)
+24 QUIT Y
ASKAP(ACRAP) ;EP; NEW SUB-ROUTINE ACR*2.1*13.02
+1 ;----- SELECT ACCOUNTING POINT FROM LIST
+2 ; ------RETURNS INTERNAL AND EXTERNAL VALUES
+3 ;
+4 NEW DIC,X,Y
+5 SET ACRAP=""
+6 SET DIC="^AUTTACPT("
+7 SET DIC(0)="AEMQ"
+8 DO ^DIC
+9 IF $DATA(DTOUT)!($DATA(DUOUT))!(+Y'>0)
QUIT
+10 SET ACRAP=Y
+11 QUIT
+12 ;
AP(X) ;EP; NEW SUB-ROUTINE ACR*2.1*13.02
+1 ;------------EXTRINSIC FUNCTION FOR ACCOUNTING POINT
+2 ;
+3 NEW Y
+4 QUIT $PIECE($GET(^AUTTACPT(X,0)),U)
+5 ;
EXPDN(X) ;EP -- RETURN EXPANDED DOCUMENT NUMBER - ACR*2.1*14.01 IM12272
+1 ;
+2 ; INPUT:
+3 ; X = DOCUMENT IEN
+4 ;
+5 ; OUTPUT:
+6 ; Y = EXPANDED DOCUMENT NUMBER
+7 ; IN FORMAT:
+8 ; "HHS"_"I"_CONTRACTLOCATION_4FY_DOCNO
+9 ;
+10 ; NOTE: If "< UNKNOWN XXX >" is returned it is most likely
+11 ; due to the following:
+12 ; UNKNOWN 001 = discrepancy in the fiscal year of
+13 ; the document and the expanded number could not be
+14 ; calculated based on the available data. In this
+15 ; case, the expanded number should be manually
+16 ; entered into the expanded document number field of
+17 ; the FMS DOCUMENT file for the document.
+18 ;
+19 NEW Y,Z
+20 SET Y=""
+21 SET Z=$GET(^ACRSYS(1,601))
+22 IF X
IF +Z
IF $PIECE(Z,U,2)
Begin DoDot:1
+23 SET Z=$GET(^ACRDOC(X,0))
+24 ;PO/CONTRACT NO
SET Y=$PIECE(Z,U,2)
+25 IF "148^600^130"[$$REF(X)
Begin DoDot:2
+26 ;DOCUMENT NO
SET Y=$PIECE(Z,U)
End DoDot:2
+27 ;IF EXPDN ALREADY EXISTS
SET Z=$PIECE($GET(^ACRDOC(X,"X")),U)
+28 IF Z]""
SET Y=Z
QUIT
+29 IF Y']""
QUIT
+30 ;ORIG DOCNO IF MOD
SET Z=$PIECE($GET(^ACRDOC(X,0)),U,15)
+31 IF Z
SET X=Z
+32 SET Z=$PIECE($GET(^ACRSYS(1,601)),U)
+33 ;CONTRACT LOCATION CODE
IF Z
SET Z=$PIECE($GET(^ACRCLC(+Z,0)),U)
+34 IF Z']""
QUIT
+35 IF $EXTRACT($$DOCYR(X),4)'=$EXTRACT(Y)
QUIT
+36 SET Z="HHS"_"I"_Z_$$DOCYR(X)_$EXTRACT(Y,2,10)
+37 IF $LENGTH(Z)'=20
QUIT
+38 IF $DATA(^ACRDOC("B",Z))
QUIT
+39 SET Y=Z
End DoDot:1
+40 QUIT Y
DOCYR(X) ;EP -- RETURN DOCUMENT YEAR - ACR*2.1*14.01 IM12272
+1 ;
+2 ; This subroutine calculates the document year based
+3 ; on code logic in the DOC3^ACRFDOCN routine:
+4 ; If the fiscal year in which the document is created is
+5 ; greater than the fiscal year of funds (in the FMS
+6 ; DEPARTMENT ACCOUNT file), use the fiscal year in which
+7 ; the document is created, otherwise use the fiscal year
+8 ; of funds.
+9 ;
+10 ; INPUT:
+11 ; X = DOCUMENT IEN
+12 ;
+13 ; OUTPUT:
+14 ; Y = DOCUMENT YEAR
+15 ;
+16 NEW Y,Z
+17 SET Y=""
+18 IF X
Begin DoDot:1
+19 ;FYFUN
SET Y=$PIECE($GET(^ACRLOCB($$DEPT(X),"DT")),U)
+20 ;DATE OF PO
SET Z=$PIECE($GET(^ACRDOC(X,"PO")),U)
+21 ;DOCUMENT DATE
IF Z=""
SET Z=$PIECE($GET(^ACRDOC(X,0)),U,3)
+22 SET Z=$$FY(Z)
+23 IF Z>Y
SET Y=Z
End DoDot:1
+24 QUIT Y
YEAR(X) ;EP -- RETURN 4 DIGIT YEAR OF DATE - ACR*2.1*14.01 IM12272
+1 ;
+2 ; INPUT:
+3 ; X = YEAR IN INTERNAL FILEMAN FORMAT
+4 ;
+5 ; OUTPUT:
+6 ; Y = 4 DIGIT YEAR
+7 ;
+8 NEW Y
+9 SET Y=""
+10 IF X
Begin DoDot:1
+11 IF $LENGTH(X)'=7
QUIT
+12 SET Y=$EXTRACT(X,1,3)+1700
End DoDot:1
+13 QUIT Y
DEPT(X) ;EP -- RETURN INTERNAL DEPARTMENT ACCOUNT OF DOCUMENT ;ACR*2.1*14.01 IM12272
+1 ;
+2 ; INPUT:
+3 ; X = DOCUMENT IEN
+4 ;
+5 ; OUTPUT:
+6 ; Y = INTERNAL DEPARTMENT ACCOUNT
+7 ;
+8 NEW Y
+9 SET Y=""
+10 IF X
SET Y=$PIECE($GET(^ACRDOC(X,0)),U,6)
+11 QUIT Y
REF(X) ;EP -- RETURN EXTERNAL DOCUMENT REFERENCE CODE ;ACR*2.1*14.01 IM12272
+1 ;
+2 ; INPUT:
+3 ; X = DOCUMENT IEN
+4 ;
+5 ; OUTPUT:
+6 ; Y = EXTERNAL DOCUMENT REFERENCE CODE
+7 ;
+8 NEW Y
+9 SET Y=""
+10 IF X
SET Y=$PIECE($GET(^ACRDOC(X,0)),U,13)
+11 IF Y
SET Y=$PIECE($GET(^AUTTDOCR(Y,0)),U)
+12 QUIT Y
