Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACRFPRC3

ACRFPRC3.m

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