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