Routine: ACRFRR2

ACRFRR2 ;IHS/OIRM/DSD/THL,AEF - CANCEL ITEMS FROM RECEIVING REPORT;  [ 09/23/2005   9:44 AM ]

 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001

 ;;CONTINUATION OF ACRFRR

CANCEL ;EP;

 N ACRCAN

 S DIR(0)="YO"

 S DIR("A")="Create PO for cancelled items"

 S DIR("B")="NO"

W !

 D DIR^ACRFDIC

 S:Y'=1 ACRNEWPO=""

 S DIR(0)="LO^1:"_ACRSSMAX

 S DIR("A")="Cancel which items(s)"

W !

 D DIR^ACRFDIC

 I 'Y!$D(ACRQUIT)!$D(ACROUT) K ACRQUIT Q

 N ACRY

 S ACRY=Y

 F ACRJ=1:1 S ACRSSDA=$P(ACRY,",",ACRJ) Q:'ACRSSDA  D  Q:$D(ACRQUIT)

 .I $D(^ACRRR("B",+ACRSS(ACRSSDA))) D  Q

 ..W *7,*7

 ..W !!,"Receiving action on file for item ",ACRSSDA,"."

 ..W !,"It cannot be cancelled."

 ..H 2

 ..S ACRQUIT=""

 .S ACRCAN($P(ACRSS(ACRSSDA),U))=""

 .K ^ACRSS("C",ACRDOCDA,$P(ACRSS(ACRSSDA),U))

 .K ^ACRSS("J",ACRDOCDA,$P(ACRSS(ACRSSDA),U))

 .K ^ACRSS("E",ACRDOCDA,+$G(^ACRSS($P(ACRSS(ACRSSDA),U),0)),$P(ACRSS(ACRSSDA),U))

 .S DA=+ACRSS(ACRSSDA)

 .S DIE="^ACRSS("

 .S DR="[ACR REJECTION/CANCELLATION]"

 .D DDS^ACRFDIC

 .Q:'$D(ACRSCREN)

 .K ACRSCREN

 .W !

 .D DIE^ACRFDIC

 .K ACREASON

 I $D(ACRQUIT) K ACRQUIT Q

 I $D(ACRNEWPO) K ACRNEWPO D DEL Q

 S ACRTXDA=$P(ACRDOC0,U,4)

 S ACRID=$P(ACRDOC0,U,14)

 S ACRTXPFX="PO"

 S (ACRREF,ACRREFX)=116

 S ACRREFDA=$O(^AUTTDOCR("B",ACRREF,0))

 S ACRCANDA=$P(ACROBL0,U,4)

 S (ACRLBDA,ACRZDA,ACRFDNO)=$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)

N X

 S X=+$G(^ACRDOC(ACRDOCDA,"PA"))

 ;S X=$P($G(^VA(200,+X,0)),U)  ;ACR*2.1*19.02 IM16848

 S X=$$NAME2^ACRFUTL1(+X)  ;ACR*2.1*19.02 IM16848

 S X=$P($P(X,",",2)," ")_" "_$P(X,",")

 W !!,"A new PO is being generated."

 W !,"This PO will be assigned to ",X," to process."

 W !,"Please contact this purchasing agent with any quesitons regarding this order."

 D EN^ACRFAUTO

DEL N ACRX

 S ACRX=0

 F  S ACRX=$O(ACRCAN(ACRX)) Q:'ACRX  D

 .S DA=ACRX

 .S DIE="^ACRSS("

 .S DR="13////0;16////0;16.1////0;18////0"

 .D DIE^ACRFDIC

 .K ^ACRSS("C",ACRDOCDA,ACRX),^ACRSS("J",ACRDOCDA,ACRX)

ACRFRR2   ;IHS/OIRM/DSD/THL,AEF - CANCEL ITEMS FROM RECEIVING REPORT;  [ 09/23/2005   9:44 AM ]

 +1       ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001

 +2       ;;CONTINUATION OF ACRFRR

CANCEL    ;EP;

 +1        NEW ACRCAN

 +2        SET DIR(0)="YO"

 +3        SET DIR("A")="Create PO for cancelled items"

 +4        SET DIR("B")="NO"

 +5        WRITE !

 +6        DO DIR^ACRFDIC

 +7        IF Y'=1

               SET ACRNEWPO=""

 +8        SET DIR(0)="LO^1:"_ACRSSMAX

 +9        SET DIR("A")="Cancel which items(s)"

 +10       WRITE !

 +11       DO DIR^ACRFDIC

 +12       IF 'Y!$DATA(ACRQUIT)!$DATA(ACROUT)

               KILL ACRQUIT

               QUIT

 +13       NEW ACRY

 +14       SET ACRY=Y

 +15       FOR ACRJ=1:1

               SET ACRSSDA=$PIECE(ACRY,",",ACRJ)

               IF 'ACRSSDA

                   QUIT

               Begin DoDot:1

 +16               IF $DATA(^ACRRR("B",+ACRSS(ACRSSDA)))

                       Begin DoDot:2

 +17                       WRITE *7,*7

 +18                       WRITE !!,"Receiving action on file for item ",ACRSSDA,"."

 +19                       WRITE !,"It cannot be cancelled."

 +20                       HANG 2

 +21                       SET ACRQUIT=""

                       End DoDot:2

                       QUIT

 +22               SET ACRCAN($PIECE(ACRSS(ACRSSDA),U))=""

 +23               KILL ^ACRSS("C",ACRDOCDA,$PIECE(ACRSS(ACRSSDA),U))

 +24               KILL ^ACRSS("J",ACRDOCDA,$PIECE(ACRSS(ACRSSDA),U))

 +25               KILL ^ACRSS("E",ACRDOCDA,+$GET(^ACRSS($PIECE(ACRSS(ACRSSDA),U),0)),$PIECE(ACRSS(ACRSSDA),U))

 +26               SET DA=+ACRSS(ACRSSDA)

 +27               SET DIE="^ACRSS("

 +28               SET DR="[ACR REJECTION/CANCELLATION]"

 +29               DO DDS^ACRFDIC

 +30               IF '$DATA(ACRSCREN)

                       QUIT

 +31               KILL ACRSCREN

 +32               WRITE !

 +33               DO DIE^ACRFDIC

 +34               KILL ACREASON

               End DoDot:1

               IF $DATA(ACRQUIT)

                   QUIT

 +35       IF $DATA(ACRQUIT)

               KILL ACRQUIT

               QUIT

 +36       IF $DATA(ACRNEWPO)

               KILL ACRNEWPO

               DO DEL

               QUIT

 +37       SET ACRTXDA=$PIECE(ACRDOC0,U,4)

 +38       SET ACRID=$PIECE(ACRDOC0,U,14)

 +39       SET ACRTXPFX="PO"

 +40       SET (ACRREF,ACRREFX)=116

 +41       SET ACRREFDA=$ORDER(^AUTTDOCR("B",ACRREF,0))

 +42       SET ACRCANDA=$PIECE(ACROBL0,U,4)

 +43       SET (ACRLBDA,ACRZDA,ACRFDNO)=$PIECE(ACROBL0,U,3)

 +44       SET ACRALWNO=$PIECE(ACROBL0,U,8)

 +45       SET ACRSSADA=$PIECE(ACROBL0,U,7)

 +46       SET ACRAPPDA=$PIECE(ACROBL0,U,9)

 +47       SET ACRTXOBJ=$PIECE(ACROBLDT,U,3)

 +48       NEW X

 +49       SET X=+$GET(^ACRDOC(ACRDOCDA,"PA"))

 +50      ;S X=$P($G(^VA(200,+X,0)),U)  ;ACR*2.1*19.02 IM16848

 +51      ;ACR*2.1*19.02 IM16848

           SET X=$$NAME2^ACRFUTL1(+X)

 +52       SET X=$PIECE($PIECE(X,",",2)," ")_" "_$PIECE(X,",")

 +53       WRITE !!,"A new PO is being generated."

 +54       WRITE !,"This PO will be assigned to ",X," to process."

 +55       WRITE !,"Please contact this purchasing agent with any quesitons regarding this order."

 +56       DO EN^ACRFAUTO

 +57       QUIT

DEL        NEW ACRX

 +1        SET ACRX=0

 +2        FOR

               SET ACRX=$ORDER(ACRCAN(ACRX))

               IF 'ACRX

                   QUIT

               Begin DoDot:1

 +3                SET DA=ACRX

 +4                SET DIE="^ACRSS("

 +5                SET DR="13////0;16////0;16.1////0;18////0"

 +6                DO DIE^ACRFDIC

 +7                KILL ^ACRSS("C",ACRDOCDA,ACRX),^ACRSS("J",ACRDOCDA,ACRX)

               End DoDot:1

 +8        QUIT

ACRFRR2.m