source: FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNREQN.m@ 1683

Last change on this file since 1683 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.2 KB
Line 
1PRCNREQN ;SSI/ALA-Enter a New Equipment Request ;[ 11/07/96 5:06 PM ]
2 ;;1.0;Equipment/Turn-In Request;**1,12**;Sep 13, 1996
3EN D NOW^%DTC S PRCNDTM=% K %I,%H
4 D FYQ^PRCNUTL S PRCF("X")="S",PRC("MDIV")=1 D ^PRCFSITE G EQ:'$D(PRC("SITE"))
5 S DIC("A")="Select CMR: ",DIC(0)="AEQZ",DIC="^ENG(6914.1," D ^DIC G EQ:Y<1
6 S PRCN("CMR")=$P(Y(0),U),PRCNCMR=+Y,PRCNSRV=$P(Y(0),U,5)
7 S PRCNRSP=$P(Y(0),U,2) I PRCNRSP="" W !!,"This CMR has no responsible official",$C(7) G EN
8 I PRCNSRV="" D G EQ:Y<1
9 . S DIC="^DIC(49," D ^DIC S PRCNSRV=+Y
10 K DIC,Y,PRCNRSP
11 ; Build next sequential number (PRCNDA) from site, CMR, fiscal year
12 S TST=PRC("SITE")_"-"_PRCN("CMR")_"-"_PRC("FY") D SEQ^PRCNUTL
13 S PRCNTRN=TST_"-"_$E("00000",$L(PRCNDA)+1,5)_PRCNDA,X=PRCNTRN
14 S DIC="^PRCN(413,",DIC(0)="L",DLAYGO=413 D FILE^DICN S (DA,PRCNRDA)=+Y
15 W !!,"This Request has been assigned Transaction #: ",PRCNTRN,!
16 ; Set defaulted information into file for this transaction
17 S DIE=413,DIE("NO^")="OUTOK",DR="[PRCNEDIT]",NEW=1 D ^DIE
18 I $G(PRCNTY)="" S DIK="^PRCN(413," D ^DIK G EQ
19 I PRCNTY="R" D
20 . I $G(TDA)="" S TDA=$P(^PRCN(413,DA,0),U,11)
21 . I $G(PRCNTDA)="" S PRCNTDA=TDA
22 . Q:$O(^PRCN(413.1,PRCNTDA,1,0))=""
23 . S EDIT=2,DIE=413.1,DR="[PRCNTIRQ]",DA=PRCNTDA D ^DIE
24EQ K C,D,NEW,PRC,PRCN,PRCNCMR,PRCNDA,PRCNSRV,PRCNTRN,PRCNTY,TST,DIWF,HL0
25 K D0,DA,DIC,DIE,DLAYGO,DR,PRCNRDA,PRCNTDA,PRCF,PRCNDTM,I,LL,PL,PRCNQT
26 K PRCNTXT,PRCNCT,PRCNPJT,J,D1,PRCNRTN,PRCNTYP,RDA,RDI,TDA
27 K PRCNTDA,EDIT,PFL,QTY
28 Q
29REP ; Build replacement entries for Turn-In request
30 S RDA=D0,RDI=D1,NUM=0
31 S QTY=$P(^PRCN(413,RDA,1,RDI,0),U,5),PRCNTYP=$P(^(0),U,12)
32 S NM=$P($G(^PRCN(413.1,TDA,1,0)),U,3)
33 I QTY>1 W !!,"A replacement item must be entered for each quantity requested.",!
34 I $G(PRCNCMR)="" S PRCNCMR=$P(^PRCN(413,RDA,0),U,16)
35 I NM="" S ^PRCN(413.1,TDA,1,0)="^413.11IPA^^"
36RP2 S NM=NM+1,NUM=NUM+1
37 G RPX:NUM>QTY
38 S RQ=RDI,$P(^PRCN(413.1,TDA,1,0),U,3,4)=NM_U_NM
39 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
40 D GNX Q:$G(DUOUT)=1
41 G RP2
42GNX W !!,"Select the Replacement Item to correspond with Line Item # "_RQ_" Quantity: "_NUM
43 S DIC("A")="Select REPLACEMENT ITEM: ",DIC="^ENG(6914,",DIC(0)="AEMQZ"
44 S DIC("S")="I $P($G(^(2)),U,9)=PRCNCMR"
45GID D ^DIC I Y<1&(PRCNTYP="C") Q
46 Q:$G(DUOUT)=1
47 I Y<1&(PRCNTYP="P") W !,$C(7),"You MUST select the Item that is being replaced for a Parent!" G GNX
48 S RI=+Y,RIDSC=$P(Y(0),U,2) D DISP^PRCNTIRQ K DIC("S")
49 I $D(^PRCN(413.1,"AB",RI)) W $C(7),!!,"This ITEM "_RIDSC_" already has a request on file!" K RI G GNX
50 K ^UTILITY($J,"W") S DIWR=70,DIWL=1,DIWF=""
51 S X="Are you sure that "_RIDSC_" is the correct item being replaced by requested item, " D ^DIWP
52 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
53 F I=1:1:^UTILITY($J,"W",DIWL) W !,^UTILITY($J,"W",DIWL,I,0)
54G1 W " " D YN^DICN I %=0 W !,"Enter 'Yes' to match the replacement item with item being requested." G G1
55 I %=2 K RI,X,RIDSC G GID
56 I %<0 Q
57 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
58 S DA(1)=TDA,DA=NM,DIC="^PRCN(413.1,"_DA(1)_",1,",DIE("NO^")=""
59 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
60 K DR,DIE("NO^") Q
61RPX K QTY,NM,RQ,NUM,DR,DOV
62 Q
Note: See TracBrowser for help on using the repository browser.