ACRFSHIP ;IHS/OIRM/DSD/THL,AEF - SHIPPING INSTRUCTIONS; [ 09/23/2005 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
;;TO REVIEW AND EDIT SHIPPING INSTRUCTIONS
EN ;EP;TO REVIEW AND EDIT SHIPPING INSTRUCTIONS
F D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
EXIT K ACRQUIT,ACRST,ACRRA,ACRSSDA,ACRY,ACRRA,ACRITEMS,ACRDPTDA,ACRSIDA,ACRQUAN,ACRSSI,ACRSS,ACRSI,ACRDMAX,ACRIMAX
Q
EN1 D DISPLAY,CHOOSE
Q
DISPLAY ;EP;TO DISPLAY CURRENT SHIPPING INSTRUCTIONS
D HEAD
S ACRST=$G(^ACRDOC(ACRDOCDA,"POST"))
I $E(IOST,1,2)'="P-",+ACRST,'$D(^ACRSI("AB",ACRDOCDA,+ACRST)) D Q:$D(ACRQUIT)!$D(ACROUT)
.S (ACRDPTDA,D0)=+ACRST,ACRDMAX=""
.W !!,"Primary Ship To Location:"
.W !
.D DISP
.S DIR(0)="YO"
.S DIR("A")="Include Primary Ship To Location in Instrutions"
.S DIR("B")="YES"
.W !
.D DIR^ACRFDIC
.Q:+Y'=1
.D FILE
S (ACRDMAX,ACRSIDA)=0
F S ACRSIDA=$O(^ACRSI("B",ACRDOCDA,ACRSIDA)) Q:'ACRSIDA D
.S ACRST=$P($G(^ACRSI(ACRSIDA,0)),U,2)
.S ACRRA=$P($G(^ACRSI(ACRSIDA,0)),U,3)
.Q:'ACRST
.S D0=+ACRST
.S ACRDMAX=ACRDMAX+1
.S ACRSI(ACRDMAX)=ACRSIDA
.D DISP
.I $D(ACRSIDA) D IDISP^ACRFSHI1
Q
CHOOSE ;EP;TO CHOOSE SHIPPING INSTRUCTION FUNCTION
S DIR(0)="SO^1:ADD a Shipping Location"_$S($D(^ACRSI("B",ACRDOCDA)):";2:EDIT a Shipping Location;3:DELETE a Shipping Location",1:"")
W !
D DIR^ACRFDIC
Q:$D(ACRQUIT)!$D(ACROUT)!'$G(Y)
I Y=1 D ADD Q
I Y=2 D EDIT Q
I Y=3 D DELETE Q
Q
SELECT ;SELECT SHIPPING INSTRUCTION TO EDIT
Q
ADD ;
D DEPT
Q:$D(ACRQUIT)!$D(ACROUT)
I $D(^ACRSI("AC",ACRDOCDA,ACRDPTDA)) D Q
.W !!,"This DEPARTMENT is already identified as a SHIPPING location for this document."
.W !,"Use the EDIT mode to add or delete items to be shipped to this DEPARTMENT."
.D PAUSE^ACRFWARN
D FILE
D ITEM
Q:$D(ACRQUIT)!$D(ACROUT)
D RECEIVER
Q:$D(ACROUT)
S:'$D(^ACRSI(ACRSIDA,1,0)) ^ACRSI(ACRSIDA,1,0)="^9003010.01P"
S ACRSS=0
F S ACRSS=$O(ACRSS(ACRSS)) Q:'ACRSS
Q
FILE S X=ACRDOCDA
S DIC="^ACRSI("
S DIC(0)="L"
S DIC("DR")=".02////"_ACRDPTDA_";.03////"_$G(ACRRA)
D FILE^ACRFDIC
S ACRSIDA=+Y
Q
EDIT ;EDIT EXISTING SHIPPING INSTRUTIONS
I ACRDMAX=1 S Y=1 D EDIT1 Q
S DIR(0)="NO^1:"_ACRDMAX
S DIR("A")="Which Shipping Location"
W !
D DIR^ACRFDIC
I +Y<1!'$D(ACRSI(+Y)) S ACRQUIT="" Q
EDIT1 S (ACRSIDA,DA)=ACRSI(+Y)
D EI
Q
EI W !
S DIE="^ACRSI("
S DR="[ACR SHIPPING INSTRUCTION]"
D DDS^ACRFDIC
I $D(ACRSCREN) K ACRSCREN D DIE^ACRFDIC
D ITEMS^ACRFSHI1
Q
DELETE ;DELETE EXISTING SHIPPING INSTRUTIONS
I ACRDMAX=1 S Y=1 D D1 Q
S DIR(0)="NO^1:"_ACRDMAX
S DIR("A")="Which Location do you want to DELETE"
W !
D DIR^ACRFDIC
I +Y<1!'$D(ACRSI(+Y)) S ACRQUIT="" Q
D1 S DA=ACRSI(+Y)
S DIK="^ACRSI("
S DIR(0)="YO"
S DIR("A")="Are you certain you want to DELETE Location NO. "_+Y
S DIR("B")="NO"
W !
D DIR^ACRFDIC
Q:+Y'=1
D DIK^ACRFDIC
Q
Q
DISP ;EP;TO DISPLAY SHIPPING LOCATION
;REQUIRES THAT 'D0' BE SET TO THE INTERNAL ENTRY NUMBER OF THE
;OF THE 'FMS DEPARTMENT/PROGRAM' FILE
N DXS,DIP
W !!?5,$G(ACRDMAX)
D ^ACRPDA
I $G(ACRRA) D
.;S X=$P($G(^VA(200,ACRRA,0)),U) ;ACR*2.1*19.02 IM16848
.S X=$$NAME2^ACRFUTL1(ACRRA) ;ACR*2.1*19.02 IM16848
.S X=$P($P(X,",",2)," ")_" "_$P(X,",")
.W !?9,"ATTN.: ",X
Q
DEPT ;SELECT DEPARTMENT TO SHIP TO
S DIC="^AUTTPRG("
S DIC(0)="AEMQZ"
S DIC("A")="Ship to DEPARTMENT..: "
W !
D DIC^ACRFDIC
I +Y<1 S ACRQUIT="" Q
Q:$D(ACROUT)
S (D0,ACRSIDA,ACRDPTDA)=+Y
D DISP
Q
ITEM ;CREATE LIST OF ITEMS TO BE SHIPPED TO SELECTED DEPARTMENT
I '$O(^ACRSS("J",ACRDOCDA,0)) S ACRQUIT="" Q
D IARRAY^ACRFSHI1
I ACRJ=1 S ACRITEMS=1 Q
S DIR(0)="LO^1:"_ACRJ
S DIR("A")="Which ITEM(S)......."
W !
D DIR^ACRFDIC
I +Y<1 S ACRQUIT="" Q
S ACRITEMS=Y
Q
RECEIVER ;SELECT NAME OF RECEIVING OFFICIAL
S DIC="^VA(200,"
S DIC(0)="AEMQZ"
S DIC("A")="RECEIVING AGENT.....: "
S DIC("S")="I $D(^ACRAPL(""AC"",+Y,7))"
W !
D DIC^ACRFDIC
I +Y<1 S ACRQUIT="" Q
S ACRRA=+Y
Q
HEAD ;EP;PRINT HEADER FOR LIST OF ALL SHIPPING LOCATION HEADER
W:$E(IOST,1,2)="C-" @IOF
W !?5,"***************************************************************"
W !?5,"SHIPPING INSTRUCTIONS FOR ORDER NO:"
W !?5,$P(^ACRDOC(ACRDOCDA,0),U,2)
W ?$X+2,"(",$P(^ACRDOC(ACRDOCDA,0),U),")"
W !?5,"***************************************************************"
Q
PRINT ;EP;TO PRINT CALL FOR PRINT OF SHIPPING INSTRUCTIONS
Q:'$D(^ACRSI("B",ACRDOCDA))
K ACRSHIP
S DIR(0)="YO"
S DIR("A")="Include Shipping Instructions"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
S:Y=1 ACRSHIP=""
Q
ACRFSHIP ;IHS/OIRM/DSD/THL,AEF - SHIPPING INSTRUCTIONS; [ 09/23/2005 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
+2 ;;TO REVIEW AND EDIT SHIPPING INSTRUCTIONS
EN ;EP;TO REVIEW AND EDIT SHIPPING INSTRUCTIONS
+1 FOR
DO EN1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
EXIT KILL ACRQUIT,ACRST,ACRRA,ACRSSDA,ACRY,ACRRA,ACRITEMS,ACRDPTDA,ACRSIDA,ACRQUAN,ACRSSI,ACRSS,ACRSI,ACRDMAX,ACRIMAX
+1 QUIT
EN1 DO DISPLAY
DO CHOOSE
+1 QUIT
DISPLAY ;EP;TO DISPLAY CURRENT SHIPPING INSTRUCTIONS
+1 DO HEAD
+2 SET ACRST=$GET(^ACRDOC(ACRDOCDA,"POST"))
+3 IF $EXTRACT(IOST,1,2)'="P-"
IF +ACRST
IF '$DATA(^ACRSI("AB",ACRDOCDA,+ACRST))
Begin DoDot:1
+4 SET (ACRDPTDA,D0)=+ACRST
SET ACRDMAX=""
+5 WRITE !!,"Primary Ship To Location:"
+6 WRITE !
+7 DO DISP
+8 SET DIR(0)="YO"
+9 SET DIR("A")="Include Primary Ship To Location in Instrutions"
+10 SET DIR("B")="YES"
+11 WRITE !
+12 DO DIR^ACRFDIC
+13 IF +Y'=1
QUIT
+14 DO FILE
End DoDot:1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+15 SET (ACRDMAX,ACRSIDA)=0
+16 FOR
SET ACRSIDA=$ORDER(^ACRSI("B",ACRDOCDA,ACRSIDA))
IF 'ACRSIDA
QUIT
Begin DoDot:1
+17 SET ACRST=$PIECE($GET(^ACRSI(ACRSIDA,0)),U,2)
+18 SET ACRRA=$PIECE($GET(^ACRSI(ACRSIDA,0)),U,3)
+19 IF 'ACRST
QUIT
+20 SET D0=+ACRST
+21 SET ACRDMAX=ACRDMAX+1
+22 SET ACRSI(ACRDMAX)=ACRSIDA
+23 DO DISP
+24 IF $DATA(ACRSIDA)
DO IDISP^ACRFSHI1
End DoDot:1
+25 QUIT
CHOOSE ;EP;TO CHOOSE SHIPPING INSTRUCTION FUNCTION
+1 SET DIR(0)="SO^1:ADD a Shipping Location"_$SELECT($DATA(^ACRSI("B",ACRDOCDA)):";2:EDIT a Shipping Location;3:DELETE a Shipping Location",1:"")
+2 WRITE !
+3 DO DIR^ACRFDIC
+4 IF $DATA(ACRQUIT)!$DATA(ACROUT)!'$GET(Y)
QUIT
+5 IF Y=1
DO ADD
QUIT
+6 IF Y=2
DO EDIT
QUIT
+7 IF Y=3
DO DELETE
QUIT
+8 QUIT
SELECT ;SELECT SHIPPING INSTRUCTION TO EDIT
+1 QUIT
ADD ;
+1 DO DEPT
+2 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+3 IF $DATA(^ACRSI("AC",ACRDOCDA,ACRDPTDA))
Begin DoDot:1
+4 WRITE !!,"This DEPARTMENT is already identified as a SHIPPING location for this document."
+5 WRITE !,"Use the EDIT mode to add or delete items to be shipped to this DEPARTMENT."
+6 DO PAUSE^ACRFWARN
End DoDot:1
QUIT
+7 DO FILE
+8 DO ITEM
+9 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+10 DO RECEIVER
+11 IF $DATA(ACROUT)
QUIT
+12 IF '$DATA(^ACRSI(ACRSIDA,1,0))
SET ^ACRSI(ACRSIDA,1,0)="^9003010.01P"
+13 SET ACRSS=0
+14 FOR
SET ACRSS=$ORDER(ACRSS(ACRSS))
IF 'ACRSS
QUIT
+15 QUIT
FILE SET X=ACRDOCDA
+1 SET DIC="^ACRSI("
+2 SET DIC(0)="L"
+3 SET DIC("DR")=".02////"_ACRDPTDA_";.03////"_$GET(ACRRA)
+4 DO FILE^ACRFDIC
+5 SET ACRSIDA=+Y
+6 QUIT
EDIT ;EDIT EXISTING SHIPPING INSTRUTIONS
+1 IF ACRDMAX=1
SET Y=1
DO EDIT1
QUIT
+2 SET DIR(0)="NO^1:"_ACRDMAX
+3 SET DIR("A")="Which Shipping Location"
+4 WRITE !
+5 DO DIR^ACRFDIC
+6 IF +Y<1!'$DATA(ACRSI(+Y))
SET ACRQUIT=""
QUIT
EDIT1 SET (ACRSIDA,DA)=ACRSI(+Y)
+1 DO EI
+2 QUIT
EI WRITE !
+1 SET DIE="^ACRSI("
+2 SET DR="[ACR SHIPPING INSTRUCTION]"
+3 DO DDS^ACRFDIC
+4 IF $DATA(ACRSCREN)
KILL ACRSCREN
DO DIE^ACRFDIC
+5 DO ITEMS^ACRFSHI1
+6 QUIT
DELETE ;DELETE EXISTING SHIPPING INSTRUTIONS
+1 IF ACRDMAX=1
SET Y=1
DO D1
QUIT
+2 SET DIR(0)="NO^1:"_ACRDMAX
+3 SET DIR("A")="Which Location do you want to DELETE"
+4 WRITE !
+5 DO DIR^ACRFDIC
+6 IF +Y<1!'$DATA(ACRSI(+Y))
SET ACRQUIT=""
QUIT
D1 SET DA=ACRSI(+Y)
+1 SET DIK="^ACRSI("
+2 SET DIR(0)="YO"
+3 SET DIR("A")="Are you certain you want to DELETE Location NO. "_+Y
+4 SET DIR("B")="NO"
+5 WRITE !
+6 DO DIR^ACRFDIC
+7 IF +Y'=1
QUIT
+8 DO DIK^ACRFDIC
+9 QUIT
+10 QUIT
DISP ;EP;TO DISPLAY SHIPPING LOCATION
+1 ;REQUIRES THAT 'D0' BE SET TO THE INTERNAL ENTRY NUMBER OF THE
+2 ;OF THE 'FMS DEPARTMENT/PROGRAM' FILE
+3 NEW DXS,DIP
+4 WRITE !!?5,$GET(ACRDMAX)
+5 DO ^ACRPDA
+6 IF $GET(ACRRA)
Begin DoDot:1
+7 ;S X=$P($G(^VA(200,ACRRA,0)),U) ;ACR*2.1*19.02 IM16848
+8 ;ACR*2.1*19.02 IM16848
SET X=$$NAME2^ACRFUTL1(ACRRA)
+9 SET X=$PIECE($PIECE(X,",",2)," ")_" "_$PIECE(X,",")
+10 WRITE !?9,"ATTN.: ",X
End DoDot:1
+11 QUIT
DEPT ;SELECT DEPARTMENT TO SHIP TO
+1 SET DIC="^AUTTPRG("
+2 SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Ship to DEPARTMENT..: "
+4 WRITE !
+5 DO DIC^ACRFDIC
+6 IF +Y<1
SET ACRQUIT=""
QUIT
+7 IF $DATA(ACROUT)
QUIT
+8 SET (D0,ACRSIDA,ACRDPTDA)=+Y
+9 DO DISP
+10 QUIT
ITEM ;CREATE LIST OF ITEMS TO BE SHIPPED TO SELECTED DEPARTMENT
+1 IF '$ORDER(^ACRSS("J",ACRDOCDA,0))
SET ACRQUIT=""
QUIT
+2 DO IARRAY^ACRFSHI1
+3 IF ACRJ=1
SET ACRITEMS=1
QUIT
+4 SET DIR(0)="LO^1:"_ACRJ
+5 SET DIR("A")="Which ITEM(S)......."
+6 WRITE !
+7 DO DIR^ACRFDIC
+8 IF +Y<1
SET ACRQUIT=""
QUIT
+9 SET ACRITEMS=Y
+10 QUIT
RECEIVER ;SELECT NAME OF RECEIVING OFFICIAL
+1 SET DIC="^VA(200,"
+2 SET DIC(0)="AEMQZ"
+3 SET DIC("A")="RECEIVING AGENT.....: "
+4 SET DIC("S")="I $D(^ACRAPL(""AC"",+Y,7))"
+5 WRITE !
+6 DO DIC^ACRFDIC
+7 IF +Y<1
SET ACRQUIT=""
QUIT
+8 SET ACRRA=+Y
+9 QUIT
HEAD ;EP;PRINT HEADER FOR LIST OF ALL SHIPPING LOCATION HEADER
+1 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+2 WRITE !?5,"***************************************************************"
+3 WRITE !?5,"SHIPPING INSTRUCTIONS FOR ORDER NO:"
+4 WRITE !?5,$PIECE(^ACRDOC(ACRDOCDA,0),U,2)
+5 WRITE ?$X+2,"(",$PIECE(^ACRDOC(ACRDOCDA,0),U),")"
+6 WRITE !?5,"***************************************************************"
+7 QUIT
PRINT ;EP;TO PRINT CALL FOR PRINT OF SHIPPING INSTRUCTIONS
+1 IF '$DATA(^ACRSI("B",ACRDOCDA))
QUIT
+2 KILL ACRSHIP
+3 SET DIR(0)="YO"
+4 SET DIR("A")="Include Shipping Instructions"
+5 SET DIR("B")="NO"
+6 WRITE !
+7 DO DIR^ACRFDIC
+8 IF Y=1
SET ACRSHIP=""
+9 QUIT
