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