ACRFSS2 ;IHS/OIRM/DSD/THL,AEF - ACRFSS CON'T; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;CONTINUATION OF ACRFSS
;;TRANSFER AND DELETE REQUEST ITEMS
TRANS ;EP;TO SELECT ITEMS TO TRANSFER TO ANOTHER REQUEST
S DIR(0)="S^1:Transfer to existing PO;2:Create new PO;3:Duplicate This PO"
S DIR("A")="Which one"
W !
D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT)!(+Y<1) K ACRQUIT Q
N ACRDOCD1
S ACRDOCD1=ACRDOCDA
I Y=1 D T Q
I Y=2 K ACRNOT D NEW^ACRFAUTO Q
I Y=3 S ACRNOT="" D NEW^ACRFAUTO Q
S ACRDOCDA=ACRDOCD1
Q
T S ACRTRANS=""
S DIR(0)="LO^1:"_ACRJ
S DIR("A")="Item NO.(S) ==> "
W !
D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT)!(+Y<1) K ACRQUIT Q
S ACRSSX=Y(0)
D HEAD^ACRFSSD1
N ACRX
F ACRX=1:1 S ACRJ=$P(ACRSSX,",",ACRX) Q:ACRJ="" D
.S ACRSSDA=+ACRSS(ACRJ)
.S ACRTRQ=$P(^ACRSS(ACRSSDA,"DT"),U,4)
.S ACRJ=ACRJ-1
.D ^ACRFSSD
W !!,"Transfer Item NO.(S) ",ACRSSX," from ",ACRDOC
W !,"to one of the following:"
W $$DASH^ACRFMENU
S (ACRTDA,ACROOBL)=ACRDOCDA
N ACRDOCDA,ACRDOC,ACRZDA,ACRDOCDA,ACRID
D LOOKUP^ACRFPO
D DISPLAY^ACRFPO
D SELECT^ACRFPO2
I $D(ACRQUIT)!$D(ACROUT) D T11 Q
W *7,*7
W !!,"The items listed above will now be transferred to the purchase order selected."
S DIR(0)="YO"
S DIR("A")="Sure you want to make this transfer"
S DIR("B")="NO"
D DIR^ACRFDIC
I Y'=1 D T11 Q
N ACRI
F ACRI=1:1 S ACRX=$P(ACRSSX,",",ACRI) Q:'ACRX D T1:$G(ACRSS(ACRX))
T11 K ACRTRANS,ACRQUIT,ACRTDOC,ACRTOBL,ACRRQ,ACROOBL,ACRTRQ,ACRTDA,ACRSSX,ACRDOCX,ACRDOCY,ACRZDAX,ACROBLX
Q
T1 ;SET THE PURCHASE ORDER FROM WHICH THE ITEM IS BEING PURCHASED WHEN
;IT IS DIFFERENT FROM THE ORIGINAL REQUISITION FOR WHICH THE ITEM WAS
;ORDERED
S DA=+ACRSS(ACRX)
S DR=".2////"_ACRDOCDA
S DIE="^ACRSS("
D DIE^ACRFDIC
Q
DELETE ;EP;TO DELETE ITEMS FROM A REQUEST
I ACRJ<2 S Y=1
E D I $D(ACRQUIT)!$D(ACROUT)!'$D(Y) K ACRQUIT Q
.S DIR(0)="LOA^1:"_ACRJ
.S DIR("A")="Delete item(s) (1-"_ACRJ_") ==> "
.W !
.D DIR^ACRFDIC
S ACRX=Y
S:$E(ACRX,$L(ACRX))="," ACRX=$E(ACRX,1,($L(ACRX)-1))
S DIR(0)="YO"
S DIR("A")="Sure you want to delete item(s) "_ACRX_" "
S DIR("B")="NO"
W !
D DIR^ACRFDIC
I $D(ACGQUIT)!(Y'=1) K ACRQUIT Q
W !
D:$E($G(IOST),1,2)="C-" WAIT^DICD
S:$E(ACRX,$L(ACRX))="," ACRX=$E(ACRX,1,$L(ACRX)-1)
DELETE1 ;EP;TO DELETE ITEM FROM ITEM FILE
;THE DFN(S) TO BE DELETED MUST BE IN ACRX, ACRX="1,2,3"
F ACRI=1:1:$L(ACRX,",") D
.S ACRY=$P(ACRX,",",ACRI)
.Q:'$D(ACRSS(ACRY))
.S ACRDEL=""
.S DA=+ACRSS(ACRY)
.S DIE="^ACRSS("
.S DR="13///0;16///0;16.1///0;18///0"
.D DIE^ACRFDIC
.K ACRDEL,^ACRSS("C",ACRDOCDA,+ACRSS(ACRY)),^ACRSS("J",ACRDOCDA,+ACRSS(ACRY)),ACRSS(ACRY)
D APCHK^ACRFSCHK
I $P(^ACRDOC(ACRDOCDA,0),U,4)=35,$E($G(^ACROBL(ACRDOCDA,"APV")))="A" Q
D APPROVE^ACRFSCHK
Q
VIEW ;EP;
S DIR(0)="NOA^1:"_ACRJ_"^K:X'?1N.2N!(X<1)!(X>ACRJ)!'$D(ACRSS(X)) X"
S DIR("A")="Item NO. ==> "
W !
D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
I '$D(^ACRSS(+ACRSS(X),1,1)) D Q
.W !!?10,"No ADDITIONAL DESCRIPTION on file for this Item."
.H 2
W !
N DXS,DIP,DC,DN,D0
S D0=+ACRSS(X)
D ^ACRADDM
Q
SVEND ;
S (ACRV1,ACRV2,ACRV1NAM,ACRV2NAM)=""
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR="[ACR COST COMPARISON]"
D DDS^ACRFDIC
I $D(ACRSCREN) D
.K ACRSCREN
.W !
.D DIE^ACRFDIC
S ACRV1=$P($G(^ACRDOC(ACRDOCDA,13)),U,5)
I ACRV1,$D(^AUTTVNDR(ACRV1,0)) S ACRV1NAM=$P(^(0),U)
E S (ACRV1,ACRV1NAM)=$P($G(^ACRDOC(ACRDOCDA,14)),U)
S ACRV2=$P($G(^ACRDOC(ACRDOCDA,13)),U,6)
I ACRV2,$D(^AUTTVNDR(ACRV2,0)) S ACRV2NAM=$P(^(0),U)
E S (ACRV2,ACRV2NAM)=$P($G(^ACRDOC(ACRDOCDA,15)),U)
Q
EDIT ;EP;TO EDIT COST COMPARISON DATA FOR SELECTED ITEMS
D SVEND
Q:$D(ACROUT)
Q:ACRV1=""&(ACRV2="")
N ACRI,ACRY
I ACRJ=1 S Y=1 D EDIT1 Q
S DIR(0)="LO^1:"_ACRSJ
S DIR("A")="Which Item(s)"
W !
D DIR^ACRFDIC
I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q
EDIT1 S ACRY=Y
F ACRJ=1,2 D:ACRJ=1&(ACRV1]"")!(ACRJ=2&(ACRV2]""))
.F ACRI=1:1 S X=$P(ACRY,",",ACRI) Q:X=""!$D(ACROUT) D:$D(ACRSS(X)) ED1
Q
ED1 S ACRSSDA=+ACRSS(X)
W !!?21,"Item NO. ",X," UNIT COST COMPARISON"
S DA=ACRSSDA
S DIE="^ACRSS("
S:ACRJ=1 DR=$S(ACRV1:"141////"_ACRV1_";142T;",ACRV1]"":"142T",1:"")
S:ACRJ=2 DR=$S(ACRV2:"143////"_(ACRV2)_";144T;",ACRV2]"":"144T",1:"")
D DIE^ACRFDIC
Q
ACRFSS2 ;IHS/OIRM/DSD/THL,AEF - ACRFSS CON'T; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;CONTINUATION OF ACRFSS
+3 ;;TRANSFER AND DELETE REQUEST ITEMS
TRANS ;EP;TO SELECT ITEMS TO TRANSFER TO ANOTHER REQUEST
+1 SET DIR(0)="S^1:Transfer to existing PO;2:Create new PO;3:Duplicate This PO"
+2 SET DIR("A")="Which one"
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF $DATA(ACRQUIT)!$DATA(ACROUT)!(+Y<1)
KILL ACRQUIT
QUIT
+6 NEW ACRDOCD1
+7 SET ACRDOCD1=ACRDOCDA
+8 IF Y=1
DO T
QUIT
+9 IF Y=2
KILL ACRNOT
DO NEW^ACRFAUTO
QUIT
+10 IF Y=3
SET ACRNOT=""
DO NEW^ACRFAUTO
QUIT
+11 SET ACRDOCDA=ACRDOCD1
+12 QUIT
T SET ACRTRANS=""
+1 SET DIR(0)="LO^1:"_ACRJ
+2 SET DIR("A")="Item NO.(S) ==> "
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF $DATA(ACRQUIT)!$DATA(ACROUT)!(+Y<1)
KILL ACRQUIT
QUIT
+6 SET ACRSSX=Y(0)
+7 DO HEAD^ACRFSSD1
+8 NEW ACRX
+9 FOR ACRX=1:1
SET ACRJ=$PIECE(ACRSSX,",",ACRX)
IF ACRJ=""
QUIT
Begin DoDot:1
+10 SET ACRSSDA=+ACRSS(ACRJ)
+11 SET ACRTRQ=$PIECE(^ACRSS(ACRSSDA,"DT"),U,4)
+12 SET ACRJ=ACRJ-1
+13 DO ^ACRFSSD
End DoDot:1
+14 WRITE !!,"Transfer Item NO.(S) ",ACRSSX," from ",ACRDOC
+15 WRITE !,"to one of the following:"
+16 WRITE $$DASH^ACRFMENU
+17 SET (ACRTDA,ACROOBL)=ACRDOCDA
+18 NEW ACRDOCDA,ACRDOC,ACRZDA,ACRDOCDA,ACRID
+19 DO LOOKUP^ACRFPO
+20 DO DISPLAY^ACRFPO
+21 DO SELECT^ACRFPO2
+22 IF $DATA(ACRQUIT)!$DATA(ACROUT)
DO T11
QUIT
+23 WRITE *7,*7
+24 WRITE !!,"The items listed above will now be transferred to the purchase order selected."
+25 SET DIR(0)="YO"
+26 SET DIR("A")="Sure you want to make this transfer"
+27 SET DIR("B")="NO"
+28 DO DIR^ACRFDIC
+29 IF Y'=1
DO T11
QUIT
+30 NEW ACRI
+31 FOR ACRI=1:1
SET ACRX=$PIECE(ACRSSX,",",ACRI)
IF 'ACRX
QUIT
IF $GET(ACRSS(ACRX))
DO T1
T11 KILL ACRTRANS,ACRQUIT,ACRTDOC,ACRTOBL,ACRRQ,ACROOBL,ACRTRQ,ACRTDA,ACRSSX,ACRDOCX,ACRDOCY,ACRZDAX,ACROBLX
+1 QUIT
T1 ;SET THE PURCHASE ORDER FROM WHICH THE ITEM IS BEING PURCHASED WHEN
+1 ;IT IS DIFFERENT FROM THE ORIGINAL REQUISITION FOR WHICH THE ITEM WAS
+2 ;ORDERED
+3 SET DA=+ACRSS(ACRX)
+4 SET DR=".2////"_ACRDOCDA
+5 SET DIE="^ACRSS("
+6 DO DIE^ACRFDIC
+7 QUIT
DELETE ;EP;TO DELETE ITEMS FROM A REQUEST
+1 IF ACRJ<2
SET Y=1
+2 IF '$TEST
Begin DoDot:1
+3 SET DIR(0)="LOA^1:"_ACRJ
+4 SET DIR("A")="Delete item(s) (1-"_ACRJ_") ==> "
+5 WRITE !
+6 DO DIR^ACRFDIC
End DoDot:1
IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$DATA(Y)
KILL ACRQUIT
QUIT
+7 SET ACRX=Y
+8 IF $EXTRACT(ACRX,$LENGTH(ACRX))=","
SET ACRX=$EXTRACT(ACRX,1,($LENGTH(ACRX)-1))
+9 SET DIR(0)="YO"
+10 SET DIR("A")="Sure you want to delete item(s) "_ACRX_" "
+11 SET DIR("B")="NO"
+12 WRITE !
+13 DO DIR^ACRFDIC
+14 IF $DATA(ACGQUIT)!(Y'=1)
KILL ACRQUIT
QUIT
+15 WRITE !
+16 IF $EXTRACT($GET(IOST),1,2)="C-"
DO WAIT^DICD
+17 IF $EXTRACT(ACRX,$LENGTH(ACRX))=","
SET ACRX=$EXTRACT(ACRX,1,$LENGTH(ACRX)-1)
DELETE1 ;EP;TO DELETE ITEM FROM ITEM FILE
+1 ;THE DFN(S) TO BE DELETED MUST BE IN ACRX, ACRX="1,2,3"
+2 FOR ACRI=1:1:$LENGTH(ACRX,",")
Begin DoDot:1
+3 SET ACRY=$PIECE(ACRX,",",ACRI)
+4 IF '$DATA(ACRSS(ACRY))
QUIT
+5 SET ACRDEL=""
+6 SET DA=+ACRSS(ACRY)
+7 SET DIE="^ACRSS("
+8 SET DR="13///0;16///0;16.1///0;18///0"
+9 DO DIE^ACRFDIC
+10 KILL ACRDEL,^ACRSS("C",ACRDOCDA,+ACRSS(ACRY)),^ACRSS("J",ACRDOCDA,+ACRSS(ACRY)),ACRSS(ACRY)
End DoDot:1
+11 DO APCHK^ACRFSCHK
+12 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,4)=35
IF $EXTRACT($GET(^ACROBL(ACRDOCDA,"APV")))="A"
QUIT
+13 DO APPROVE^ACRFSCHK
+14 QUIT
VIEW ;EP;
+1 SET DIR(0)="NOA^1:"_ACRJ_"^K:X'?1N.2N!(X<1)!(X>ACRJ)!'$D(ACRSS(X)) X"
+2 SET DIR("A")="Item NO. ==> "
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
+6 IF '$DATA(^ACRSS(+ACRSS(X),1,1))
Begin DoDot:1
+7 WRITE !!?10,"No ADDITIONAL DESCRIPTION on file for this Item."
+8 HANG 2
End DoDot:1
QUIT
+9 WRITE !
+10 NEW DXS,DIP,DC,DN,D0
+11 SET D0=+ACRSS(X)
+12 DO ^ACRADDM
+13 QUIT
SVEND ;
+1 SET (ACRV1,ACRV2,ACRV1NAM,ACRV2NAM)=""
+2 SET DA=ACRDOCDA
+3 SET DIE="^ACRDOC("
+4 SET DR="[ACR COST COMPARISON]"
+5 DO DDS^ACRFDIC
+6 IF $DATA(ACRSCREN)
Begin DoDot:1
+7 KILL ACRSCREN
+8 WRITE !
+9 DO DIE^ACRFDIC
End DoDot:1
+10 SET ACRV1=$PIECE($GET(^ACRDOC(ACRDOCDA,13)),U,5)
+11 IF ACRV1
IF $DATA(^AUTTVNDR(ACRV1,0))
SET ACRV1NAM=$PIECE(^(0),U)
+12 IF '$TEST
SET (ACRV1,ACRV1NAM)=$PIECE($GET(^ACRDOC(ACRDOCDA,14)),U)
+13 SET ACRV2=$PIECE($GET(^ACRDOC(ACRDOCDA,13)),U,6)
+14 IF ACRV2
IF $DATA(^AUTTVNDR(ACRV2,0))
SET ACRV2NAM=$PIECE(^(0),U)
+15 IF '$TEST
SET (ACRV2,ACRV2NAM)=$PIECE($GET(^ACRDOC(ACRDOCDA,15)),U)
+16 QUIT
EDIT ;EP;TO EDIT COST COMPARISON DATA FOR SELECTED ITEMS
+1 DO SVEND
+2 IF $DATA(ACROUT)
QUIT
+3 IF ACRV1=""&(ACRV2="")
QUIT
+4 NEW ACRI,ACRY
+5 IF ACRJ=1
SET Y=1
DO EDIT1
QUIT
+6 SET DIR(0)="LO^1:"_ACRSJ
+7 SET DIR("A")="Which Item(s)"
+8 WRITE !
+9 DO DIR^ACRFDIC
+10 IF $DATA(ACRQUIT)!$DATA(ACROUT)
KILL ACRQUIT
QUIT
EDIT1 SET ACRY=Y
+1 FOR ACRJ=1,2
IF ACRJ=1&(ACRV1]"")!(ACRJ=2&(ACRV2]""))
Begin DoDot:1
+2 FOR ACRI=1:1
SET X=$PIECE(ACRY,",",ACRI)
IF X=""!$DATA(ACROUT)
QUIT
IF $DATA(ACRSS(X))
DO ED1
End DoDot:1
+3 QUIT
ED1 SET ACRSSDA=+ACRSS(X)
+1 WRITE !!?21,"Item NO. ",X," UNIT COST COMPARISON"
+2 SET DA=ACRSSDA
+3 SET DIE="^ACRSS("
+4 IF ACRJ=1
SET DR=$SELECT(ACRV1:"141////"_ACRV1_";142T;",ACRV1]"":"142T",1:"")
+5 IF ACRJ=2
SET DR=$SELECT(ACRV2:"143////"_(ACRV2)_";144T;",ACRV2]"":"144T",1:"")
+6 DO DIE^ACRFDIC
+7 QUIT
