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
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
+2 ;;ROUTINE CONTROLS AUTOMATIC CREATION OF REQUEST/PURCHASE ORDER
EN ;EP;USED TO CREATE NEW PO WHEN ITEM CANCELED FROM A RECEIVING REPORT
+1 IF '$DATA(IOST)#2
SET IOST=""
+2 DO EN1
+3 DO SSTRANS
EXIT KILL ACRDOC,ACRCAN
+1 QUIT
EN1 ;EP;TO CREATE NEW DOCUMENT AND DUPLICATE CONTENT OF EXISTING DOCUMENT
+1 DO DOC^ACRFDOCN
+2 SET X="0"
+3 SET DIC="^ACROBL("
+4 SET DIC(0)="L"
+5 DO FILE^ACRFDIC
+6 SET (DA,ACROBL2)=+Y
+7 SET %X="^ACROBL("_ACRDOCDA_","
+8 SET %Y="^ACROBL("_(ACROBL2)_","
+9 DO %XY^%RCR
+10 KILL %X,%Y
+11 FOR X="CNG","RSN","NOTES"
SET ^ACROBL(ACROBL2,X)=""
+12 SET X=^ACROBL(ACROBL2,0)
+13 SET $PIECE(X,U,5)=DUZ
+14 SET $PIECE(X,U,6)=DT
+15 SET $PIECE(X,U)=0
+16 SET $PIECE(^ACROBL(ACROBL2,"DT"),U)=ACROBL2
+17 SET DIK="^ACROBL("
+18 IF $DATA(ACRNOT)&$DATA(ACRTDDA)
SET $PIECE(X,U,3)=ACRTDDA
+19 IF $DATA(ACRNOT)
FOR ACR=1,3,6,8,9
SET $PIECE(^ACROBL(ACROBL2,"APV"),U,ACR)=""
+20 IF '$DATA(ACRNOT)
IF '$DATA(ACRAMEND)
SET $PIECE(^ACROBL(ACROBL2,"APV"),U,8)=""
+21 SET ^ACROBL(ACROBL2,0)=X
+22 SET $PIECE(^ACROBL(ACROBL2,"APV"),U,6)=""
+23 DO IX1^ACRFDIC
+24 SET DINUM=ACROBL2
+25 SET X=ACRDOC
+26 SET DIC="^ACRDOC("
+27 SET DIC(0)="L"
+28 DO FILE^ACRFDIC
+29 SET (DA,ACRDOC2)=+Y
+30 SET %X="^ACRDOC("_ACRDOCDA_","
+31 SET %Y="^ACRDOC("_(ACRDOC2)_","
+32 DO %XY^%RCR
+33 IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:1
+34 WRITE !!,"Document Number ",ACRDOC," (ID NO.: ",ACRDOC2,") has been created."
+35 WRITE !,"Please make note of this number for future reference."
+36 DO PAUSE^ACRFWARN
End DoDot:1
+37 SET X=^ACRDOC(ACRDOC2,0)
+38 SET $PIECE(X,U)=ACRDOC
+39 SET $PIECE(X,U,5)=ACRDOC2
+40 SET $PIECE(X,U,3)=DT
+41 SET DIK="^ACRDOC("
+42 NEW ACR
+43 FOR ACR=16,18,20
SET $PIECE(X,U,ACR)=""
+44 IF '$DATA(ACRAMEND)
SET $PIECE(X,U,2)=""
+45 IF $DATA(ACRAMEND)!$DATA(ACRNOT)
SET $PIECE(X,U,13)=ACRREFDA
+46 IF $DATA(ACRNOT)&$DATA(ACRTDDA)
SET $PIECE(X,U,6)=ACRTDDA
+47 SET ^ACRDOC(ACRDOC2,0)=X
+48 IF ACRREF=130
Begin DoDot:1
+49 IF $DATA(ACRTDA)
SET $PIECE(^ACRDOC(ACRDOC2,"TO"),U,9)=ACRTDA
SET $PIECE(^("TO"),U,18)=ACRTDA
+50 FOR X=19,22,23,25
SET $PIECE(^ACRDOC(ACRDOC2,"TO"),U,X)=""
+51 SET $PIECE(^ACRDOC(ACRDOC2,"TOAU"),U,8)=""
End DoDot:1
IF 1
+52 IF $PIECE($GET(^ACRDOC(ACRDOC2,"PA")),U,2)
SET $PIECE(^("PA"),U,2)=""
+53 IF ACRREF=148&$DATA(ACRTDA)
SET $PIECE(^ACRDOC(ACRDOC2,"TRNG"),U,2)=ACRTDA
+54 IF $DATA(ACRNOT)&$DATA(ACRTDDA)
SET $PIECE(^ACRDOC(ACRDOC2,"REQ"),U,10)=$PIECE($GET(^ACRLOCB(ACRTDDA,"DT")),U,9)
+55 IF $DATA(ACRVDA)
IF ACRREF'=130
IF ACRREF'=600
IF ACRREF'=148
Begin DoDot:1
+56 SET $PIECE(^ACRDOC(ACRDOC2,"PO"),U,4)=ACRDOC
SET $PIECE(^("PO"),U,5)=ACRVDA
End DoDot:1
+57 DO IX1^ACRFDIC
+58 IF $DATA(ACRNOT)
IF $DATA(ACRTDDA)
Begin DoDot:1
+59 SET DA=ACRDOC2
+60 SET DIE="^ACRDOC("
+61 SET DR="113100////"_$PIECE($GET(^ACRLOCB(ACRTDDA,"DT")),U,9)
+62 DO DIE^ACRFDIC
End DoDot:1
+63 SET ACRDA=0
+64 IF $DATA(ACRCAN)>9
Begin DoDot:1
+65 FOR ACRJ=1:1
SET ACRDA=$ORDER(ACRCAN(ACRDA))
IF 'ACRDA
QUIT
DO SS^ACRFAUT1
End DoDot:1
IF 1
+66 IF $DATA(ACRNOT)
IF $DATA(ACRCAN)<9
Begin DoDot:1
+67 SET ACRXREF=$SELECT(ACRREF=103!(ACRREF=349)!(ACRREF=326)!($PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35&($PIECE($GET(^ACROBL(ACRDOCDA,"APV")),U)="A")):"J",1:"C")
+68 FOR ACRJ=1:1
SET ACRDA=$ORDER(^ACRSS(ACRXREF,ACRDOCDA,ACRDA))
IF 'ACRDA
QUIT
DO SS^ACRFAUT1
End DoDot:1
IF 1
+69 IF '$DATA(ACRAMEND)
IF ACRREF=130!(ACRREF=600)
DO DAYS^ACRFAUT1
+70 SET ACRAPDA=0
+71 IF '$DATA(ACRNOT)
IF '$DATA(ACRAMEND)
FOR
SET ACRAPDA=$ORDER(^ACRAPVS("AB",ACRDOCDA,ACRAPDA))
IF 'ACRAPDA
QUIT
Begin DoDot:1
+72 SET X=ACROBL2
+73 SET DIC="^ACRAPVS("
+74 SET DIC(0)="L"
+75 DO FILE^ACRFDIC
+76 SET (DA,ACRAP2)=+Y
+77 SET %X="^ACRAPVS("_ACRAPDA_","
+78 SET %Y="^ACRAPVS("_(ACRAP2)_","
+79 DO %XY^%RCR
+80 KILL %X,%Y
+81 SET $PIECE(^ACRAPVS(ACRAP2,0),U)=ACROBL2
+82 SET DIK="^ACRAPVS("
+83 DO IX1^ACRFDIC
End DoDot:1
+84 IF '$DATA(ACRNOT)
IF '$DATA(ACRAMEND)
IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:1
+85 WRITE !!,"Approvals have been transferred from the original requisition."
End DoDot:1
+86 SET ACRDOCX=ACRDOCDA
+87 SET ACRDOCDA=ACROBL2
+88 DO SETDOC^ACRFEA1
+89 SET ACRAPVT=""
+90 IF '$DATA(ACRNOT)&'$DATA(ACRAMEND)
DO CONV^ACRFPRC3
+91 ;ACR*2.1*14.01 IM12272
IF '$GET(ACRAMEND)
DO EXPDN(ACRDOCDA)
+92 ;ACR*2.1*14.04 IM14041
DO PA(ACRDOCDA)
+93 KILL ACRDOC,ACRDOCDA,ACRID,ACRCAN,ACRDOC2
+94 SET ACRDOCDA=ACRDOCX
+95 DO SETDOC^ACRFEA1
+96 QUIT
NEW ;EP;
+1 SET DIR(0)="LO^1:"_ACRJ
+2 SET DIR("A")="Which items(s)"
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF '+Y!$DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+6 FOR ACRJ=1:1:($LENGTH(Y,",")-1)
Begin DoDot:1
+7 SET ACRSSDA=$PIECE(Y,",",ACRJ)
+8 SET ACRCAN($PIECE(ACRSS(ACRSSDA),U))=""
End DoDot:1
+9 SET DIC="^AUTTVNDR("
+10 SET DIC(0)="AEMQZ"
+11 SET DIC("A")="Vendor for NEW Req..: "
+12 WRITE !
+13 DO DIC^ACRFDIC
+14 IF '+Y!$DATA(ACRQUIT)!$DATA(ACROUT)
Begin DoDot:1
+15 WRITE !!,"A Vendor/Contractor must be selected to generate NEW Request."
+16 DO PAUSE^ACRFWARN
+17 KILL ACRQUIT
End DoDot:1
QUIT
+18 SET ACRVDA=+Y
+19 IF +Y=$PIECE(^ACRDOC(ACRDOCDA,"PO"),U,5)
Begin DoDot:1
+20 SET DIR(0)="YO"
+21 SET DIR("A")="Do you really want to create a NEW Request with the same vendor"
+22 SET DIR("B")="NO"
+23 WRITE !
+24 DO DIR^ACRFDIC
End DoDot:1
IF Y'=1
QUIT
+25 SET DIR(0)="YO"
+26 SET DIR("A")="Create NEW Request for selected items"
+27 SET DIR("B")="NO"
+28 WRITE !
+29 DO DIR^ACRFDIC
+30 IF Y'=1
QUIT
+31 SET ACRTXDA=$PIECE(ACRDOC0,U,4)
+32 SET ACRID=$PIECE(ACRDOC0,U,14)
+33 SET ACRTXPFX="PO"
+34 SET ACRREF=116
+35 SET ACRREFDA=$ORDER(^AUTTDOCR("B",ACRREF,0))
+36 SET ACRCANDA=$PIECE(ACROBL0,U,4)
+37 SET (ACRLBDA,ACRFDNO,ACRZDA)=$PIECE(ACROBL0,U,3)
+38 SET ACRALWNO=$PIECE(ACROBL0,U,8)
+39 SET ACRSSADA=$PIECE(ACROBL0,U,7)
+40 SET ACRAPPDA=$PIECE(ACROBL0,U,9)
+41 SET ACRTXOBJ=$PIECE(ACROBLDT,U,3)
+42 IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:1
+43 WRITE !!,"A NEW Request is being generated"
+44 HANG 2
End DoDot:1
+45 DO EN1
+46 QUIT
SSTRANS ;EP;TO TRANSFER SUPPLIES/SERVICES TO NEW OR DIFFERENT REQ/PO
+1 SET ACRDA=0
+2 IF '$DATA(ACRNOT)
IF '$DATA(ACRAMEND)
Begin DoDot:1
+3 FOR
SET ACRDA=$ORDER(ACRCAN(ACRDA))
IF 'ACRDA
QUIT
Begin DoDot:2
+4 SET DA=ACRDA
+5 SET DIE="^ACRSS("
+6 SET DR=".02////"_ACRDOCDA_";.03////"_ACRDOCDA
+7 DO DIE^ACRFDIC
End DoDot:2
End DoDot:1
+8 QUIT
PA(ACRDOCDA) ;ACR*2.1*14.04 IM14041
+1 ;----- DELETE PURCHASING AGENT FROM DUPLICATE DOCUMENT
+2 ; ALSO DATE ASSIGNED AND PURCHASING SUPERVISOR
+3 ;
+4 NEW DA,DIE,DR,X,Y
+5 SET DA=ACRDOCDA
+6 SET DIE="^ACRDOC("
+7 SET DR=".2///^S X=""@"";.3///^S X=""@"";.4///^S X=""@"""
+8 DO ^DIE
+9 QUIT
EXPDN(ACRDOCDA) ;ACR*2.1*14.01 IM12272
+1 ;----- DELETE EXPANDED DOCUMENT NUMBER FROM DUPLICATE DOCUMENT
+2 ; AND INSERT CORRECT ONE AS APPROPRIATE
+3 ;
+4 NEW ACREXPDN,DA,DIE,DR,X,Y
+5 SET DA=ACRDOCDA
+6 SET DIE="^ACRDOC("
+7 SET DR=".011///"_"@"
+8 DO ^DIE
+9 SET ACREXPDN=$$EXPDN^ACRFUTL(ACRDOCDA)
+10 SET DR=".011////^S X=ACREXPDN"
+11 DO ^DIE
+12 QUIT