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

PRCNREQN.m

Go to the documentation of this file.
  1. PRCNREQN ;SSI/ALA-Enter a New Equipment Request ;[ 11/07/96 5:06 PM ]
  1. ;;1.0;Equipment/Turn-In Request;**1,12**;Sep 13, 1996
  1. EN D NOW^%DTC S PRCNDTM=% K %I,%H
  1. D FYQ^PRCNUTL S PRCF("X")="S",PRC("MDIV")=1 D ^PRCFSITE G EQ:'$D(PRC("SITE"))
  1. S DIC("A")="Select CMR: ",DIC(0)="AEQZ",DIC="^ENG(6914.1," D ^DIC G EQ:Y<1
  1. S PRCN("CMR")=$P(Y(0),U),PRCNCMR=+Y,PRCNSRV=$P(Y(0),U,5)
  1. S PRCNRSP=$P(Y(0),U,2) I PRCNRSP="" W !!,"This CMR has no responsible official",$C(7) G EN
  1. I PRCNSRV="" D G EQ:Y<1
  1. . S DIC="^DIC(49," D ^DIC S PRCNSRV=+Y
  1. K DIC,Y,PRCNRSP
  1. ; Build next sequential number (PRCNDA) from site, CMR, fiscal year
  1. S TST=PRC("SITE")_"-"_PRCN("CMR")_"-"_PRC("FY") D SEQ^PRCNUTL
  1. S PRCNTRN=TST_"-"_$E("00000",$L(PRCNDA)+1,5)_PRCNDA,X=PRCNTRN
  1. S DIC="^PRCN(413,",DIC(0)="L",DLAYGO=413 D FILE^DICN S (DA,PRCNRDA)=+Y
  1. W !!,"This Request has been assigned Transaction #: ",PRCNTRN,!
  1. ; Set defaulted information into file for this transaction
  1. S DIE=413,DIE("NO^")="OUTOK",DR="[PRCNEDIT]",NEW=1 D ^DIE
  1. I $G(PRCNTY)="" S DIK="^PRCN(413," D ^DIK G EQ
  1. I PRCNTY="R" D
  1. . I $G(TDA)="" S TDA=$P(^PRCN(413,DA,0),U,11)
  1. . I $G(PRCNTDA)="" S PRCNTDA=TDA
  1. . Q:$O(^PRCN(413.1,PRCNTDA,1,0))=""
  1. . S EDIT=2,DIE=413.1,DR="[PRCNTIRQ]",DA=PRCNTDA D ^DIE
  1. EQ K C,D,NEW,PRC,PRCN,PRCNCMR,PRCNDA,PRCNSRV,PRCNTRN,PRCNTY,TST,DIWF,HL0
  1. K D0,DA,DIC,DIE,DLAYGO,DR,PRCNRDA,PRCNTDA,PRCF,PRCNDTM,I,LL,PL,PRCNQT
  1. K PRCNTXT,PRCNCT,PRCNPJT,J,D1,PRCNRTN,PRCNTYP,RDA,RDI,TDA
  1. K PRCNTDA,EDIT,PFL,QTY
  1. Q
  1. REP ; Build replacement entries for Turn-In request
  1. S RDA=D0,RDI=D1,NUM=0
  1. S QTY=$P(^PRCN(413,RDA,1,RDI,0),U,5),PRCNTYP=$P(^(0),U,12)
  1. S NM=$P($G(^PRCN(413.1,TDA,1,0)),U,3)
  1. I QTY>1 W !!,"A replacement item must be entered for each quantity requested.",!
  1. I $G(PRCNCMR)="" S PRCNCMR=$P(^PRCN(413,RDA,0),U,16)
  1. I NM="" S ^PRCN(413.1,TDA,1,0)="^413.11IPA^^"
  1. RP2 S NM=NM+1,NUM=NUM+1
  1. G RPX:NUM>QTY
  1. S RQ=RDI,$P(^PRCN(413.1,TDA,1,0),U,3,4)=NM_U_NM
  1. NEW DIEL,DI,DK,DL,DM,DP,DU,DIC,DIE,DA,D0,D1,D,DR,Y,DQ,DIFLD,DOV,DE,DC,DG,DH,DN,DV
  1. D GNX Q:$G(DUOUT)=1
  1. G RP2
  1. GNX W !!,"Select the Replacement Item to correspond with Line Item # "_RQ_" Quantity: "_NUM
  1. S DIC("A")="Select REPLACEMENT ITEM: ",DIC="^ENG(6914,",DIC(0)="AEMQZ"
  1. S DIC("S")="I $P($G(^(2)),U,9)=PRCNCMR"
  1. GID D ^DIC I Y<1&(PRCNTYP="C") Q
  1. Q:$G(DUOUT)=1
  1. I Y<1&(PRCNTYP="P") W !,$C(7),"You MUST select the Item that is being replaced for a Parent!" G GNX
  1. S RI=+Y,RIDSC=$P(Y(0),U,2) D DISP^PRCNTIRQ K DIC("S")
  1. I $D(^PRCN(413.1,"AB",RI)) W $C(7),!!,"This ITEM "_RIDSC_" already has a request on file!" K RI G GNX
  1. K ^UTILITY($J,"W") S DIWR=70,DIWL=1,DIWF=""
  1. S X="Are you sure that "_RIDSC_" is the correct item being replaced by requested item, " D ^DIWP
  1. S RQD=0 F S RQD=$O(^PRCN(413,RDA,1,RQ,1,RQD)) Q:RQD'>0 S X=^PRCN(413,RDA,1,RQ,1,RQD,0) D ^DIWP
  1. F I=1:1:^UTILITY($J,"W",DIWL) W !,^UTILITY($J,"W",DIWL,I,0)
  1. G1 W " " D YN^DICN I %=0 W !,"Enter 'Yes' to match the replacement item with item being requested." G G1
  1. I %=2 K RI,X,RIDSC G GID
  1. I %<0 Q
  1. NEW DIEL,DI,DK,DL,DM,DP,DU,DIC,DIE,DA,D0,D1,D,DR,Y,DQ,DIFLD,DOV,DE,DC,DG,DH,DN,DV
  1. S DA(1)=TDA,DA=NM,DIC="^PRCN(413.1,"_DA(1)_",1,",DIE("NO^")=""
  1. S DR=".01///^S X=RI;2///^S X=RDI;3///^S X=RIDSC;.5Replacement Justification~;I X'=6 S Y="""";.7",DIE=DIC D ^DIE
  1. K DR,DIE("NO^") Q
  1. RPX K QTY,NM,RQ,NUM,DR,DOV
  1. Q