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

ACRFDTP4.m

Go to the documentation of this file. 
  1. ACRFDTP4 ;IHS/OIRM/DSD/THL,AEF - ACRFDTP CON'T;  [ 07/20/2006   9:44 AM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;**20**;NOV 05, 2001
  1.  ;;CONTINUATION OF ACRFDTP TO DISPLAY FINANCIAL DATA AND ACCOUNTS
  1. DISP ;EP;
  1. OBLAMT I '$D(^ACROBL(ACRFD,0))!'$D(^ACROBL(ACRFD,"DT")) D  Q
  1.  .S (DA,ACRFD2)=ACRFD
  1.  .S DIK="^ACROBL("
  1.  .D DIK^ACRFDIC
  1.  .S DA=ACRFD
  1.  .S DIK="^ACRDOC("
  1.  .D DIK^ACRFDIC
  1.  .S ACRDA=0
  1.  .F  S ACRDA=$O(^ACRSS("C",ACRFD,ACRDA)) Q:'ACRDA  D
  1.  ..S DA=ACRDA
  1.  ..S DIK="^ACRSS("
  1.  ..D DIK^ACRFDIC
  1.  .S ACRJ=ACRJ-1
  1.  S ACRDISA=""
  1.  I $D(^ACRAPVS("AB",ACRFD)) D
  1.  .S ACR=0
  1.  .F  S ACR=$O(^ACRAPVS("AB",ACRFD,ACR)) Q:'ACR  D
  1.  ..I $D(^ACRAPVS(ACR,"DT")),$P(^("DT"),U)="D" S ACRDISA="D"
  1.  I ACRDISA="",$E(^ACRDOC(ACRFD,"DT"),1,3)="1^0" S ACRDISA="*"
  1.  S ACRFD2=$S($P(^ACRDOC(ACRFD,0),U,2)]""&($D(ACRPO)!$D(ACRPOA)):$P(^(0),U,2),1:$P(^(0),U))
  1.  S ACRID=$E($P(^ACRDOC(ACRDOCDA,0),U,14),1,16)
  1.  S ACR(ACRJ)=ACRFD_U_U_(ACRFD2)_U_ACRID_U_ACRDISA_U_U_$P($G(^ACRDOC(ACRFD,"REQ2")),U,6)
  1.  Q
  1. LOCBAMT N ACRFY
  1.  S ACRFD0=$G(^ACRLOCB(ACRFD,0))
  1.  S ACRFDT=$G(^ACRLOCB(ACRFD,"DT"))
  1.  S ACRCANDA=$P(ACRFDT,U,9)
  1.  S ACRFY=$P(ACRFDT,U)
  1.  S ACRSSADA=$P(ACRFDT,U,8)
  1.  S ACRALCDA=$P(ACRFD0,U,4)
  1.  S ACRFD3=$S(ACRSSADA:$P(^AUTTSSA(ACRSSADA,0),U,4),1:"XX")
  1.  S ACRFD2=$S(ACRCANDA:$P(^AUTTCAN(ACRCANDA,0),U),1:"<UNDEF>")
  1.  S ACRFDX=$S($P(ACRFD0,U,5):$P(^AUTTPRG($P(ACRFD0,U,5),0),U)_" ("_$P(^(0),U,2)_")",1:"** NO DEPARTMENT LISTED **")
  1.  S ACR(ACRJ)=ACRFD_U_ACRFD1_U_(ACRFD2)_U_U_ACRFDX_U_ACRCANDA_U_(ACRFD3)_U_$S(ACRFY]"":ACRFY,1:"**")
  1.  Q
  1. ALCAMT S ACRFD0=^ACRALC(ACRFD,0)
  1.  S ACRFDT=^ACRALC(ACRFD,"DT")
  1.  S ACRFY=$P(ACRFDT,U)
  1.  S ACRFD2=$S($P(ACRFDT,U,5):$P(^AUTTALLW($P(ACRFDT,U,5),0),U),1:"XX")
  1.  S ACRFDX=$E($P(ACRFD0,U,12),1,18)
  1.  S ACRFD3=$S($P(ACRFDT,U,8):$P(^AUTTSSA($P(ACRFDT,U,8),0),U),1:"XX")
  1.  S ACR(ACRJ)=ACRFD_U_ACRFD1_U_(ACRFD2)_U_(ACRFD3)_U_ACRFDX_U_$S(ACRFY]"":ACRFY,1:"**")
  1.  Q
  1. ALLAMT S ACRFDT=$G(^ACRALW(ACRFD,"DT"))
  1.  S ACRFY=$P(ACRFDT,U)
  1.  S ACRFDX=$E($P(^ACRALW(ACRFD,0),U,12),1,18)
  1.  S ACRFD2=$S($P(ACRFDT,U,5):$P(^AUTTALLW($P(ACRFDT,U,5),0),U),1:"XXXXX")
  1.  S ACRFD3=$S($P(ACRFDT,U,8):$P(^AUTTSSA($P(ACRFDT,U,8),0),U),1:"XX")
  1.  S ACR(ACRJ)=ACRFD_U_ACRFD1_U_(ACRFD2)_U_(ACRFD3)_U_ACRFDX_U_$S(ACRFY]"":ACRFY,1:"**")
  1.  Q
  1. APPAMT S ACRFD2=$P(^AUTTPRO($P(^ACRAPP(ACRFD,0),U,2),0),U)
  1.  S ACR(ACRJ)=ACRFD_U_ACRFD1_U_(ACRFD2)_"^^^"_$S($P(^ACRAPP(ACRFD,"DT"),U)]"":$P(^("DT"),U),1:"**")
  1.  Q
  1. EDIC ;EP;
  1.  D:$G(ACRI)>9 CHOOSE Q:$D(ACRQUIT)!$D(ACROUT)
  1.  K ACRXACT,ACRI
  1.  S DIC=ACRDIC
  1.  S DIC("A")=ACRDIC("A")
  1.  S DIC(0)=ACRDIC(0)
  1.  S DIC("DR")="",D=ACRD
  1.  D DIC^ACRFDIC:ACRDIC(0)["M"
  1.  D IX^ACRFDIC:ACRDIC(0)'["M"
  1.  I $E(X)=U!(X="")!(Y<1) S (ACRQUIT,ACROUT)="" K ACRFD,ACRFDNA Q
  1.  I ACRDIC(0)["N",$P(Y,U,3)'=1,X,+Y'=+X S Y=+X
  1.  S (DA,ACRZDA,ACRFDNO)=+Y
  1.  S ACRFDNA=Y(0,0)
  1.  S ACRZY=Y
  1.  Q:'$D(@(ACRDIC_DA_",0)"))
  1.  S ACRFD0=@(ACRDIC_DA_",0)")
  1.  I $P(Y,U,3)'=1 D ICHECK
  1.  I $D(ACRQUIT) S (ACRQUIT,ACROUT)="" K ACRFD,ACRFDNA Q
  1.  I $P(Y,U,3)=1,ACRDIC'["OBL" D
  1.  .S X=DUZ
  1.  .S DIC=ACRDIC_DA_",""SC"","
  1.  .S DIC(0)="L"
  1.  .S DA(1)=DA
  1.  .S:'$D(@(DIC_"0)")) @(DIC_"0)")="^"_$S(ACRDIC["ACRAPP":9002185.01,ACRDIC["ACRALW":9002186.01,ACRDIC["ACRALC":9002187.04,1:9002188.04)_"P"
  1.  .D FILE^ACRFDIC
  1.  I ACRENTR1["LOCB" D  Q:$D(ACRQUIT)
  1.  .S ACRAPP=$P(^ACRLOCB(DA,"DT"),U,4)
  1.  .S ACRAPP=$P(^AUTTPRO(ACRAPP,0),U)
  1.  .S:$E(ACRAPP,3)="X" ACRXACT=""
  1.  .D LBCHK
  1.  .Q:$D(ACRQUIT)
  1.  .D CALC
  1.  I $D(ACRSOF)!$D(ACRSOFT) S ACRQUIT="" Q
  1.  F ACRI="APP","ALLAMT","ALCAMT" D:ACRENTRY[ACRI&($P(ACRZY,U,3)=1) EDIC1
  1.  I ACRENTRY["OBLA" D  Q:$D(ACRQUIT)
  1.  .S ACRCANDA=$P(^ACRLOCB(ACRZDA,"DT"),U,9)
  1.  .S ACRPODA=$P($G(^ACRCAN(ACRCANDA,"DFLT1")),U,15)
  1.  .S ACRADA=$P($G(^ACRPO(+ACRPODA,0)),U,19)
  1.  .;I 'ACRPODA!'ACRADA D                 ; ACR*2.1*20.13  IM20924
  1.  .I 'ACRPODA!'ACRADA D  Q               ; ACR*2.1*20.13  IM20924
  1.  ..W !!,"The DEFAULT DATA including defining the PURCHASING OFFICE for this CAN"
  1.  ..W !,"has not been completed."
  1.  ..W !!,"Please report this to your ARMS Manager immediately."
  1.  ..D PAUSE^ACRFWARN
  1.  ..S (ACRQUIT,ACROUT)=""
  1.  .D LBCHK
  1.  D EN^ACRFDTP2
  1.  S ACRDISP=""
  1.  Q
  1. SOF ;EP;FOR STATUS OF FUNDS
  1.  D:'$D(ACRSOFX) DETAIL^ACRFSOF
  1.  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  S:$D(ACRDTAIL) ZTSAVE("ACRDTAIL")=""
  1.  S ACRRTN="^ACRFSOF"
  1.  S ZTDESC="STATUS OF FUNDS REPORT"
  1.  D ^ACRFZIS
  1.  K ACRFDNO
  1.  Q
  1. EDIC1 S ACRFINSS=""
  1.  S DA=ACRZDA
  1.  S DIE=ACRDIE
  1.  S DR=ACRDR_";2////0;3////0;800////N"
  1.  D DIE^ACRFDIC
  1.  S DA=ACRZDA
  1.  Q
  1. ICHECK ;INTEGRITY CHECK FOR FUNDS
  1.  K ACR
  1.  S X=@(ACRDIC_DA_",""DT"")")
  1.  I ACRDIC["LOCB",$P(X,U)="" S ACR(Y)="FISCAL YEAR"
  1.  I ACRDIC'["ACRAPP" D
  1.  .F Y=3,4,5,8 I $P(X,U,Y)="" D
  1.  ..S ACR(Y)=$S(Y=3:"RECUR/NON-RECUR",Y=4:"APPROPRIATION NO.",Y=5:"ALLOWANCE",1:"SUB-SUB-ACTIVITY")
  1.  Q:'$D(ACR)#2
  1.  W *7,*7
  1.  W !!,"The entry you selected has the following missing data."
  1.  W !
  1.  S ACR=0
  1.  F  S ACR=$O(ACR(ACR)) Q:'ACR  W !?10,ACR(ACR)
  1.  W !!,"This entry cannot be used until missing data has been corrected."
  1.  D PAUSE^ACRFWARN
  1.  S ACRQUIT=""
  1.  Q
  1. CALC N ACR,X,I,ACRDT
  1.  Q:ACRENTR1["LOCB"
  1.  F I=4,21,9 S X(I)=0
  1.  S ACR=0
  1.  F  S ACR=$O(^ACRSS("F",ACRZDA,ACR)) Q:'ACR  D
  1.  .I $D(^ACRSS(ACR,"DT")) S ACRDT=^("DT") D
  1.  ..F I=4,21,9 S X(I)=X(I)+$P(ACRDT,U,I)
  1.  F I=2,3,5 S $P(ACRFDNAC,U,I)=X($S(I=2:4,I=3:21,1:9))
  1.  S DA=ACRZDA
  1.  S DIE="^ACRLOCB("
  1.  S DR="2////"_X(4)_";3////"_X(21)_";7////"_X(9)
  1.  D DIE^ACRFDIC
  1.  S DA=ACRZDA
  1.  Q
  1. CHOOSE ;EP;TO CHOOSE LOOKUP FORMAT
  1.  S DIR(0)="SO^1:By ID NO.;2:By DEPARTMENT Name;3:By CAN NO."
  1.  S:ACRDIC["ACRAPP" DIR(0)="SO^1:By ID NO.;2:Appropriation Number"
  1.  S:ACRDIC["ACRAL" DIR(0)="SO^1:By ID NO.;2:Location Name;3:Allowance"
  1.  S DIR("A")="Select Account by"
  1.  S DIR("B")="By ID NO."
  1.  D DIR^ACRFDIC
  1.  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  I +Y<1 S ACRQUIT="" Q
  1.  I Y=1 S:ACRDIC'["ACRAPP" ACRDIC(0)="AENQZ" S ACRDIC("A")="ID NO.: ",(ACRD,D)="B"
  1.  I Y=2 D
  1.  .S:ACRDIC'["ACRAPP" ACRDIC(0)="AEQZ"
  1.  .S:ACRDIC'["ACRAPP" ACRDIC("A")="DEPARTMENT/LOCATION Name: "
  1.  .S:ACRDIC["ACRAPP" ACRDIC("A")="Appropriation NO.: "
  1.  .I ACRDIC["ACRAPP" S ACRD="C"
  1.  .I ACRDIC["ACRALW" S ACRD="D"
  1.  .I ACRDIC["ACRALC" S ACRD="C"
  1.  .I ACRDIC["ACRLOCB" S ACRD="DEPT"
  1.  I Y=3 D
  1.  .S:ACRDIC'["ACRAPP" ACRDIC(0)="AEQZ"
  1.  .S ACRDIC("A")="Allowance NO.: "
  1.  .I ACRDIC["ACRALW" S ACRD="C"
  1.  .I ACRDIC["ACRALC" S ACRD="E"
  1.  .I ACRDIC["ACRLOCB" S ACRD="DCAN",ACRDIC("A")="CAN NO.: "
  1.  W !
  1.  Q
  1. LBCHK ;CHECK DEPARTMENT ACCOUNT FOR REQUIRED DATA
  1.  K ACRQUIT
  1.  W !
  1.  S ACRDT=$G(^ACRLOCB(ACRZDA,"DT"))
  1.  I ACRDT="" W !,"Department Account information" S ACRQUIT=""
  1.  I $P(ACRDT,U)="" W !,"Fiscal Year" S ACRQUIT=""
  1.  I $P(ACRDT,U,4)="" W:$D(ACRQUIT) " and" W !,"Appropriation information" S ACRQUIT=""
  1.  I $P(ACRDT,U,5)="" W:$D(ACRQUIT) " and" W !,"Allowance information" S ACRQUIT=""
  1.  I $P(ACRDT,U,8)="" W:$D(ACRQUIT) " and" W !,"Sub-Sub-Activity information" S ACRQUIT=""
  1.  I $P(ACRDT,U,9)="" W:$D(ACRQUIT) " and" W !,"Common Accounting Number" S ACRQUIT=""
  1.  I $P(ACRDT,U,11)="" W:$D(ACRQUIT) " and" W !,"Location Code information" S ACRQUIT=""
  1.  I $P(ACRDT,U,15)=""&($P($G(^ACRLOCB(ACRZDA,3)),U)="") W:$D(ACRQUIT) " and" W !,"Cost Center and/or Project Number information" S ACRQUIT=""
  1.  I $D(ACRQUIT) D
  1.  .W " MISSING in"
  1.  .W !!,"Department Account ID NO. ",ACRZDA
  1.  .W !,"(Sub-Allowance ID NO. ",$P(^ACRLOCB(ACRZDA,0),U,4)
  1.  .D PAUSE^ACRFWARN
  1.  .S (ACRQUIT,ACROUT)=""
  1.  Q