ACRFSS2.m

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