ACRFPRC3 ;IHS/OIRM/DSD/THL,AEF - PROCESS PENDING DOCUMENTS; [ 01/03/2003 9:53 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,5**;NOV 05, 2001
;;CONTINUATION OF ACRFPRCS
UP ;EP;TO SET NEXT APPROVAL TO BE PROCESSED
N ACRAPDA
K ACRQUIT,ACROUT
S ACRORD=0
F S ACRORD=$O(^ACRAPVS("AORDR",ACRDOCDA,ACRORD)) Q:'ACRORD!$D(ACRQUIT)!$D(ACROUT) D
.S ACRAPDA=0
.F S ACRAPDA=$O(^ACRAPVS("AORDR",ACRDOCDA,ACRORD,ACRAPDA)) Q:'ACRAPDA!$D(ACRQUIT) D
..S ACRAPV0=$G(^ACRAPVS(ACRAPDA,0))
..S ACRAPVDT=$G(^ACRAPVS(ACRAPDA,"DT"))
..Q:$P(ACRAPVDT,U)]""
..Q:DT<$P(ACRAPVDT,U,8)
..K ACRQUIT
..D NOW^%DTC
..S ACRNOW=%
..S ACRAPVT=$P(ACRAPV0,U,3)
..S ACRINDV=$P(ACRAPVDT,U,2)
..I ACRAPVT=""!(ACRINDV="") S ACRQUIT="" Q
..S $P(^ACRAPVS(ACRAPDA,"DT"),U,3)=ACRNOW
..S ^ACRAPVS("ANXT",ACRAPVT,ACRINDV,ACRAPDA)=ACRDOCDA_U_$P(ACRAPVDT,U,8)
..S $P(^ACRAPVS(ACRAPDA,"DT"),U,3)=ACRNOW
..D DOMAIN^ACRFNXT
..K ACRINDV,ACRAPV0,ACRAPVDT
..S ACRQUIT=""
K ACRQUIT
Q
APX ;EP;SUBROUTINE TO UPDATES INFO IN THE APPROVAL FILE FOR EACH DOCUMENT
;APPROVAL. ALSO, CREATES A MAILMAN MESSAGE WHENEVER DOCUMENT IS NOT
;APPROVED OR WHEN ANY MESSAGE IS ENTERED AT TIME OF APPROVAL
Q:+$$SIGSCR^ACRFPRC1($G(ACRAPVT),.ACRAPVS,$P($G(^ACRDOC(ACRDOCDA,"TO")),U,9),$P($G(^ACRDOC(ACRDOCDA,"TRNG")),U,2),DUZ)
D NOW^%DTC
S ACRNOW=%
S DA=ACRAPDA
S DIE="^ACRAPVS("
S DR="1////"_ACRAPDAS_";6////"_DUZ_";4////"_ACRNOW
S:$D(ACRSIGN(ACRAPDA)) DR=DR_";3////"_ACRNOW
D DIE^ACRFDIC
S ACRAPV0=^ACRAPVS(ACRAPDA,0)
S ACRAPVDT=^ACRAPVS(ACRAPDA,"DT")
S X=^ACRAPVT($P(ACRAPV0,U,3),"DT")
S ACRGLB=$P(X,U)
S ACRPC=$P(X,U,2)
S ACRTXTYP=$P(ACRDOC0,U,4)
S ACRAPVT=$P(ACRAPV0,U,3)
S ACRAPDAS=$P(ACRAPVDT,U)
S ACRAPDAF=$E($P(ACRAPVDT,U,5))
S ACRINDV=$P(ACRAPVDT,U,2)
S ACRORD=$P(ACRAPV0,U,4)
I ACRAPVT=15,$P(ACRAPV0,U,6)=$O(^AUTTDOCR("B",602,0)) D OTA^ACRFTA:ACRAPDAS="A" Q:ACRAPDAS'="A"
I ACRAPVT'=43 D:ACRAPDAF="Y" APV11
I $D(ACRALTY),$D(ACRALTX(ACRALTY)) S ACRDUZ=ACRALTX(ACRALTY)
I ACRAPDAS="A" D
.I ACRAPVT=36 D ;IF TO REQUEST, CK FOR AMT>2500 & SEND MSG ACR*2.1*5.15
..D TO25^ACRFXMY(ACRDOCDA,ACRAPDA) ;ACR*2.1*5.15
.K ^ACRAPVS("ANXT",ACRAPVT,ACRINDV,ACRAPDA),^TMP("ACRDATA",$J,ACRDUZ,ACRJJ),^TMP("ACRALT",$J,ACRDUZ,ACRJJ)
.D CERT^ACRFPRC4:$P(ACRAPV0,U,6)'=$O(^AUTTDOCR("B",602,0))
.D UP
I ACRAPDAS="D" D
.K ^ACRAPVS("ANXT",ACRAPVT,ACRINDV,ACRAPDA),^TMP("ACRDATA",$J,ACRDUZ,ACRJJ),^TMP("ACRALT",$J,ACRDUZ,ACRJJ)
.I $P(^ACRAPVS(ACRAPDA,0),U,11) D OTADEL^ACRFTA Q
.D EN3^ACRFDEL
.S DA=ACRDOCDA
.S DIE="^ACROBL("
.S DR="903////D"
.D DIE^ACRFDIC
Q
APV11 ;SUBROUTINE TO UPDATE OBLIGATION AND DOCUMENT FILE INFO DURING
;APPROVAL PROCESS
I $G(ACRAPDAS)="D",$P(^ACRAPVS(ACRAPDA,0),U,11) Q
W:$E($G(IOST),1,2)="C-" !!,"Document ",$S(ACRAPDAS="A":"",1:"DIS"),"APPROVED, now being forwarded for processing..."
S DA=ACRDOCDA
S DIE="^ACROBL("
S DR="903////"_ACRAPDAS
I "^103^204^349^326^210^600^148^"[(U_ACRREF_U) D
.S:"^103^349^326^210^148^"[(U_ACRREF_U)!(ACRREF=204&($P(^ACRDOC(ACRDOCDA,0),U,4)=30)) DR=DR_";911////"_ACRAPDAS_";905////"_ACRAPDAS
.I ACRREF=600,$P($G(^AUTTDOCR(+$P($G(ACRAPV0),U,6),0)),U)=600 S DR=DR_";911////"_ACRAPDAS_";905////"_ACRAPDAS
D DIE^ACRFDIC
I ACRAPDAF="Y",ACRAPDAS="A" D PROCESS
Q
PROCESS ;PROCESS FINAL APPROVAL SIGNATURE
S ACRPODA=$P(ACRDOC0,U,8)
S ACRLBDA=$P(ACRDOC0,U,6)
S ACRDPTDA=$P(^ACRLOCB(ACRLBDA,0),U,5)
S ACRPA=$P(^ACRDEPT(ACRDPTDA,0),U,3)
I ACRREF=116,'+$G(^ACRDOC(ACRDOCDA,"PA")) D
.S DIE="^ACRDOC("
.S DA=ACRDOCDA
.S ACRPA=$S(ACRPA:ACRPA,1:$P(^ACRPO(ACRPODA,0),U,3))
.S DR=".2////"_ACRPA
.D DIE^ACRFDIC
I ACRREF=116,$P(ACRDOC0,U,19)!($P(ACRDOC0,U,4)=30) D CONV
I "^116^204^101^130^148^"[(U_ACRREF_U) D
.S ACRREFX=ACRREF
.D ^ACRFPRNT
.K ACRREV
I ACRREF=103!(ACRREF=349)!(ACRREF=326)!(ACRREF=210),ACRAPVT=1 D
.D PONUM1^ACRFPRC4
.S ACRPO=""
.I $D(^ACRDOC(ACRDOCDA,3)),$P(^(3),U,13) D FEDSTRIP^ACRFSSA
D OBL^ACRFSS
I "^103^204^349^326^210^130^600^148^"[(U_ACRREF_U)!(ACRREF=116&($P(^ACRDOC(ACRDOCDA,0),U,4)=35)) D
.S:ACRREF=103!(ACRREF=349)!(ACRREF=326)!(ACRREF=210) (ACRPO,ACRPPO)=""
.S ACRREFX=ACRREF
.D:$G(ACRAPVT)'=9 ^ACRFDHR
.D:ACRREF'=130 ^ACRFPRNT
.K ACRREV,ACRPO,ACRPPO
I ACRREF=130,ACRAPVT=21 D
.S (ACRSSDA,ACRTOT)=0
.F S ACRSSDA=$O(^ACRSS("C",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA I $D(^ACRSS(ACRSSDA,"DT")) S ACRTOT=ACRTOT+$P(^("DT"),U,4)
.I ACRTOT D
..S DIE="^ACRDOC("
..S DA=ACRDOCDA
..S DR="130176////"_$G(ACRTOT)
..D DIE^ACRFDIC
;CREATE TRAVEL PAYMENT ENTRY IN 1166
I ACRREF=600,ACRAPVT=38!(ACRAPVT=39),$P($G(^ACRSYS(1,"DT1")),U,9)>1 D PAYT
I ACRREF=148,ACRAPVT=38!(ACRAPVT=39),$P($G(^ACRSYS(1,"DT1")),U,9)>2 D PAYT
I ACRREF=130,$P($G(^ACROTA(ACRDOCDA,0)),U,3)>$P($G(^ACROTA(ACRDOCDA,0)),U,4) D OTAAPP
I ACRREF=116!(ACRREF=101)!(ACRREF=130)!(ACRREF=210&($P(^ACROBL(ACRDOCDA,"APV"),U,3)="")) D CONV
I ACRAPVT=1 D POAPP^ACRFXMY
I ACRAPVT=21 D TOAPP^ACRFXMY
I ACRAPVT=22 D TRAPP^ACRFXMY
I ACRAPVT=38!(ACRAPVT=39) D TVAPP^ACRFXMY
I $P(^ACRDOC(ACRDOCDA,0),U,4)=30 D RR
Q
CONV ;EP;CONVERT REQUEST TO PO AND TRAVEL ORDER TO TRAVEL VOUCHER WHEN APPROVED
S ACRREF=$S(ACRREF=130:600,$P(^ACRDOC(ACRDOCDA,0),U,4)=30:204,$P(^(0),U,24)&($P(^(0),U,24)<4):349,$P(^(0),U,24)=4:326,"^116^204^101^103^210^"[(U_ACRREF_U):103,1:ACRREF)
S:$P($G(^ACRDOC(ACRDOCDA,3)),U,13) ACRREF=210
S ACRREFDA=$O(^AUTTDOCR("B",ACRREF,0))
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR=".13///"_ACRREF
N ACRBPA
I ACRREF=103!(ACRREF=349)!(ACRREF=326)!(ACRREF=210) D
.S DR=DR_";.4////"_$P(^ACRPO($P(ACRDOC0,U,8),0),U,3)
.I $P(^ACRDOC(ACRDOCDA,0),U,19) D
..S ACRBPA=$P(^ACRDOC(ACRDOCDA,0),U,19)
..S ACRUSER=+^ACRDOC(ACRBPA,"PA")
..S DR=DR_";.2////"_ACRUSER_";.3////"_DT
S:ACRREF=600 DR=DR_";130155////"_DT
S:ACRREF=148 DR=DR_";148320////"_DT
K ACRTXDAX
D DIE^ACRFDIC
S ACRTXDA=$P(ACRDOC0,U,4)
S DA=ACRDOCDA
S DIE="^ACROBL("
S DR=".1///"_ACRREF_";906////Y"
S:ACRREF=600 DR=DR_";910////19"
D DIE^ACRFDIC
S ACRY=ACRDOCDA
S ACRDA=0
F S ACRDA=$O(^ACRSS("C",ACRY,ACRDA)) Q:'ACRDA D
.S DA=ACRDA
.S DIE="^ACRSS("
.S DR=".1///"_ACRREF
.D DIE^ACRFDIC
BPA ;IF CALL AGAINST BPA OR CREDIT CARD PURCHASE
;AUTHORIZE PURCHASE AND BYPASS PURCHASING
;I $P(^ACRDOC(ACRDOCDA,0),U,19)!($P(^(0),U,25))!($P(^(0),U,4)=35)!($P(^(0),U,12)) D
I $P(^ACRDOC(ACRDOCDA,0),U,19)!($P(^(0),U,25)&($P(^(0),U,4)=35)) D
.S DA=ACRDOCDA
.S DIE="^ACROBL("
.S DR="905////A;911////A"
.D DIE^ACRFDIC
.S DA=ACRDOCDA
.S DIE="^ACRDOC("
.S DR=".13///103"
.D DIE^ACRFDIC
Q
AP1 ;EP;CHECK IF THE CURRENT USER IS SUPPOSED TO SIGN DOCUMENT IN ANY OTHER
;CAPACITY AND PROCESSES ADDITIONAL SIGNATURES
K ACRP11
N ACRAPDA
S ACRAPDA=0
F S ACRAPDA=$O(ACRSIGN(ACRAPDA)) Q:'ACRAPDA D APX
Q
PAYT ;SEND TRAVEL PAYMENT INFO TO 1166
K ACRIVPAY
N J,X,Y,Z
S X=0
F J=1:1 S X=$O(^ACRSS("J",ACRDOCDA,X)) Q:'X D
.S Y=$G(^ACRSS(X,0))
.S Z=$G(^ACRSS(X,"DT"))
.Q:'$P(Y,U,4)!'$P(Y,U,5)
.I J=1,ACRREF'=148,$P($G(^ACRDOC(ACRDOCDA,"TOAU")),U,5)'=1 Q
.S ACRIVPAY($P(Y,U,5),$P(Y,U,4))=$G(ACRIVPAY($P(Y,U,5),$P(Y,U,4)))+$P(Z,U,4)
Q:'$P(Y,U,4)!'$P(Y,U,5)
S ACRIVPAY($P(Y,U,5),$P(Y,U,4))=$G(ACRIVPAY($P(Y,U,5),$P(Y,U,4)))-$P($G(^ACROTA(ACRDOCDA,0)),U,3)+$P($G(^(0)),U,4)
S X=DT
I $E(X,4,7)=1225 S X=$E(X,1,3)_1224
I $E(X,4,7)="0101" S X=$E(X,1,3)_"0102"
I $E(X,4,7)="0704" S X=$E(X,1,3)_"0705"
S Z=X
D DW^%DTC
I $E(X)="S" D
.S X1=Z
.S X2=$S($E(X,1,2)="SA":-1,1:-2)
.D C^%DTC
.S Z=X
S Y=$S(Z>DT:Z,1:DT)
S ACRPAYDA=Y
S ACRBTYP=$S(ACRREF'=148:"T",1:"V")
D ^ACRFIV11
K ACRIVPAY
Q
RR ;PROCESS RECEIVING FOR MISC OBLIGATION DOCUMENTS
N ACRSSDA
S ACRSSDA=0
F S ACRSSDA=$O(^ACRSS("J",ACRDOCDA,ACRSSDA)) Q:'ACRSSDA D
.S ACRSS0=$G(^ACRSS(ACRSSDA,0))
.S ACRSSDT=$G(^ACRSS(ACRSSDA,"DT"))
.S X=ACRSSDA
.S DIC="^ACRRR("
.S DIC(0)="L"
.S DIC("DR")=".02////"_ACRDOCDA_";.03////"_ACRDOCDA_";.04////1;.05////"_DUZ_";.06////"_DT_";.07////"_DT_";.08////1;1////"_$P(ACRSSDT,U,3)_";2////"_$P(ACRSSDT,U)_";3////"_$P(ACRSSDT,U)_";4////"_DT
.D FILE^ACRFDIC
S DA=ACRDOCDA
S DIE="^ACROBL("
S DR="909////1;911////"_ACRAPDAS_";905////"_ACRAPDAS
D DIE^ACRFDIC
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR="113210////"_DT
D DIE^ACRFDIC
Q
OTAAPP ;CREATE APPROVAL FOR OUTSTANDING TRAVEL ADVANCE
N ACRREFDA,ACRFINAL,ACRAPVT,ACRORDER,ACRLBDA,ACRUSER,ACRDATE,ACRINDV,ACRAPDA
S ACRREFDA=$O(^AUTTDOCR("B",602,0))
D KILL^ACRFAPVS
S ACRFINAL="N"
S ACRAPVT=39
S ACRORDER=1
S ACRLBDA=$P(^ACRDOC(ACRDOCDA,0),U,6)
S ACRUSER=$P(^ACRDOC(ACRDOCDA,"TO"),U,24)
Q:'ACRUSER
D NOW^%DTC
S ACRDATE=%
D SETAPP^ACRFAPVS
S (DA,ACRAPDA)=+Y
S ^ACRAPVS("ANXT",39,+ACRUSER,ACRAPDA)=ACRDOCDA
S ACRUSERZ=ACRUSER
S ACRAPDAZ=ACRAPDA
S DIE="^ACRAPVS("
S DR=".11////"_ACRDOCDA
D DIE^ACRFDIC
S ACRFINAL="Y"
S ACRAPVT=15
S ACRORDER=2
S ACRREFDA=$O(^AUTTDOCR("B",602,0))
S ACRLBDA=$P(^ACRDOC(ACRDOCDA,0),U,6)
;When a doucment is created, all of the Signature authorities
;are set into the FMS Document file, regardless of the type of request.
;The Area FMO is retrieved from the FMS System Default file and set
;into the REQ1 node and is not an editable field for the user.
;Sometimes this value is reset to a different person, by-passing the
;data dictionary input transform, which verifies that the person has
;the signature authority. Have not been able to find the cause of the
;error. Frequently, the erroneous value does not have the signature
;authority, so the document never comes up for approval. Appears to go
;into a black hole. This can create a problem when a travel advance is
;requested as the routines are hard-coded to use the Area FMO signature
;for the final approval for the advance. This is a band-aid fix that
;ignores what is in the Document file and uses the value in the FMS
;System Default file.
;
;S ACRUSER=$P(^ACRDOC(ACRDOCDA,"REQ1"),U,13) ;COMMENTED OUT ;ACR*2.1*3.38
S ACRUSER=$P(^ACRSYS(1,"DT"),U,5) ; Default Area FMO ;ACR*2.1*3.38
Q:'ACRUSER
D NOW^%DTC
S ACRDATE=%
D SETAPP^ACRFAPVS
S (DA,ACRAPDA)=+Y
S DIE="^ACRAPVS("
S DR=".11////"_ACRDOCDA
D DIE^ACRFDIC
ZZ ;EP;
S ^ACRAPVS("ANXT",39,+ACRUSERZ,ACRAPDAZ)=ACRDOCDA
Q
ACRFPRC3 ;IHS/OIRM/DSD/THL,AEF - PROCESS PENDING DOCUMENTS; [ 01/03/2003 9:53 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**3,5**;NOV 05, 2001
+2 ;;CONTINUATION OF ACRFPRCS
UP ;EP;TO SET NEXT APPROVAL TO BE PROCESSED
+1 NEW ACRAPDA
+2 KILL ACRQUIT,ACROUT
+3 SET ACRORD=0
+4 FOR
SET ACRORD=$ORDER(^ACRAPVS("AORDR",ACRDOCDA,ACRORD))
IF 'ACRORD!$DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
Begin DoDot:1
+5 SET ACRAPDA=0
+6 FOR
SET ACRAPDA=$ORDER(^ACRAPVS("AORDR",ACRDOCDA,ACRORD,ACRAPDA))
IF 'ACRAPDA!$DATA(ACRQUIT)
QUIT
Begin DoDot:2
+7 SET ACRAPV0=$GET(^ACRAPVS(ACRAPDA,0))
+8 SET ACRAPVDT=$GET(^ACRAPVS(ACRAPDA,"DT"))
+9 IF $PIECE(ACRAPVDT,U)]""
QUIT
+10 IF DT<$PIECE(ACRAPVDT,U,8)
QUIT
+11 KILL ACRQUIT
+12 DO NOW^%DTC
+13 SET ACRNOW=%
+14 SET ACRAPVT=$PIECE(ACRAPV0,U,3)
+15 SET ACRINDV=$PIECE(ACRAPVDT,U,2)
+16 IF ACRAPVT=""!(ACRINDV="")
SET ACRQUIT=""
QUIT
+17 SET $PIECE(^ACRAPVS(ACRAPDA,"DT"),U,3)=ACRNOW
+18 SET ^ACRAPVS("ANXT",ACRAPVT,ACRINDV,ACRAPDA)=ACRDOCDA_U_$PIECE(ACRAPVDT,U,8)
+19 SET $PIECE(^ACRAPVS(ACRAPDA,"DT"),U,3)=ACRNOW
+20 DO DOMAIN^ACRFNXT
+21 KILL ACRINDV,ACRAPV0,ACRAPVDT
+22 SET ACRQUIT=""
End DoDot:2
End DoDot:1
+23 KILL ACRQUIT
+24 QUIT
APX ;EP;SUBROUTINE TO UPDATES INFO IN THE APPROVAL FILE FOR EACH DOCUMENT
+1 ;APPROVAL. ALSO, CREATES A MAILMAN MESSAGE WHENEVER DOCUMENT IS NOT
+2 ;APPROVED OR WHEN ANY MESSAGE IS ENTERED AT TIME OF APPROVAL
+3 IF +$$SIGSCR^ACRFPRC1($GET(ACRAPVT),.ACRAPVS,$PIECE($GET(^ACRDOC(ACRDOCDA,"TO")),U,9),$PIECE($GET(^ACRDOC(ACRDOCDA,"TRNG")),U,2),DUZ)
QUIT
+4 DO NOW^%DTC
+5 SET ACRNOW=%
+6 SET DA=ACRAPDA
+7 SET DIE="^ACRAPVS("
+8 SET DR="1////"_ACRAPDAS_";6////"_DUZ_";4////"_ACRNOW
+9 IF $DATA(ACRSIGN(ACRAPDA))
SET DR=DR_";3////"_ACRNOW
+10 DO DIE^ACRFDIC
+11 SET ACRAPV0=^ACRAPVS(ACRAPDA,0)
+12 SET ACRAPVDT=^ACRAPVS(ACRAPDA,"DT")
+13 SET X=^ACRAPVT($PIECE(ACRAPV0,U,3),"DT")
+14 SET ACRGLB=$PIECE(X,U)
+15 SET ACRPC=$PIECE(X,U,2)
+16 SET ACRTXTYP=$PIECE(ACRDOC0,U,4)
+17 SET ACRAPVT=$PIECE(ACRAPV0,U,3)
+18 SET ACRAPDAS=$PIECE(ACRAPVDT,U)
+19 SET ACRAPDAF=$EXTRACT($PIECE(ACRAPVDT,U,5))
+20 SET ACRINDV=$PIECE(ACRAPVDT,U,2)
+21 SET ACRORD=$PIECE(ACRAPV0,U,4)
+22 IF ACRAPVT=15
IF $PIECE(ACRAPV0,U,6)=$ORDER(^AUTTDOCR("B",602,0))
IF ACRAPDAS="A"
DO OTA^ACRFTA
IF ACRAPDAS'="A"
QUIT
+23 IF ACRAPVT'=43
IF ACRAPDAF="Y"
DO APV11
+24 IF $DATA(ACRALTY)
IF $DATA(ACRALTX(ACRALTY))
SET ACRDUZ=ACRALTX(ACRALTY)
+25 IF ACRAPDAS="A"
Begin DoDot:1
+26 ;IF TO REQUEST, CK FOR AMT>2500 & SEND MSG ACR*2.1*5.15
IF ACRAPVT=36
Begin DoDot:2
+27 ;ACR*2.1*5.15
DO TO25^ACRFXMY(ACRDOCDA,ACRAPDA)
End DoDot:2
+28 KILL ^ACRAPVS("ANXT",ACRAPVT,ACRINDV,ACRAPDA),^TMP("ACRDATA",$JOB,ACRDUZ,ACRJJ),^TMP("ACRALT",$JOB,ACRDUZ,ACRJJ)
+29 IF $PIECE(ACRAPV0,U,6)'=$ORDER(^AUTTDOCR("B",602,0))
DO CERT^ACRFPRC4
+30 DO UP
End DoDot:1
+31 IF ACRAPDAS="D"
Begin DoDot:1
+32 KILL ^ACRAPVS("ANXT",ACRAPVT,ACRINDV,ACRAPDA),^TMP("ACRDATA",$JOB,ACRDUZ,ACRJJ),^TMP("ACRALT",$JOB,ACRDUZ,ACRJJ)
+33 IF $PIECE(^ACRAPVS(ACRAPDA,0),U,11)
DO OTADEL^ACRFTA
QUIT
+34 DO EN3^ACRFDEL
+35 SET DA=ACRDOCDA
+36 SET DIE="^ACROBL("
+37 SET DR="903////D"
+38 DO DIE^ACRFDIC
End DoDot:1
+39 QUIT
APV11 ;SUBROUTINE TO UPDATE OBLIGATION AND DOCUMENT FILE INFO DURING
+1 ;APPROVAL PROCESS
+2 IF $GET(ACRAPDAS)="D"
IF $PIECE(^ACRAPVS(ACRAPDA,0),U,11)
QUIT
+3 IF $EXTRACT($GET(IOST),1,2)="C-"
WRITE !!,"Document ",$SELECT(ACRAPDAS="A":"",1:"DIS"),"APPROVED, now being forwarded for processing..."
+4 SET DA=ACRDOCDA
+5 SET DIE="^ACROBL("
+6 SET DR="903////"_ACRAPDAS
+7 IF "^103^204^349^326^210^600^148^"[(U_ACRREF_U)
Begin DoDot:1
+8 IF "^103^349^326^210^148^"[(U_ACRREF_U)!(ACRREF=204&($PIECE(^ACRDOC(ACRDOCDA,0),U,4)=30))
SET DR=DR_";911////"_ACRAPDAS_";905////"_ACRAPDAS
+9 IF ACRREF=600
IF $PIECE($GET(^AUTTDOCR(+$PIECE($GET(ACRAPV0),U,6),0)),U)=600
SET DR=DR_";911////"_ACRAPDAS_";905////"_ACRAPDAS
End DoDot:1
+10 DO DIE^ACRFDIC
+11 IF ACRAPDAF="Y"
IF ACRAPDAS="A"
DO PROCESS
+12 QUIT
PROCESS ;PROCESS FINAL APPROVAL SIGNATURE
+1 SET ACRPODA=$PIECE(ACRDOC0,U,8)
+2 SET ACRLBDA=$PIECE(ACRDOC0,U,6)
+3 SET ACRDPTDA=$PIECE(^ACRLOCB(ACRLBDA,0),U,5)
+4 SET ACRPA=$PIECE(^ACRDEPT(ACRDPTDA,0),U,3)
+5 IF ACRREF=116
IF '+$GET(^ACRDOC(ACRDOCDA,"PA"))
Begin DoDot:1
+6 SET DIE="^ACRDOC("
+7 SET DA=ACRDOCDA
+8 SET ACRPA=$SELECT(ACRPA:ACRPA,1:$PIECE(^ACRPO(ACRPODA,0),U,3))
+9 SET DR=".2////"_ACRPA
+10 DO DIE^ACRFDIC
End DoDot:1
+11 IF ACRREF=116
IF $PIECE(ACRDOC0,U,19)!($PIECE(ACRDOC0,U,4)=30)
DO CONV
+12 IF "^116^204^101^130^148^"[(U_ACRREF_U)
Begin DoDot:1
+13 SET ACRREFX=ACRREF
+14 DO ^ACRFPRNT
+15 KILL ACRREV
End DoDot:1
+16 IF ACRREF=103!(ACRREF=349)!(ACRREF=326)!(ACRREF=210)
IF ACRAPVT=1
Begin DoDot:1
+17 DO PONUM1^ACRFPRC4
+18 SET ACRPO=""
+19 IF $DATA(^ACRDOC(ACRDOCDA,3))
IF $PIECE(^(3),U,13)
DO FEDSTRIP^ACRFSSA
End DoDot:1
+20 DO OBL^ACRFSS
+21 IF "^103^204^349^326^210^130^600^148^"[(U_ACRREF_U)!(ACRREF=116&($PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35))
Begin DoDot:1
+22 IF ACRREF=103!(ACRREF=349)!(ACRREF=326)!(ACRREF=210)
SET (ACRPO,ACRPPO)=""
+23 SET ACRREFX=ACRREF
+24 IF $GET(ACRAPVT)'=9
DO ^ACRFDHR
+25 IF ACRREF'=130
DO ^ACRFPRNT
+26 KILL ACRREV,ACRPO,ACRPPO
End DoDot:1
+27 IF ACRREF=130
IF ACRAPVT=21
Begin DoDot:1
+28 SET (ACRSSDA,ACRTOT)=0
+29 FOR
SET ACRSSDA=$ORDER(^ACRSS("C",ACRDOCDA,ACRSSDA))
IF 'ACRSSDA
QUIT
IF $DATA(^ACRSS(ACRSSDA,"DT"))
SET ACRTOT=ACRTOT+$PIECE(^("DT"),U,4)
+30 IF ACRTOT
Begin DoDot:2
+31 SET DIE="^ACRDOC("
+32 SET DA=ACRDOCDA
+33 SET DR="130176////"_$GET(ACRTOT)
+34 DO DIE^ACRFDIC
End DoDot:2
End DoDot:1
+35 ;CREATE TRAVEL PAYMENT ENTRY IN 1166
+36 IF ACRREF=600
IF ACRAPVT=38!(ACRAPVT=39)
IF $PIECE($GET(^ACRSYS(1,"DT1")),U,9)>1
DO PAYT
+37 IF ACRREF=148
IF ACRAPVT=38!(ACRAPVT=39)
IF $PIECE($GET(^ACRSYS(1,"DT1")),U,9)>2
DO PAYT
+38 IF ACRREF=130
IF $PIECE($GET(^ACROTA(ACRDOCDA,0)),U,3)>$PIECE($GET(^ACROTA(ACRDOCDA,0)),U,4)
DO OTAAPP
+39 IF ACRREF=116!(ACRREF=101)!(ACRREF=130)!(ACRREF=210&($PIECE(^ACROBL(ACRDOCDA,"APV"),U,3)=""))
DO CONV
+40 IF ACRAPVT=1
DO POAPP^ACRFXMY
+41 IF ACRAPVT=21
DO TOAPP^ACRFXMY
+42 IF ACRAPVT=22
DO TRAPP^ACRFXMY
+43 IF ACRAPVT=38!(ACRAPVT=39)
DO TVAPP^ACRFXMY
+44 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,4)=30
DO RR
+45 QUIT
CONV ;EP;CONVERT REQUEST TO PO AND TRAVEL ORDER TO TRAVEL VOUCHER WHEN APPROVED
+1 SET ACRREF=$SELECT(ACRREF=130:600,$PIECE(^ACRDOC(ACRDOCDA,0),U,4)=30:204,$PIECE(^(0),U,24)&($PIECE(^(0),U,24)<4):349,$PIECE(^(0),U,24)=4:326,"^116^204^101^103^210^"[(U_ACRREF_U):103,1:ACRREF)
+2 IF $PIECE($GET(^ACRDOC(ACRDOCDA,3)),U,13)
SET ACRREF=210
+3 SET ACRREFDA=$ORDER(^AUTTDOCR("B",ACRREF,0))
+4 SET DA=ACRDOCDA
+5 SET DIE="^ACRDOC("
+6 SET DR=".13///"_ACRREF
+7 NEW ACRBPA
+8 IF ACRREF=103!(ACRREF=349)!(ACRREF=326)!(ACRREF=210)
Begin DoDot:1
+9 SET DR=DR_";.4////"_$PIECE(^ACRPO($PIECE(ACRDOC0,U,8),0),U,3)
+10 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,19)
Begin DoDot:2
+11 SET ACRBPA=$PIECE(^ACRDOC(ACRDOCDA,0),U,19)
+12 SET ACRUSER=+^ACRDOC(ACRBPA,"PA")
+13 SET DR=DR_";.2////"_ACRUSER_";.3////"_DT
End DoDot:2
End DoDot:1
+14 IF ACRREF=600
SET DR=DR_";130155////"_DT
+15 IF ACRREF=148
SET DR=DR_";148320////"_DT
+16 KILL ACRTXDAX
+17 DO DIE^ACRFDIC
+18 SET ACRTXDA=$PIECE(ACRDOC0,U,4)
+19 SET DA=ACRDOCDA
+20 SET DIE="^ACROBL("
+21 SET DR=".1///"_ACRREF_";906////Y"
+22 IF ACRREF=600
SET DR=DR_";910////19"
+23 DO DIE^ACRFDIC
+24 SET ACRY=ACRDOCDA
+25 SET ACRDA=0
+26 FOR
SET ACRDA=$ORDER(^ACRSS("C",ACRY,ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:1
+27 SET DA=ACRDA
+28 SET DIE="^ACRSS("
+29 SET DR=".1///"_ACRREF
+30 DO DIE^ACRFDIC
End DoDot:1
BPA ;IF CALL AGAINST BPA OR CREDIT CARD PURCHASE
+1 ;AUTHORIZE PURCHASE AND BYPASS PURCHASING
+2 ;I $P(^ACRDOC(ACRDOCDA,0),U,19)!($P(^(0),U,25))!($P(^(0),U,4)=35)!($P(^(0),U,12)) D
+3 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,19)!($PIECE(^(0),U,25)&($PIECE(^(0),U,4)=35))
Begin DoDot:1
+4 SET DA=ACRDOCDA
+5 SET DIE="^ACROBL("
+6 SET DR="905////A;911////A"
+7 DO DIE^ACRFDIC
+8 SET DA=ACRDOCDA
+9 SET DIE="^ACRDOC("
+10 SET DR=".13///103"
+11 DO DIE^ACRFDIC
End DoDot:1
+12 QUIT
AP1 ;EP;CHECK IF THE CURRENT USER IS SUPPOSED TO SIGN DOCUMENT IN ANY OTHER
+1 ;CAPACITY AND PROCESSES ADDITIONAL SIGNATURES
+2 KILL ACRP11
+3 NEW ACRAPDA
+4 SET ACRAPDA=0
+5 FOR
SET ACRAPDA=$ORDER(ACRSIGN(ACRAPDA))
IF 'ACRAPDA
QUIT
DO APX
+6 QUIT
PAYT ;SEND TRAVEL PAYMENT INFO TO 1166
+1 KILL ACRIVPAY
+2 NEW J,X,Y,Z
+3 SET X=0
+4 FOR J=1:1
SET X=$ORDER(^ACRSS("J",ACRDOCDA,X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=$GET(^ACRSS(X,0))
+6 SET Z=$GET(^ACRSS(X,"DT"))
+7 IF '$PIECE(Y,U,4)!'$PIECE(Y,U,5)
QUIT
+8 IF J=1
IF ACRREF'=148
IF $PIECE($GET(^ACRDOC(ACRDOCDA,"TOAU")),U,5)'=1
QUIT
+9 SET ACRIVPAY($PIECE(Y,U,5),$PIECE(Y,U,4))=$GET(ACRIVPAY($PIECE(Y,U,5),$PIECE(Y,U,4)))+$PIECE(Z,U,4)
End DoDot:1
+10 IF '$PIECE(Y,U,4)!'$PIECE(Y,U,5)
QUIT
+11 SET ACRIVPAY($PIECE(Y,U,5),$PIECE(Y,U,4))=$GET(ACRIVPAY($PIECE(Y,U,5),$PIECE(Y,U,4)))-$PIECE($GET(^ACROTA(ACRDOCDA,0)),U,3)+$PIECE($GET(^(0)),U,4)
+12 SET X=DT
+13 IF $EXTRACT(X,4,7)=1225
SET X=$EXTRACT(X,1,3)_1224
+14 IF $EXTRACT(X,4,7)="0101"
SET X=$EXTRACT(X,1,3)_"0102"
+15 IF $EXTRACT(X,4,7)="0704"
SET X=$EXTRACT(X,1,3)_"0705"
+16 SET Z=X
+17 DO DW^%DTC
+18 IF $EXTRACT(X)="S"
Begin DoDot:1
+19 SET X1=Z
+20 SET X2=$SELECT($EXTRACT(X,1,2)="SA":-1,1:-2)
+21 DO C^%DTC
+22 SET Z=X
End DoDot:1
+23 SET Y=$SELECT(Z>DT:Z,1:DT)
+24 SET ACRPAYDA=Y
+25 SET ACRBTYP=$SELECT(ACRREF'=148:"T",1:"V")
+26 DO ^ACRFIV11
+27 KILL ACRIVPAY
+28 QUIT
RR ;PROCESS RECEIVING FOR MISC OBLIGATION DOCUMENTS
+1 NEW ACRSSDA
+2 SET ACRSSDA=0
+3 FOR
SET ACRSSDA=$ORDER(^ACRSS("J",ACRDOCDA,ACRSSDA))
IF 'ACRSSDA
QUIT
Begin DoDot:1
+4 SET ACRSS0=$GET(^ACRSS(ACRSSDA,0))
+5 SET ACRSSDT=$GET(^ACRSS(ACRSSDA,"DT"))
+6 SET X=ACRSSDA
+7 SET DIC="^ACRRR("
+8 SET DIC(0)="L"
+9 SET DIC("DR")=".02////"_ACRDOCDA_";.03////"_ACRDOCDA_";.04////1;.05////"_DUZ_";.06////"_DT_";.07////"_DT_";.08////1;1////"_$PIECE(ACRSSDT,U,3)_";2////"_$PIECE(ACRSSDT,U)_";3////"_$PIECE(ACRSSDT,U)_";4////"_DT
+10 DO FILE^ACRFDIC
End DoDot:1
+11 SET DA=ACRDOCDA
+12 SET DIE="^ACROBL("
+13 SET DR="909////1;911////"_ACRAPDAS_";905////"_ACRAPDAS
+14 DO DIE^ACRFDIC
+15 SET DA=ACRDOCDA
+16 SET DIE="^ACRDOC("
+17 SET DR="113210////"_DT
+18 DO DIE^ACRFDIC
+19 QUIT
OTAAPP ;CREATE APPROVAL FOR OUTSTANDING TRAVEL ADVANCE
+1 NEW ACRREFDA,ACRFINAL,ACRAPVT,ACRORDER,ACRLBDA,ACRUSER,ACRDATE,ACRINDV,ACRAPDA
+2 SET ACRREFDA=$ORDER(^AUTTDOCR("B",602,0))
+3 DO KILL^ACRFAPVS
+4 SET ACRFINAL="N"
+5 SET ACRAPVT=39
+6 SET ACRORDER=1
+7 SET ACRLBDA=$PIECE(^ACRDOC(ACRDOCDA,0),U,6)
+8 SET ACRUSER=$PIECE(^ACRDOC(ACRDOCDA,"TO"),U,24)
+9 IF 'ACRUSER
QUIT
+10 DO NOW^%DTC
+11 SET ACRDATE=%
+12 DO SETAPP^ACRFAPVS
+13 SET (DA,ACRAPDA)=+Y
+14 SET ^ACRAPVS("ANXT",39,+ACRUSER,ACRAPDA)=ACRDOCDA
+15 SET ACRUSERZ=ACRUSER
+16 SET ACRAPDAZ=ACRAPDA
+17 SET DIE="^ACRAPVS("
+18 SET DR=".11////"_ACRDOCDA
+19 DO DIE^ACRFDIC
+20 SET ACRFINAL="Y"
+21 SET ACRAPVT=15
+22 SET ACRORDER=2
+23 SET ACRREFDA=$ORDER(^AUTTDOCR("B",602,0))
+24 SET ACRLBDA=$PIECE(^ACRDOC(ACRDOCDA,0),U,6)
+25 ;When a doucment is created, all of the Signature authorities
+26 ;are set into the FMS Document file, regardless of the type of request.
+27 ;The Area FMO is retrieved from the FMS System Default file and set
+28 ;into the REQ1 node and is not an editable field for the user.
+29 ;Sometimes this value is reset to a different person, by-passing the
+30 ;data dictionary input transform, which verifies that the person has
+31 ;the signature authority. Have not been able to find the cause of the
+32 ;error. Frequently, the erroneous value does not have the signature
+33 ;authority, so the document never comes up for approval. Appears to go
+34 ;into a black hole. This can create a problem when a travel advance is
+35 ;requested as the routines are hard-coded to use the Area FMO signature
+36 ;for the final approval for the advance. This is a band-aid fix that
+37 ;ignores what is in the Document file and uses the value in the FMS
+38 ;System Default file.
+39 ;
+40 ;S ACRUSER=$P(^ACRDOC(ACRDOCDA,"REQ1"),U,13) ;COMMENTED OUT ;ACR*2.1*3.38
+41 ; Default Area FMO ;ACR*2.1*3.38
SET ACRUSER=$PIECE(^ACRSYS(1,"DT"),U,5)
+42 IF 'ACRUSER
QUIT
+43 DO NOW^%DTC
+44 SET ACRDATE=%
+45 DO SETAPP^ACRFAPVS
+46 SET (DA,ACRAPDA)=+Y
+47 SET DIE="^ACRAPVS("
+48 SET DR=".11////"_ACRDOCDA
+49 DO DIE^ACRFDIC
ZZ ;EP;
+1 SET ^ACRAPVS("ANXT",39,+ACRUSERZ,ACRAPDAZ)=ACRDOCDA
+2 QUIT
