PRCNREQN ;SSI/ALA-Enter a New Equipment Request ;[ 11/07/96 5:06 PM ]
;;1.0;Equipment/Turn-In Request;**1,12**;Sep 13, 1996
EN D NOW^%DTC S PRCNDTM=% K %I,%H
D FYQ^PRCNUTL S PRCF("X")="S",PRC("MDIV")=1 D ^PRCFSITE G EQ:'$D(PRC("SITE"))
S DIC("A")="Select CMR: ",DIC(0)="AEQZ",DIC="^ENG(6914.1," D ^DIC G EQ:Y<1
S PRCN("CMR")=$P(Y(0),U),PRCNCMR=+Y,PRCNSRV=$P(Y(0),U,5)
S PRCNRSP=$P(Y(0),U,2) I PRCNRSP="" W !!,"This CMR has no responsible official",$C(7) G EN
I PRCNSRV="" D G EQ:Y<1
. S DIC="^DIC(49," D ^DIC S PRCNSRV=+Y
K DIC,Y,PRCNRSP
; Build next sequential number (PRCNDA) from site, CMR, fiscal year
S TST=PRC("SITE")_"-"_PRCN("CMR")_"-"_PRC("FY") D SEQ^PRCNUTL
S PRCNTRN=TST_"-"_$E("00000",$L(PRCNDA)+1,5)_PRCNDA,X=PRCNTRN
S DIC="^PRCN(413,",DIC(0)="L",DLAYGO=413 D FILE^DICN S (DA,PRCNRDA)=+Y
W !!,"This Request has been assigned Transaction #: ",PRCNTRN,!
; Set defaulted information into file for this transaction
S DIE=413,DIE("NO^")="OUTOK",DR="[PRCNEDIT]",NEW=1 D ^DIE
I $G(PRCNTY)="" S DIK="^PRCN(413," D ^DIK G EQ
I PRCNTY="R" D
. I $G(TDA)="" S TDA=$P(^PRCN(413,DA,0),U,11)
. I $G(PRCNTDA)="" S PRCNTDA=TDA
. Q:$O(^PRCN(413.1,PRCNTDA,1,0))=""
. S EDIT=2,DIE=413.1,DR="[PRCNTIRQ]",DA=PRCNTDA D ^DIE
EQ K C,D,NEW,PRC,PRCN,PRCNCMR,PRCNDA,PRCNSRV,PRCNTRN,PRCNTY,TST,DIWF,HL0
K D0,DA,DIC,DIE,DLAYGO,DR,PRCNRDA,PRCNTDA,PRCF,PRCNDTM,I,LL,PL,PRCNQT
K PRCNTXT,PRCNCT,PRCNPJT,J,D1,PRCNRTN,PRCNTYP,RDA,RDI,TDA
K PRCNTDA,EDIT,PFL,QTY
Q
REP ; Build replacement entries for Turn-In request
S RDA=D0,RDI=D1,NUM=0
S QTY=$P(^PRCN(413,RDA,1,RDI,0),U,5),PRCNTYP=$P(^(0),U,12)
S NM=$P($G(^PRCN(413.1,TDA,1,0)),U,3)
I QTY>1 W !!,"A replacement item must be entered for each quantity requested.",!
I $G(PRCNCMR)="" S PRCNCMR=$P(^PRCN(413,RDA,0),U,16)
I NM="" S ^PRCN(413.1,TDA,1,0)="^413.11IPA^^"
RP2 S NM=NM+1,NUM=NUM+1
G RPX:NUM>QTY
S RQ=RDI,$P(^PRCN(413.1,TDA,1,0),U,3,4)=NM_U_NM
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
D GNX Q:$G(DUOUT)=1
G RP2
GNX W !!,"Select the Replacement Item to correspond with Line Item # "_RQ_" Quantity: "_NUM
S DIC("A")="Select REPLACEMENT ITEM: ",DIC="^ENG(6914,",DIC(0)="AEMQZ"
S DIC("S")="I $P($G(^(2)),U,9)=PRCNCMR"
GID D ^DIC I Y<1&(PRCNTYP="C") Q
Q:$G(DUOUT)=1
I Y<1&(PRCNTYP="P") W !,$C(7),"You MUST select the Item that is being replaced for a Parent!" G GNX
S RI=+Y,RIDSC=$P(Y(0),U,2) D DISP^PRCNTIRQ K DIC("S")
I $D(^PRCN(413.1,"AB",RI)) W $C(7),!!,"This ITEM "_RIDSC_" already has a request on file!" K RI G GNX
K ^UTILITY($J,"W") S DIWR=70,DIWL=1,DIWF=""
S X="Are you sure that "_RIDSC_" is the correct item being replaced by requested item, " D ^DIWP
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
F I=1:1:^UTILITY($J,"W",DIWL) W !,^UTILITY($J,"W",DIWL,I,0)
G1 W " " D YN^DICN I %=0 W !,"Enter 'Yes' to match the replacement item with item being requested." G G1
I %=2 K RI,X,RIDSC G GID
I %<0 Q
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
S DA(1)=TDA,DA=NM,DIC="^PRCN(413.1,"_DA(1)_",1,",DIE("NO^")=""
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
K DR,DIE("NO^") Q
RPX K QTY,NM,RQ,NUM,DR,DOV
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCNREQN 3352 printed Oct 16, 2024@17:55:22 Page 2
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
EN DO NOW^%DTC
SET PRCNDTM=%
KILL %I,%H
+1 DO FYQ^PRCNUTL
SET PRCF("X")="S"
SET PRC("MDIV")=1
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
GOTO EQ
+2 SET DIC("A")="Select CMR: "
SET DIC(0)="AEQZ"
SET DIC="^ENG(6914.1,"
DO ^DIC
if Y<1
GOTO EQ
+3 SET PRCN("CMR")=$PIECE(Y(0),U)
SET PRCNCMR=+Y
SET PRCNSRV=$PIECE(Y(0),U,5)
+4 SET PRCNRSP=$PIECE(Y(0),U,2)
IF PRCNRSP=""
WRITE !!,"This CMR has no responsible official",$CHAR(7)
GOTO EN
+5 IF PRCNSRV=""
Begin DoDot:1
+6 SET DIC="^DIC(49,"
DO ^DIC
SET PRCNSRV=+Y
End DoDot:1
if Y<1
GOTO EQ
+7 KILL DIC,Y,PRCNRSP
+8 ; Build next sequential number (PRCNDA) from site, CMR, fiscal year
+9 SET TST=PRC("SITE")_"-"_PRCN("CMR")_"-"_PRC("FY")
DO SEQ^PRCNUTL
+10 SET PRCNTRN=TST_"-"_$EXTRACT("00000",$LENGTH(PRCNDA)+1,5)_PRCNDA
SET X=PRCNTRN
+11 SET DIC="^PRCN(413,"
SET DIC(0)="L"
SET DLAYGO=413
DO FILE^DICN
SET (DA,PRCNRDA)=+Y
+12 WRITE !!,"This Request has been assigned Transaction #: ",PRCNTRN,!
+13 ; Set defaulted information into file for this transaction
+14 SET DIE=413
SET DIE("NO^")="OUTOK"
SET DR="[PRCNEDIT]"
SET NEW=1
DO ^DIE
+15 IF $GET(PRCNTY)=""
SET DIK="^PRCN(413,"
DO ^DIK
GOTO EQ
+16 IF PRCNTY="R"
Begin DoDot:1
+17 IF $GET(TDA)=""
SET TDA=$PIECE(^PRCN(413,DA,0),U,11)
+18 IF $GET(PRCNTDA)=""
SET PRCNTDA=TDA
+19 if $ORDER(^PRCN(413.1,PRCNTDA,1,0))=""
QUIT
+20 SET EDIT=2
SET DIE=413.1
SET DR="[PRCNTIRQ]"
SET DA=PRCNTDA
DO ^DIE
End DoDot:1
EQ KILL C,D,NEW,PRC,PRCN,PRCNCMR,PRCNDA,PRCNSRV,PRCNTRN,PRCNTY,TST,DIWF,HL0
+1 KILL D0,DA,DIC,DIE,DLAYGO,DR,PRCNRDA,PRCNTDA,PRCF,PRCNDTM,I,LL,PL,PRCNQT
+2 KILL PRCNTXT,PRCNCT,PRCNPJT,J,D1,PRCNRTN,PRCNTYP,RDA,RDI,TDA
+3 KILL PRCNTDA,EDIT,PFL,QTY
+4 QUIT
REP ; Build replacement entries for Turn-In request
+1 SET RDA=D0
SET RDI=D1
SET NUM=0
+2 SET QTY=$PIECE(^PRCN(413,RDA,1,RDI,0),U,5)
SET PRCNTYP=$PIECE(^(0),U,12)
+3 SET NM=$PIECE($GET(^PRCN(413.1,TDA,1,0)),U,3)
+4 IF QTY>1
WRITE !!,"A replacement item must be entered for each quantity requested.",!
+5 IF $GET(PRCNCMR)=""
SET PRCNCMR=$PIECE(^PRCN(413,RDA,0),U,16)
+6 IF NM=""
SET ^PRCN(413.1,TDA,1,0)="^413.11IPA^^"
RP2 SET NM=NM+1
SET NUM=NUM+1
+1 if NUM>QTY
GOTO RPX
+2 SET RQ=RDI
SET $PIECE(^PRCN(413.1,TDA,1,0),U,3,4)=NM_U_NM
+3 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
+4 DO GNX
if $GET(DUOUT)=1
QUIT
+5 GOTO RP2
GNX WRITE !!,"Select the Replacement Item to correspond with Line Item # "_RQ_" Quantity: "_NUM
+1 SET DIC("A")="Select REPLACEMENT ITEM: "
SET DIC="^ENG(6914,"
SET DIC(0)="AEMQZ"
+2 SET DIC("S")="I $P($G(^(2)),U,9)=PRCNCMR"
GID DO ^DIC
IF Y<1&(PRCNTYP="C")
QUIT
+1 if $GET(DUOUT)=1
QUIT
+2 IF Y<1&(PRCNTYP="P")
WRITE !,$CHAR(7),"You MUST select the Item that is being replaced for a Parent!"
GOTO GNX
+3 SET RI=+Y
SET RIDSC=$PIECE(Y(0),U,2)
DO DISP^PRCNTIRQ
KILL DIC("S")
+4 IF $DATA(^PRCN(413.1,"AB",RI))
WRITE $CHAR(7),!!,"This ITEM "_RIDSC_" already has a request on file!"
KILL RI
GOTO GNX
+5 KILL ^UTILITY($JOB,"W")
SET DIWR=70
SET DIWL=1
SET DIWF=""
+6 SET X="Are you sure that "_RIDSC_" is the correct item being replaced by requested item, "
DO ^DIWP
+7 SET RQD=0
FOR
SET RQD=$ORDER(^PRCN(413,RDA,1,RQ,1,RQD))
if RQD'>0
QUIT
SET X=^PRCN(413,RDA,1,RQ,1,RQD,0)
DO ^DIWP
+8 FOR I=1:1:^UTILITY($JOB,"W",DIWL)
WRITE !,^UTILITY($JOB,"W",DIWL,I,0)
G1 WRITE " "
DO YN^DICN
IF %=0
WRITE !,"Enter 'Yes' to match the replacement item with item being requested."
GOTO G1
+1 IF %=2
KILL RI,X,RIDSC
GOTO GID
+2 IF %<0
QUIT
+3 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
+4 SET DA(1)=TDA
SET DA=NM
SET DIC="^PRCN(413.1,"_DA(1)_",1,"
SET DIE("NO^")=""
+5 SET DR=".01///^S X=RI;2///^S X=RDI;3///^S X=RIDSC;.5Replacement Justification~;I X'=6 S Y="""";.7"
SET DIE=DIC
DO ^DIE
+6 KILL DR,DIE("NO^")
QUIT
RPX KILL QTY,NM,RQ,NUM,DR,DOV
+1 QUIT
