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

ACRFPO1.m

Go to the documentation of this file. 
  1. ACRFPO1 ;IHS/OIRM/DSD/THL,AEF - PURCHASE ORDER PROCESSING;  [ 1/31/2007   9:44 AM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19,22**;NOV 05, 2001
  1.  ;;CONTINUATION OF ACRFPO
  1. ASSIGN ;EP;
  1.  K ACRAPDA
  1.  Q:$D(ACRQUIT)!$D(ACROUT)!(+Y<1)
  1.  S ACRREFX=116
  1.  S ACRREQST=""
  1.  D ACCEPT
  1.  I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
  1.  W !
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Print the Requisition now"
  1.  S DIR("B")="NO"
  1.  D DIR^ACRFDIC
  1.  Q:$D(ACROUT)
  1.  K ACRQUIT
  1.  I Y=1 D PR^ACRFEA42
  1.  K ACRREQST
  1.  Q:$D(ACROUT)
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Is this procurement within our purchasing authority"
  1.  S DIR("B")="YES"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
  1.  I ACRY'=1 D  Q
  1.  .S DA=ACRDOCDA
  1.  .S DIE="^ACRDOC("
  1.  .S DR=".08T;.4T"
  1.  .D DIE^ACRFDIC
  1.  .S ACRPS=$P(^ACRDOC(ACRDOCDA,"PA"),U,3)
  1.  .;S ACRPS=$P($P($P(^VA(200,ACRPS,0),U),",",2)," ")_" "_$P($P(^(0),U),",")  ;ACR*2.1*19.02 IM16848
  1.  .S ACRPS=$$NAME3^ACRFUTL1(ACRPS)  ;ACR*2.1*19.02 IM16848
  1.  .W !!,"Document ",ACRDOC," transferred to ",ACRPS
  1.  .W !,"for assignment and processing."
  1.  .W !
  1.  .D PAUSE^ACRFWARN
  1.  S DIR(0)="SO^1:Purchase Order;2:Award/Contract (SF 26);3:Solicitation, Offer and Award (SF 33);4:Solicitation/Contract/Order for Commercial Items (SF 1449);5:Tribal Contract"
  1.  S DIR("A")="Type of procurement action"
  1.  S DIR("?")="Indicate the type of procurement action to be taken."
  1.  W !
  1.  I 0 D DIR^ACRFDIC
  1.  I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
  1.  S DA=ACRDOCDA
  1.  S DIE="^ACRDOC("
  1.  S DR=".24///"_$S(ACRY=1:"@",1:(ACRY-1))_";.13///"_$S(ACRY=1:"103",ACRY=5:"326",1:"349")
  1.  S DR=".24///@;.13///103"
  1.  D DIE^ACRFDIC
  1.  W !!,"Assign ",ACRDOC," to:"
  1.  S ACRPA=+$G(^ACRDOC(ACRDOCDA,"PA"))
  1.  S DA=ACRDOCDA
  1.  S DIE="^ACRDOC("
  1.  S DR=".2T;103960T;20T"
  1.  D DIE^ACRFDIC
  1.  I +$G(^ACRDOC(ACRDOCDA,"PA")),+^("PA")'=ACRPA D
  1.  .D NOW^%DTC
  1.  .S X=%
  1.  .S DIC(0)="L"
  1.  .S DIC="^ACRDOC("_ACRDOCDA_",11,"
  1.  .S DA(1)=ACRDOCDA
  1.  .S DIC("DR")=".02////"_ACRPA_";.03////"_DUZ
  1.  .S:'$D(@(DIC_"0)")) ^ACRDOC(ACRDOCDA,11,0)="^9002196.0111D"
  1.  .D FILE^ACRFDIC
  1.  Q
  1. ACCEPT ;EP;
  1.  S DIR(0)="SO^1:Accept Requisition;2:Send Message to Requestor;3:Return Requisition for Resubmission"
  1.  S DIR("B")="Accept Requisition"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I ACRY=2 D
  1.  .S ACRAPDAS=""
  1.  .D XMY^ACRFXMY
  1.  .S (ACRY,Y)=2
  1.  I ACRY=3 D  Q
  1.  .D REACT^ACRFEA4
  1.  .I ACRY=1 D
  1.  ..S ACRAPDAS="R"
  1.  ..D XMY^ACRFXMY
  1.  ..W !,ACRDOC," resubmitted for change/clarification."
  1.  ..D PAUSE^ACRFWARN
  1.  ..S ACRQUIT="",Y=-1
  1.  ..I $P(^ACRDOC(ACRDOCDA,0),U,4)=35,$P(^(0),U,7),$P(^(0),U,7)'=35 D
  1.  ...S DA=ACRDOCDA
  1.  ...S DIE="^ACRDOC("
  1.  ...S DR=".04////"_$P(^ACRDOC(ACRDOCDA,0),U,7)
  1.  ...D DIE^ACRFDIC
  1.  Q
  1. PRINT ;EP;TO PRINT PURCHASE ORDER
  1.  F  D P1 Q:$D(ACRQUIT)!$D(ACROUT)
  1.  K ACRQUIT,ACRPPO
  1.  Q
  1. P1 I '$D(ACRREQST) D
  1.  .S DIC("S")="S ACRAPV=$G(^ACROBL(+Y,""APV"")),ACRREFZ=$P(^ACRDOC(+Y,0),U,13),ACRREFZ=$P($G(^AUTTDOCR(+ACRREFZ,0)),U)"
  1.  .S DIC("S")=DIC("S")_" I ""^103^210^349^326^""[(U_ACRREFZ_U)!(ACRREFZ=116&($P(^ACRDOC(+Y,0),U,4)=35)!($P(^(0),U,12))),$E(ACRAPV)=""A"""
  1.  D LOOKUP^ACRFPO3
  1.  K ACRREFZ,ACRAPV
  1.  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  D PSC:$D(ACRPPO)
  1.  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  D PRINT^ACRFSHIP:ACRREFX'=349
  1.  I '$D(ACRRR)#2,'$P(ACRDOC0,U,19) D  Q:$D(ACROUT)
  1.  .D ^ACRFSSPO
  1.  .;Q:ACRPOTOT<2500.999                 ;ACR*2.1*22.06 IM23064
  1.  .Q:ACRPOTOT<3000.999                  ;ACR*2.1*22.06 IM23064
  1.  .N X
  1.  .S X=$P($G(^ACRDOC(ACRDOCDA,13)),U,5,6)
  1.  .Q:$L(X)=1
  1.  .S DIR(0)="YO"
  1.  .S DIR("A")="Include Cost Comparison"
  1.  .S DIR("B")="NO"
  1.  .W !
  1.  .D DIR^ACRFDIC
  1.  .S:Y=1 ACRCOST=""
  1.  .Q:$D(ACROUT)
  1. P11 ;EP;FOR RECEIVING REPORT PRINT
  1.  N ACRPAGE                             ;ACR*2.1*22.01 IM22636
  1.  I $D(ACRRR)#2!($D(ACRIV)#2) D  Q:$D(ACRQUIT)!$D(ACROUT)!'$G(ACRRRNO)
  1.  .D RRNO^ACRFRRPT
  1.  .Q:$D(ACRQUIT)!$D(ACROUT)!'$D(ACRRRNO)
  1.  .Q:'ACRRRNO
  1.  .S (ACRREF,ACRREFX)=499
  1.  I $D(ACRFEDS) D
  1.  .S (ACRREF,ACRREFX)=210
  1.  .S:$P($G(^ACRDOC(ACRDOCDA,3)),U,17)=1 ACR3542=""
  1.  D TSKVAR^ACRFPRNT
  1.  S ACRRTN="^ACRFQ"
  1.  D ^ACRFZIS
  1.  K ACRQUIT,ACR3542,ACRPSC,ACRORIGF,ACRADJST
  1.  Q
  1. EDIT ;EP;
  1.  S ACRENTRY=$T(@ACRENTRY^ACRFCTL1)
  1.  S ACRPO=""
  1.  K ACRPOA
  1.  D SET^ACRFEA
  1.  D ^ACRFEA4
  1.  K ACRPRCS
  1.  Q
  1. AMEND ;EP;
  1.  S DIC("S")="S ACRREF=$P(^ACRDOC(+Y,0),U,13),ACRREF=$P(^AUTTDOCR(ACRREF,0),U) I ""^116^103^349^326^210^148^""[(U_ACRREF_U),$D(^ACROBL(+Y,""APV"")),$P(^(""APV""),U,8)=""A"""
  1.  D LOOKUP^ACRFPO3
  1.  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  D NOW^%DTC
  1.  S X=DUZ
  1.  S DA(1)=ACRDOCDA
  1.  S DIC="^ACRDOC("_DA(1)_",7,"
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02///"_%
  1.  S:'$D(^ACRDOC(DA(1),7,0)) ^ACRDOC(DA(1),7,0)="^9002196.07"
  1.  D FILE^ACRFDIC
  1.  N ACRENTRY,ACRPO
  1.  S ACRENTRY="PO",ACRPO=""
  1.  D ^ACRFEA41:'$D(ACRCANCL)
  1.  I $D(ACRCANCL) S ACRMCODE=4 D EN2^ACRFDEL
  1.  Q
  1. FEDSTRIP ;EP;TO PRINT FEDSTRIP ORDER
  1.  S ACRFEDS=""
  1.  D PRINT
  1.  Q
  1. ACRCANCL ;EP;TO SELECT APPROVED PURCHASE ORDER FOR CANCELLATION
  1.  K ACRREQST
  1.  N ACRPO,ACRENTRY,ACRCANCL
  1.  S ACRENTRY="PO"
  1.  S ACRCANCL=""
  1.  S ACRPO=""
  1.  D AMEND
  1.  K ACRPRT
  1.  Q
  1. SPENT ;EP;TO ADJUST OBLIGATION WITH THE ACTUAL EXPENDITURE
  1.  F  D S1 Q:$D(ACRQUIT)
  1.  K ACRQUIT
  1.  Q
  1. S1 D LOOKUP^ACRFPO3
  1.  Q:$D(ACRQUIT)
  1.  S DA=ACRDOCDA
  1.  S DIE="^ACRDOC("
  1.  S DR="103200.1T;103200.2T"
  1.  D DIE^ACRFDIC
  1.  S DA=ACRDOCDA
  1.  S DIE="^ACROBL("
  1.  S DR="2FINAL PAYMENT AMOUNT"
  1.  D DIE^ACRFDIC
  1.  Q
  1. MOD ;EP;PURCHASE AGENT OPTIONS
  1.  W @IOF
  1.  W !?20,"Purchasing Agent Options"
  1.  K ACRPOA
  1.  S ACRPO=""
  1.  S DIR(0)="SO^1:Process Signed Requisition;2:Create Modification;3:Edit Pending Modification;4:Quit"
  1.  D DIR^ACRFDIC
  1.  I $D(ACROUT)!$D(ACRQUIT)!(123'[$G(Y)) S ACRQUIT="" Q
  1.  I Y=1 D EN^ACRFPO S Y=1
  1.  I Y=2 D M1 S Y=2
  1.  I Y=3 D M2 S Y=3
  1.  K ACRQUIT,ACRPPO,ACRPRT
  1.  Q
  1. M1 ;
  1.  N ACRPO,ACRENTRY
  1.  S ACRENTRY="OBLAMT"
  1.  S ACRENTRY=$T(@ACRENTRY^ACRFCTL1)
  1.  S ACRZY=""
  1.  D SET^ACRFEA
  1.  D A1^ACRFNEWD
  1.  D A1^ACRFEA1:'$D(ACRQUIT)&$G(ACRAMEND)
  1.  Q
  1. M2 ;
  1.  S DIC="^ACRDOC("
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="Edit Which Modification: "
  1.  S D="B^C^G^J"
  1.  S DIC("S")="S ACRXX=^ACRDOC(+Y,0),ACRAPV=$G(^ACROBL(+Y,""APV"")),ACRREF=$P(ACRXX,U,13),ACRREF=$P(^AUTTDOCR(ACRREF,0),U) I ""^116^204^210^""[(U_ACRREF_U),$P(ACRXX,U,15),$P(ACRAPV,U)="""""
  1.  W !
  1.  D MIX^ACRFDIC
  1.  S:+Y<1 ACRQUIT=""
  1.  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  S ACRDOCDA=+Y
  1.  D SETDOC^ACRFEA1
  1.  D ^ACRFEA41
  1.  Q
  1. PSC ;EP;DETERMINE WHICH PO TO PRINT
  1.  K ACRPSC,ACRORIGF
  1.  S Y=$P(^ACRDOC(ACRDOCDA,0),U,24)+1
  1.  I +Y<1 K ACRPSC S ACRQUIT="" Q
  1.  I +Y=1 S ACRPSC="347^50"
  1.  I +Y=2 S ACRPSC="26^32"
  1.  I +Y=3 S ACRPSC="33^33"
  1.  I +Y=4 S ACRPSC="1449^32"
  1.  I +Y=5 S ACRPSC="326^50" Q
  1.  I Y'=1 D PSC1 Q
  1.  ;PRINT ON BLANK PAPER OR PRE-PRINTED FORM
  1.  S DIR(0)="SO^1:Print on blank paper;2:Print on Pre-printed form"
  1.  S DIR("A")="Which print format"
  1.  S DIR("B")=1
  1.  W !
  1.  D DIR^ACRFDIC
  1.  Q:+Y'=2
  1. PSC1 S ACRORIGF=""
  1.  S DIR(0)="NO^0:2"
  1.  S DIR("A")="Adjust TOP OF PAGE by (number of lines)"
  1.  S DIR("B")=0
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I "012"'[Y S ACRQUIT="" Q
  1.  S ACRADJST=Y
  1.  Q