Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACRFSHIP

ACRFSHIP.m

Go to the documentation of this file. 
  1. 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
  1.  ;;TO REVIEW AND EDIT SHIPPING INSTRUCTIONS
  1. EN ;EP;TO REVIEW AND EDIT SHIPPING INSTRUCTIONS
  1.  F  D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
  1. EXIT K ACRQUIT,ACRST,ACRRA,ACRSSDA,ACRY,ACRRA,ACRITEMS,ACRDPTDA,ACRSIDA,ACRQUAN,ACRSSI,ACRSS,ACRSI,ACRDMAX,ACRIMAX
  1.  Q
  1. EN1 D DISPLAY,CHOOSE
  1.  Q
  1. DISPLAY ;EP;TO DISPLAY CURRENT SHIPPING INSTRUCTIONS
  1.  D HEAD
  1.  S ACRST=$G(^ACRDOC(ACRDOCDA,"POST"))
  1.  I $E(IOST,1,2)'="P-",+ACRST,'$D(^ACRSI("AB",ACRDOCDA,+ACRST)) D  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  .S (ACRDPTDA,D0)=+ACRST,ACRDMAX=""
  1.  .W !!,"Primary Ship To Location:"
  1.  .W !
  1.  .D DISP
  1.  .S DIR(0)="YO"
  1.  .S DIR("A")="Include Primary Ship To Location in Instrutions"
  1.  .S DIR("B")="YES"
  1.  .W !
  1.  .D DIR^ACRFDIC
  1.  .Q:+Y'=1
  1.  .D FILE
  1.  S (ACRDMAX,ACRSIDA)=0
  1.  F  S ACRSIDA=$O(^ACRSI("B",ACRDOCDA,ACRSIDA)) Q:'ACRSIDA  D
  1.  .S ACRST=$P($G(^ACRSI(ACRSIDA,0)),U,2)
  1.  .S ACRRA=$P($G(^ACRSI(ACRSIDA,0)),U,3)
  1.  .Q:'ACRST
  1.  .S D0=+ACRST
  1.  .S ACRDMAX=ACRDMAX+1
  1.  .S ACRSI(ACRDMAX)=ACRSIDA
  1.  .D DISP
  1.  .I $D(ACRSIDA) D IDISP^ACRFSHI1
  1.  Q
  1. CHOOSE ;EP;TO CHOOSE SHIPPING INSTRUCTION FUNCTION
  1.  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:"")
  1.  W !
  1.  D DIR^ACRFDIC
  1.  Q:$D(ACRQUIT)!$D(ACROUT)!'$G(Y)
  1.  I Y=1 D ADD Q
  1.  I Y=2 D EDIT Q
  1.  I Y=3 D DELETE Q
  1.  Q
  1. SELECT ;SELECT SHIPPING INSTRUCTION TO EDIT
  1.  Q
  1. ADD ;
  1.  D DEPT
  1.  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  I $D(^ACRSI("AC",ACRDOCDA,ACRDPTDA)) D  Q
  1.  .W !!,"This DEPARTMENT is already identified as a SHIPPING location for this document."
  1.  .W !,"Use the EDIT mode to add or delete items to be shipped to this DEPARTMENT."
  1.  .D PAUSE^ACRFWARN
  1.  D FILE
  1.  D ITEM
  1.  Q:$D(ACRQUIT)!$D(ACROUT)
  1.  D RECEIVER
  1.  Q:$D(ACROUT)
  1.  S:'$D(^ACRSI(ACRSIDA,1,0)) ^ACRSI(ACRSIDA,1,0)="^9003010.01P"
  1.  S ACRSS=0
  1.  F  S ACRSS=$O(ACRSS(ACRSS)) Q:'ACRSS
  1.  Q
  1. FILE S X=ACRDOCDA
  1.  S DIC="^ACRSI("
  1.  S DIC(0)="L"
  1.  S DIC("DR")=".02////"_ACRDPTDA_";.03////"_$G(ACRRA)
  1.  D FILE^ACRFDIC
  1.  S ACRSIDA=+Y
  1.  Q
  1. EDIT ;EDIT EXISTING SHIPPING INSTRUTIONS
  1.  I ACRDMAX=1 S Y=1 D EDIT1 Q
  1.  S DIR(0)="NO^1:"_ACRDMAX
  1.  S DIR("A")="Which Shipping Location"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I +Y<1!'$D(ACRSI(+Y)) S ACRQUIT="" Q
  1. EDIT1 S (ACRSIDA,DA)=ACRSI(+Y)
  1.  D EI
  1.  Q
  1. EI W !
  1.  S DIE="^ACRSI("
  1.  S DR="[ACR SHIPPING INSTRUCTION]"
  1.  D DDS^ACRFDIC
  1.  I $D(ACRSCREN) K ACRSCREN D DIE^ACRFDIC
  1.  D ITEMS^ACRFSHI1
  1.  Q
  1. DELETE ;DELETE EXISTING SHIPPING INSTRUTIONS
  1.  I ACRDMAX=1 S Y=1 D D1 Q
  1.  S DIR(0)="NO^1:"_ACRDMAX
  1.  S DIR("A")="Which Location do you want to DELETE"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I +Y<1!'$D(ACRSI(+Y)) S ACRQUIT="" Q
  1. D1 S DA=ACRSI(+Y)
  1.  S DIK="^ACRSI("
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Are you certain you want to DELETE Location NO. "_+Y
  1.  S DIR("B")="NO"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  Q:+Y'=1
  1.  D DIK^ACRFDIC
  1.  Q
  1.  Q
  1. DISP ;EP;TO DISPLAY SHIPPING LOCATION
  1.  ;REQUIRES THAT 'D0' BE SET TO THE INTERNAL ENTRY NUMBER OF THE
  1.  ;OF THE 'FMS DEPARTMENT/PROGRAM' FILE
  1.  N DXS,DIP
  1.  W !!?5,$G(ACRDMAX)
  1.  D ^ACRPDA
  1.  I $G(ACRRA) D
  1.  .;S X=$P($G(^VA(200,ACRRA,0)),U)  ;ACR*2.1*19.02 IM16848
  1.  .S X=$$NAME2^ACRFUTL1(ACRRA)  ;ACR*2.1*19.02 IM16848
  1.  .S X=$P($P(X,",",2)," ")_" "_$P(X,",")
  1.  .W !?9,"ATTN.: ",X
  1.  Q
  1. DEPT ;SELECT DEPARTMENT TO SHIP TO
  1.  S DIC="^AUTTPRG("
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="Ship to DEPARTMENT..: "
  1.  W !
  1.  D DIC^ACRFDIC
  1.  I +Y<1 S ACRQUIT="" Q
  1.  Q:$D(ACROUT)
  1.  S (D0,ACRSIDA,ACRDPTDA)=+Y
  1.  D DISP
  1.  Q
  1. ITEM ;CREATE LIST OF ITEMS TO BE SHIPPED TO SELECTED DEPARTMENT
  1.  I '$O(^ACRSS("J",ACRDOCDA,0)) S ACRQUIT="" Q
  1.  D IARRAY^ACRFSHI1
  1.  I ACRJ=1 S ACRITEMS=1 Q
  1.  S DIR(0)="LO^1:"_ACRJ
  1.  S DIR("A")="Which ITEM(S)......."
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I +Y<1 S ACRQUIT="" Q
  1.  S ACRITEMS=Y
  1.  Q
  1. RECEIVER ;SELECT NAME OF RECEIVING OFFICIAL
  1.  S DIC="^VA(200,"
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("A")="RECEIVING AGENT.....: "
  1.  S DIC("S")="I $D(^ACRAPL(""AC"",+Y,7))"
  1.  W !
  1.  D DIC^ACRFDIC
  1.  I +Y<1 S ACRQUIT="" Q
  1.  S ACRRA=+Y
  1.  Q
  1.  W:$E(IOST,1,2)="C-" @IOF
  1.  W !?5,"***************************************************************"
  1.  W !?5,"SHIPPING INSTRUCTIONS FOR ORDER NO:"
  1.  W !?5,$P(^ACRDOC(ACRDOCDA,0),U,2)
  1.  W ?$X+2,"(",$P(^ACRDOC(ACRDOCDA,0),U),")"
  1.  W !?5,"***************************************************************"
  1.  Q
  1. PRINT ;EP;TO PRINT CALL FOR PRINT OF SHIPPING INSTRUCTIONS
  1.  Q:'$D(^ACRSI("B",ACRDOCDA))
  1.  K ACRSHIP
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Include Shipping Instructions"
  1.  S DIR("B")="NO"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  S:Y=1 ACRSHIP=""
  1.  Q