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

ACRFPO2.m

Go to the documentation of this file.
  1. ACRFPO2 ;IHS/OIRM/DSD/THL,AEF - PURCHASE ORDER PROCESSING; [ 09/23/2005 9:44 AM ]
  1. ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
  1. ;;CONTINUATION OF ACRFPO
  1. EXIT ;EP;
  1. K ACRDATA,ACRDAT2,ACRDATX,ACRRDATE,ACRPRIOR,ACRDATA1,ACRX,ACRDOC,ACRREF,ACRTXTYP,ACRDOC1,ACRMAX,ACRAPVT,ACRQUIT,ACRDA,ACRDOCDA,ACRGREF,ACRDOCDA,ACRREF1,ACRY,ACRAPDA,ACRLBDA,ACRNOW,ACRNUM,ACRORD,ACRREFDA,ACRSIG,ACRSIGG,ACRPRT
  1. K ACRSIGP,ACRSIGZ,ACRSIGZZ,ACRFDNO(1),ACRPOA,ACRPO,ACRPPO,ACRPA,ACRXMY,ACRSCRL
  1. Q
  1. OBJ ;EP;DETERMINE OBJECT CLASS CODE
  1. K ACROBJ
  1. N X,Y,Z
  1. S X=0
  1. F S X=$O(^ACRSS("J",ACRDOCDA,X)) Q:'X D
  1. .S Y=$P($G(^ACRSS(X,0)),U,4)
  1. .S ACRW=$P($G(^ACRSS(X,"DT")),U,4)
  1. .I +Y D
  1. ..S Z=$G(^AUTTOBJC(+Y,0))
  1. ..S Z=$E($P(Z,U),1,2)
  1. ..I $L(Z) D
  1. ...S:'$D(ACR("OBJ",Z)) ACR("OBJ",Z)=""
  1. ...S ACR("OBJ",Z)=ACR("OBJ",Z)+ACRW
  1. K ACRW
  1. S (X,Y)=0
  1. F S X=$O(ACR("OBJ",X)) Q:'X I ACR("OBJ",X)>Y D
  1. .S Z=X
  1. .S Y=ACR("OBJ",X)
  1. Q:$G(Z)=""
  1. S ACROBJ=Z_"00"
  1. K ACR("OBJ")
  1. Q
  1. VENDOR ;EP;INCLUDE VENDOR NAME ON DISPLAY
  1. S DIR(0)="YO"
  1. S DIR("A")="Display VENDOR's name"
  1. S DIR("B")="NO"
  1. S DIR("?")="Enter 'Y' if you want the VENDOR's name displayed."
  1. W !
  1. D DIR^ACRFDIC
  1. Q:$D(ACRQUIT)!$D(ACROUT)
  1. I Y=1 S ACRSCRL=6
  1. E S ACRSCRL=10
  1. Q
  1. SELECT ;EP;TO SELECT PURCHASE ORDER
  1. I 'ACRMAX D Q
  1. .W !?10,"NO PURCHASE ORDERS PENDING"
  1. .D PAUSE^ACRFWARN
  1. .S ACRQUIT=""
  1. K ACRQUIT
  1. S DIR(0)="LO^1:"_ACRMAX
  1. S DIR("A")=$S($D(ACRPO):"Which one",1:"Assign NO(S)")
  1. W !
  1. D DIR^ACRFDIC
  1. Q:$D(ACRQUIT)!$D(ACROUT)!(+Y<1)
  1. N ACRY,ACRI,ACRZI
  1. S ACRY=Y
  1. F ACRZI=1:1 S ACRX=$P(ACRY,",",ACRZI) Q:ACRX=""!$D(ACROUT) D Q:$D(ACROUT)
  1. .S ACRX=+ACRX
  1. .S ACRXPO=ACRX
  1. .N ACRENTRY
  1. .S ACRENTRY="PO"
  1. .S (DA,ACRDOCDA,ACRZDA,ACRDOCDA)=$P(^TMP("ACRDATA",$J,ACRX),U)
  1. .S ACRDOC=$P(^TMP("ACRDATA",$J,ACRX),U,4)
  1. .S ACRTXTYP=$P(^TMP("ACRDATA",$J,ACRX),U,3)
  1. .D SETDOC^ACRFEA1
  1. .I $P(ACRDOC0,U,4)=35 S ACRREFX=116
  1. .E S ACRREFX=$P(ACRDOC0,U,13),ACRREFX=$P(^AUTTDOCR(ACRREFX,0),U)
  1. .Q:$D(ACRTRANS)
  1. .I $D(ACRPOA) D
  1. ..D ASSIGN^ACRFPO1
  1. ..S ACRPOA=""
  1. ..K ACRPO
  1. .I $D(ACRPO)&'$D(ACRPPO) D
  1. ..D EDIT
  1. ..K ACRPOA
  1. ..S ACRPO=""
  1. .S ACRX=ACRXPO
  1. .K ACRXPO,ACRIPO
  1. Q
  1. AGENT ;EP;TO SELECT PURCHASING AGENT FOR PO REVIEW
  1. S DIR(0)="YO"
  1. S DIR("A")="Display documents assigned to one PURCHASING AGENT only"
  1. S DIR("B")="NO"
  1. S DIR("?")="Enter 'Y' to display only documents assigned to a specified purchasing agent."
  1. W !
  1. D DIR^ACRFDIC
  1. Q:$D(ACRQUIT)!$D(ACROUT)
  1. I +Y'=1 K ACRDUZ,ACRREV Q
  1. S DIC="^ACRPA("
  1. S DIC("A")="Which PURCHASING AGENT: "
  1. S DIC(0)="AEMQZ"
  1. W !
  1. D DIC^ACRFDIC
  1. I $E(X)=U!$D(DTOUT)!$D(DUOUT) S ACRQUIT="" Q
  1. S ACRDUZ=+Y
  1. S ACRPO=""
  1. Q
  1. TEMP ;EP;TEMP MESSAGE
  1. W @IOF,*7,*7,*7
  1. W !?10,"*** PURCHASING SUPERVISOR PLEASE NOTE THE FOLLOWING ***"
  1. W !?5,"A slight modification has been made to allow ARMS to work better with"
  1. W !?5,"requisitions created to produce CONTRACTs rather than PURCHASE ORDERs."
  1. W !!?5,"The CONTRACT module of ARMS is still not yet completed. However,"
  1. W !?5,"if you select '2' below for requisitions which are intended to initiate a"
  1. W !?5,"CONTRACT action, ARMS will allow you to proceed with assigning the document"
  1. W !?5,"to a contract or purchasing agent. The BASIC data can be completed and"
  1. W !?5,"the document sent for approval and 'signed.' This will allow the initiator"
  1. W !?5,"to use ARMS to initiate and track the document throughout the process"
  1. W !?5,"and get the dollars recorded against their DEPARTMENT ACCOUNT."
  1. W !?5,"However, NO CIS (Contract Information System) entry will be created."
  1. W !?5,"The document will be 'set aside' by ARMS and can be processed manually"
  1. W !?5,"as a new CONTRACT or CONTRACT action."
  1. W !!?5,"Therefore, ALL ARMS requisitions which are intended to initiate a"
  1. W !?5,"CONTRACT action should be coded as a '2' for 'Contract'd."
  1. Q
  1. W:$D(IOF)&'$D(ACRTRANS)&'$D(ACRREV) @IOF
  1. W $S($D(ACRPO)!$D(ACRPPO):"Select PURCHASE ORDER:",1:"Select REQUEST to ASSIGN TO PURCHASING AGENT")
  1. W !!?2,"NO."
  1. W ?9,"REQUEST NO."
  1. W ?24,"RQD BY/OBJ CD/$$"
  1. W ?40,"| NO."
  1. W ?50,"REQUEST NO."
  1. W ?65,"RQD BY/OBJ CD/$"
  1. W !,"------"
  1. W ?7,"----------------"
  1. W ?24,"----------------"
  1. W ?40,"|------"
  1. W ?48,"----------------"
  1. W ?65,"---------------"
  1. Q
  1. ASSONE ;EP;TO ASSIGN ONE DOCUMENT ONLY
  1. K ACRPO
  1. S ACRPOA=""
  1. S DIR(0)="SO^1:Assign ONE Document Only;2:List ALL Pending PO's;3:Transfer Unsigned PO's to new Agent"
  1. W !
  1. D DIR^ACRFDIC
  1. I $D(ACRQUIT)!$D(ACROUT)!(123'[+Y) S ACRQUIT="" Q
  1. Q:Y=2
  1. I Y=3 D TRANS Q
  1. ONE ;EP;
  1. D LOOKUP^ACRFPO3
  1. K ACRREFZ,ACRAPV
  1. I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT
  1. N ACRENTRY
  1. S ACRENTRY="PO",ACRONE=""
  1. D ASSIGN^ACRFPO1
  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. TRANS ;EP;TO TRANSFER ALL ACTIVE/UNSIGNED PO'S TO NEW PA
  1. N ACRPA1,ACRPA2
  1. S DIC="^ACRPA("
  1. S DIC(0)="AEMQZ"
  1. S DIC("A")="Purchasing Agent: "
  1. W !!,"Transfer PO's FROM"
  1. D DIC^ACRFDIC
  1. I Y<1 W !,"No Purchasing Agent selected." H 2 Q
  1. S ACRPA1=+Y
  1. S DIC="^ACRPA("
  1. S DIC(0)="AEMQZ"
  1. S DIC("A")="Purchasing Agent: "
  1. W !!,"Transfer PO's TO"
  1. D DIC^ACRFDIC
  1. I Y<1 W !,"No Purchasing Agent selected." H 2 Q
  1. S ACRPA2=+Y
  1. D T1
  1. S ACRQUIT=""
  1. Q
  1. T1 S (ACRDOCDA,ACRJ)=0
  1. F S ACRDOCDA=$O(^ACRDOC("PA",ACRPA1,ACRDOCDA)) Q:'ACRDOCDA I $E($G(^ACROBL(ACRDOCDA,"APV")))="A",$P(^("APV"),U,8)="" S ACRJ=ACRJ+1
  1. W !!?10,"All ",@ACRON,ACRJ,@ACROF," unsigned PO's"
  1. ;W !?10,"currently assigned to: ",$P($G(^VA(200,ACRPA1,0)),U) ;ACR*2.1*19.02 IM16848
  1. ;W !?10,"will be re-assigned to: ",$P($G(^VA(200,ACRPA2,0)),U) ;ACR*2.1*19.02 IM16848
  1. W !?10,"currently assigned to: ",$$NAME2^ACRFUTL1(ACRPA1) ;ACR*2.1*19.02 IM16848
  1. W !?10,"will be re-assigned to: ",$$NAME2^ACRFUTL1(ACRPA2) ;ACR*2.1*19.02 IM16848
  1. S DIR(0)="YO"
  1. S DIR("A",1)="Are you certain you want"
  1. S DIR("A")="to make this transfer"
  1. S DIR("B")="NO"
  1. W !
  1. D DIR^ACRFDIC
  1. I Y'=1 S ACRQUIT="" Q
  1. D T2
  1. Q
  1. T2 S ACRDOCDA=0
  1. F S ACRDOCDA=$O(^ACRDOC("PA",ACRPA1,ACRDOCDA)) Q:'ACRDOCDA I $E($G(^ACROBL(ACRDOCDA,"APV")))="A",$P(^("APV"),U,8)="" D
  1. .S DA=ACRDOCDA
  1. .S DIE="^ACRDOC("
  1. .S DR=".2////"_ACRPA2
  1. .D DIE^ACRFDIC
  1. .;W !,$P(^ACRDOC(ACRDOCDA,0),U),?15," now assigned to: ",$P($G(^VA(200,ACRPA2,0)),U) ;ACR*2.1*19.02 IM16848
  1. .W !,$P(^ACRDOC(ACRDOCDA,0),U),?15," now assigned to: ",$$NAME2^ACRFUTL1(ACRPA2) ;ACR*2.1*19.02 IM16848
  1. Q