- 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 Jan 18, 2025@02:55:46 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