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

ACRFAUTO.m

Go to the documentation of this file. 
  1. ACRFAUTO ;IHS/OIRM/DSD/THL,AEF - AUTO CREATION OF REQUEST;  [ 10/27/2004   4:15 PM ]
  1.  ;;2.1;ADMIN RESOURCE MGT SYSTEM;**14**;NOV 05, 2001
  1.  ;;ROUTINE CONTROLS AUTOMATIC CREATION OF REQUEST/PURCHASE ORDER
  1. EN ;EP;USED TO CREATE NEW PO WHEN ITEM CANCELED FROM A RECEIVING REPORT
  1.  S:'$D(IOST)#2 IOST=""
  1.  D EN1
  1.  D SSTRANS
  1. EXIT K ACRDOC,ACRCAN
  1.  Q
  1. EN1 ;EP;TO CREATE NEW DOCUMENT AND DUPLICATE CONTENT OF EXISTING DOCUMENT
  1.  D DOC^ACRFDOCN
  1.  S X="0"
  1.  S DIC="^ACROBL("
  1.  S DIC(0)="L"
  1.  D FILE^ACRFDIC
  1.  S (DA,ACROBL2)=+Y
  1.  S %X="^ACROBL("_ACRDOCDA_","
  1.  S %Y="^ACROBL("_(ACROBL2)_","
  1.  D %XY^%RCR
  1.  K %X,%Y
  1.  F X="CNG","RSN","NOTES" S ^ACROBL(ACROBL2,X)=""
  1.  S X=^ACROBL(ACROBL2,0)
  1.  S $P(X,U,5)=DUZ
  1.  S $P(X,U,6)=DT
  1.  S $P(X,U)=0
  1.  S $P(^ACROBL(ACROBL2,"DT"),U)=ACROBL2
  1.  S DIK="^ACROBL("
  1.  S:$D(ACRNOT)&$D(ACRTDDA) $P(X,U,3)=ACRTDDA
  1.  I $D(ACRNOT) F ACR=1,3,6,8,9 S $P(^ACROBL(ACROBL2,"APV"),U,ACR)=""
  1.  I '$D(ACRNOT),'$D(ACRAMEND) S $P(^ACROBL(ACROBL2,"APV"),U,8)=""
  1.  S ^ACROBL(ACROBL2,0)=X
  1.  S $P(^ACROBL(ACROBL2,"APV"),U,6)=""
  1.  D IX1^ACRFDIC
  1.  S DINUM=ACROBL2
  1.  S X=ACRDOC
  1.  S DIC="^ACRDOC("
  1.  S DIC(0)="L"
  1.  D FILE^ACRFDIC
  1.  S (DA,ACRDOC2)=+Y
  1.  S %X="^ACRDOC("_ACRDOCDA_","
  1.  S %Y="^ACRDOC("_(ACRDOC2)_","
  1.  D %XY^%RCR
  1.  I $E($G(IOST),1,2)="C-" D
  1.  .W !!,"Document Number ",ACRDOC," (ID NO.: ",ACRDOC2,") has been created."
  1.  .W !,"Please make note of this number for future reference."
  1.  .D PAUSE^ACRFWARN
  1.  S X=^ACRDOC(ACRDOC2,0)
  1.  S $P(X,U)=ACRDOC
  1.  S $P(X,U,5)=ACRDOC2
  1.  S $P(X,U,3)=DT
  1.  S DIK="^ACRDOC("
  1.  N ACR
  1.  F ACR=16,18,20 S $P(X,U,ACR)=""
  1.  S:'$D(ACRAMEND) $P(X,U,2)=""
  1.  S:$D(ACRAMEND)!$D(ACRNOT) $P(X,U,13)=ACRREFDA
  1.  S:$D(ACRNOT)&$D(ACRTDDA) $P(X,U,6)=ACRTDDA
  1.  S ^ACRDOC(ACRDOC2,0)=X
  1.  I ACRREF=130 D  I 1
  1.  .S:$D(ACRTDA) $P(^ACRDOC(ACRDOC2,"TO"),U,9)=ACRTDA,$P(^("TO"),U,18)=ACRTDA
  1.  .F X=19,22,23,25 S $P(^ACRDOC(ACRDOC2,"TO"),U,X)=""
  1.  .S $P(^ACRDOC(ACRDOC2,"TOAU"),U,8)=""
  1.  S:$P($G(^ACRDOC(ACRDOC2,"PA")),U,2) $P(^("PA"),U,2)=""
  1.  S:ACRREF=148&$D(ACRTDA) $P(^ACRDOC(ACRDOC2,"TRNG"),U,2)=ACRTDA
  1.  S:$D(ACRNOT)&$D(ACRTDDA) $P(^ACRDOC(ACRDOC2,"REQ"),U,10)=$P($G(^ACRLOCB(ACRTDDA,"DT")),U,9)
  1.  I $D(ACRVDA),ACRREF'=130,ACRREF'=600,ACRREF'=148 D
  1.  .S $P(^ACRDOC(ACRDOC2,"PO"),U,4)=ACRDOC,$P(^("PO"),U,5)=ACRVDA
  1.  D IX1^ACRFDIC
  1.  I $D(ACRNOT),$D(ACRTDDA) D
  1.  .S DA=ACRDOC2
  1.  .S DIE="^ACRDOC("
  1.  .S DR="113100////"_$P($G(^ACRLOCB(ACRTDDA,"DT")),U,9)
  1.  .D DIE^ACRFDIC
  1.  S ACRDA=0
  1.  I $D(ACRCAN)>9 D  I 1
  1.  .F ACRJ=1:1 S ACRDA=$O(ACRCAN(ACRDA)) Q:'ACRDA  D SS^ACRFAUT1
  1.  I $D(ACRNOT),$D(ACRCAN)<9 D  I 1
  1.  .S ACRXREF=$S(ACRREF=103!(ACRREF=349)!(ACRREF=326)!($P(^ACRDOC(ACRDOCDA,0),U,4)=35&($P($G(^ACROBL(ACRDOCDA,"APV")),U)="A")):"J",1:"C")
  1.  .F ACRJ=1:1 S ACRDA=$O(^ACRSS(ACRXREF,ACRDOCDA,ACRDA)) Q:'ACRDA  D SS^ACRFAUT1
  1.  I '$D(ACRAMEND),ACRREF=130!(ACRREF=600) D DAYS^ACRFAUT1
  1.  S ACRAPDA=0
  1.  I '$D(ACRNOT),'$D(ACRAMEND) F  S ACRAPDA=$O(^ACRAPVS("AB",ACRDOCDA,ACRAPDA)) Q:'ACRAPDA  D
  1.  .S X=ACROBL2
  1.  .S DIC="^ACRAPVS("
  1.  .S DIC(0)="L"
  1.  .D FILE^ACRFDIC
  1.  .S (DA,ACRAP2)=+Y
  1.  .S %X="^ACRAPVS("_ACRAPDA_","
  1.  .S %Y="^ACRAPVS("_(ACRAP2)_","
  1.  .D %XY^%RCR
  1.  .K %X,%Y
  1.  .S $P(^ACRAPVS(ACRAP2,0),U)=ACROBL2
  1.  .S DIK="^ACRAPVS("
  1.  .D IX1^ACRFDIC
  1.  I '$D(ACRNOT),'$D(ACRAMEND),$E($G(IOST),1,2)="C-" D
  1.  .W !!,"Approvals have been transferred from the original requisition."
  1.  S ACRDOCX=ACRDOCDA
  1.  S ACRDOCDA=ACROBL2
  1.  D SETDOC^ACRFEA1
  1.  S ACRAPVT=""
  1.  D:'$D(ACRNOT)&'$D(ACRAMEND) CONV^ACRFPRC3
  1.  I '$G(ACRAMEND) D EXPDN(ACRDOCDA)            ;ACR*2.1*14.01 IM12272
  1.  D PA(ACRDOCDA)                               ;ACR*2.1*14.04 IM14041
  1.  K ACRDOC,ACRDOCDA,ACRID,ACRCAN,ACRDOC2
  1.  S ACRDOCDA=ACRDOCX
  1.  D SETDOC^ACRFEA1
  1.  Q
  1. NEW ;EP;
  1.  S DIR(0)="LO^1:"_ACRJ
  1.  S DIR("A")="Which items(s)"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I '+Y!$D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
  1.  F ACRJ=1:1:($L(Y,",")-1) D
  1.  .S ACRSSDA=$P(Y,",",ACRJ)
  1.  .S ACRCAN($P(ACRSS(ACRSSDA),U))=""
  1.  S DIC="^AUTTVNDR("
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="Vendor for NEW Req..: "
  1.  W !
  1.  D DIC^ACRFDIC
  1.  I '+Y!$D(ACRQUIT)!$D(ACROUT) D  Q
  1.  .W !!,"A Vendor/Contractor must be selected to generate NEW Request."
  1.  .D PAUSE^ACRFWARN
  1.  .K ACRQUIT
  1.  S ACRVDA=+Y
  1.  I +Y=$P(^ACRDOC(ACRDOCDA,"PO"),U,5) D  Q:Y'=1
  1.  .S DIR(0)="YO"
  1.  .S DIR("A")="Do you really want to create a NEW Request with the same vendor"
  1.  .S DIR("B")="NO"
  1.  .W !
  1.  .D DIR^ACRFDIC
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Create NEW Request for selected items"
  1.  S DIR("B")="NO"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  Q:Y'=1
  1.  S ACRTXDA=$P(ACRDOC0,U,4)
  1.  S ACRID=$P(ACRDOC0,U,14)
  1.  S ACRTXPFX="PO"
  1.  S ACRREF=116
  1.  S ACRREFDA=$O(^AUTTDOCR("B",ACRREF,0))
  1.  S ACRCANDA=$P(ACROBL0,U,4)
  1.  S (ACRLBDA,ACRFDNO,ACRZDA)=$P(ACROBL0,U,3)
  1.  S ACRALWNO=$P(ACROBL0,U,8)
  1.  S ACRSSADA=$P(ACROBL0,U,7)
  1.  S ACRAPPDA=$P(ACROBL0,U,9)
  1.  S ACRTXOBJ=$P(ACROBLDT,U,3)
  1.  I $E($G(IOST),1,2)="C-" D
  1.  .W !!,"A NEW Request is being generated"
  1.  .H 2
  1.  D EN1
  1.  Q
  1. SSTRANS ;EP;TO TRANSFER SUPPLIES/SERVICES TO NEW OR DIFFERENT REQ/PO
  1.  S ACRDA=0
  1.  I '$D(ACRNOT),'$D(ACRAMEND) D
  1.  .F  S ACRDA=$O(ACRCAN(ACRDA)) Q:'ACRDA  D
  1.  ..S DA=ACRDA
  1.  ..S DIE="^ACRSS("
  1.  ..S DR=".02////"_ACRDOCDA_";.03////"_ACRDOCDA
  1.  ..D DIE^ACRFDIC
  1.  Q
  1. PA(ACRDOCDA)                                   ;ACR*2.1*14.04 IM14041
  1.  ;----- DELETE PURCHASING AGENT FROM DUPLICATE DOCUMENT
  1.  ;      ALSO DATE ASSIGNED AND PURCHASING SUPERVISOR
  1.  ;
  1.  N DA,DIE,DR,X,Y
  1.  S DA=ACRDOCDA
  1.  S DIE="^ACRDOC("
  1.  S DR=".2///^S X=""@"";.3///^S X=""@"";.4///^S X=""@"""
  1.  D ^DIE
  1.  Q
  1. EXPDN(ACRDOCDA)                                ;ACR*2.1*14.01 IM12272
  1.  ;----- DELETE EXPANDED DOCUMENT NUMBER FROM DUPLICATE DOCUMENT
  1.  ;      AND INSERT CORRECT ONE AS APPROPRIATE
  1.  ;
  1.  N ACREXPDN,DA,DIE,DR,X,Y
  1.  S DA=ACRDOCDA
  1.  S DIE="^ACRDOC("
  1.  S DR=".011///"_"@"
  1.  D ^DIE
  1.  S ACREXPDN=$$EXPDN^ACRFUTL(ACRDOCDA)
  1.  S DR=".011////^S X=ACREXPDN"
  1.  D ^DIE
  1.  Q