- PRCHQ2 ;(WASH IRMFO)/LKG-RFQ Enter/Edit ;9/8/96 13:01
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN ;Entry point for editing Incomplete RFQ
- S PRCEDIT=$$EDITOR^PRCHQ1C
- I PRCEDIT="" D EN^DDIOL("Edit mode not indicated, aborting the edit.") K PRCEDIT Q
- A S DIC="^PRC(444,",DIC(0)="AEMQ",DIC("S")="I "";1;""[("";""_$P(^(0),U,8)_"";"")"
- S DIC("A")="Enter '^' to Exit or existing RFQ #: "
- S D="F^D" D MIX^DIC1 K DIC
- I Y<1!$D(DTOUT)!$D(DUOUT) G OUT^PRCHQ2B
- S PRCDA=+Y
- L +^PRC(444,PRCDA):5 E W !,"Someone else is editing this entry, please try later!" G OUT^PRCHQ2B
- G CONT^PRCHQ2B
- EN2 ;Entry point for generating a new RFQ
- S PRCEDIT=$$EDITOR^PRCHQ1C
- I PRCEDIT="" D EN^DDIOL("Edit mode not indicated, aborting the edit.") K PRCEDIT Q
- B S PRCNEW=1
- S DIC="^PRC(443,",DIC(0)="AEMNZ"
- S DIC("S")="I "";70;80;""[("";""_$P(^(0),U,7)_"";""),$P($G(^PRCS(410,Y,4)),U,5)="""""
- S DIC("A")="Enter Primary 2237 Transaction #: "
- D ^DIC K DIC I Y<1!$D(DTOUT)!$D(DUOUT) G OUT^PRCHQ2B
- S PRCDA410=+Y
- L +^PRC(443,PRCDA410):5 E W !,"Work Sheet entry in use, please try later!" G OUT^PRCHQ2B
- L +^PRCS(410,PRCDA410):5 E W !,"Someone is editing the source 2237, please try later!" G OUT^PRCHQ2B
- S X=$$GETNUM($P(Y(0,0),"-",1,2)) G:'X OUT^PRCHQ2B
- S DIC="^PRC(444,",DIC(0)="XL",DLAYGO=444 D ^DIC K DIC,DLAYGO
- I +Y<1 W !,"Unable to add RFQ entry - Please notify IRM staff." G OUT^PRCHQ2B
- S PRCDA=+Y W:$P(Y,U,3) !,"RFQ # ",$P(Y,U,2)," has been added."
- L +^PRC(444,PRCDA):5 E W !,"Someone else is editing this RFQ entry, please try later!" G OUT^PRCHQ2B
- I '$P(Y,U,3) G CONT^PRCHQ2B
- W !,"Importing 2237 information into the RFQ entry..."
- K PRC410,PRC443
- F I=0,1,2,3,7,9 S PRC410(I)=$G(^PRCS(410,PRCDA410,I))
- S PRC443(0)=$G(^PRC(443,PRCDA410,0))
- S PRCE(0)=^PRC(444,PRCDA,0)
- S $P(PRCE(0),U,8)=1
- S PRCX=$P(PRC443(0),U,5) S:PRCX]"" $P(PRCE(0),U,4)=PRCX
- S PRCX=$P(PRC410(1),U,3) S:PRCX]"" $P(PRCE(0),U,6)=PRCX
- S $P(PRCE(0),U,9)=PRCDA410
- S PRCX=$P(PRC410(0),U,10) S:PRCX]"" $P(PRCE(0),U,10)=PRCX
- S PRCX=$P(PRC410(3),U,5) S:PRCX]"" $P(PRCE(0),U,11)=PRCX
- S PRCX=$P(PRC410(7),U) S:PRCX]"" $P(PRCE(0),U,12)=PRCX
- S PRCX=$P(PRC410(3),U) S:PRCX]"" $P(PRCE(0),U,14)=PRCX
- S PRCY=$P(PRC410(7),U)
- I PRCY?1.N D
- . K ^UTILITY("DIQ1",$J)
- . N DA,DIC,DIQ,DR,PRCZ
- . S DA=PRCY,DIC=200,DIQ="PRCZ",DR=".132;.135" D EN^DIQ1
- . S PRCX=$S(PRCZ(200,DA,.132)]"":PRCZ(200,DA,.132),1:PRCZ(200,DA,.135))
- . S:PRCX]"" $P(PRCE(0),U,13)=PRCX K ^UTILITY("DIQ1",$J)
- S ^PRC(444,PRCDA,0)=PRCE(0) K PRCE(0)
- S PRCE(1)=$G(^PRC(444,PRCDA,1))
- S PRCX=$P(PRC410(9),U,4),$P(PRCE(1),U)=$S(+PRCX>0:"O",1:"D")
- S PRCX=$P(PRC410(1),U,4) S:PRCX]"" $P(PRCE(1),U,2)=PRCX
- S PRCX=$P(PRC410(9),U) S:PRCX]"" $P(PRCE(1),U,4)=PRCX
- S ^PRC(444,PRCDA,1)=PRCE(1) K PRCE(1)
- K PRC443,PRC410(0),PRC410(1),PRC410(7),PRC410(9)
- S PRCI=0,PRCJ=0
- F S PRCI=$O(^PRCS(410,PRCDA410,"RM",PRCI)) Q:PRCI="" D
- . S:$D(^PRCS(410,PRCDA410,"RM",PRCI,0)) PRCJ=PRCJ+1,^PRC(444,PRCDA,3,PRCJ,0)=^(0)
- S:PRCJ>0 ^PRC(444,PRCDA,3,0)="^^"_PRCJ_U_PRCJ_U_DT_"^^^^"
- D IT^PRCHQ2A
- G ^PRCHQ2B
- HERE ;
- GETNUM(PRCX) ;Get new RFQ #
- N PRCFAIL,PRCI,X,DIC,Y,DA,DLAYGO
- S X=PRCX,DIC=444.3,DIC(0)="LX",DLAYGO=444.3 D ^DIC
- I +Y<1 W !,"Unable to get RFQ counter value - Please notify IRM staff." Q 0
- S DA=+Y,PRCFAIL=0
- F PRCI=1:1:10 L +^PRC(444.3,DA):5 Q:$T W !,"Someone else has the RFQ counter locked!" W:PRCI<10 !,?5,"I will try again!" S:PRCI=10 PRCFAIL=1
- Q:PRCFAIL 0
- UPCNTR S X=$P(^PRC(444.3,DA,0),U,2)+1,$P(^PRC(444.3,DA,0),U,2)=X
- S X=PRCX_"-RFQ-"_$E(100000+X,2,6) G:$D(^PRC(444,"B",X)) UPCNTR
- L -^PRC(444.3,DA)
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQ2 3663 printed Dec 13, 2024@02:09:41 Page 2
- PRCHQ2 ;(WASH IRMFO)/LKG-RFQ Enter/Edit ;9/8/96 13:01
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN ;Entry point for editing Incomplete RFQ
- +1 SET PRCEDIT=$$EDITOR^PRCHQ1C
- +2 IF PRCEDIT=""
- DO EN^DDIOL("Edit mode not indicated, aborting the edit.")
- KILL PRCEDIT
- QUIT
- A SET DIC="^PRC(444,"
- SET DIC(0)="AEMQ"
- SET DIC("S")="I "";1;""[("";""_$P(^(0),U,8)_"";"")"
- +1 SET DIC("A")="Enter '^' to Exit or existing RFQ #: "
- +2 SET D="F^D"
- DO MIX^DIC1
- KILL DIC
- +3 IF Y<1!$DATA(DTOUT)!$DATA(DUOUT)
- GOTO OUT^PRCHQ2B
- +4 SET PRCDA=+Y
- +5 LOCK +^PRC(444,PRCDA):5
- IF '$TEST
- WRITE !,"Someone else is editing this entry, please try later!"
- GOTO OUT^PRCHQ2B
- +6 GOTO CONT^PRCHQ2B
- EN2 ;Entry point for generating a new RFQ
- +1 SET PRCEDIT=$$EDITOR^PRCHQ1C
- +2 IF PRCEDIT=""
- DO EN^DDIOL("Edit mode not indicated, aborting the edit.")
- KILL PRCEDIT
- QUIT
- B SET PRCNEW=1
- +1 SET DIC="^PRC(443,"
- SET DIC(0)="AEMNZ"
- +2 SET DIC("S")="I "";70;80;""[("";""_$P(^(0),U,7)_"";""),$P($G(^PRCS(410,Y,4)),U,5)="""""
- +3 SET DIC("A")="Enter Primary 2237 Transaction #: "
- +4 DO ^DIC
- KILL DIC
- IF Y<1!$DATA(DTOUT)!$DATA(DUOUT)
- GOTO OUT^PRCHQ2B
- +5 SET PRCDA410=+Y
- +6 LOCK +^PRC(443,PRCDA410):5
- IF '$TEST
- WRITE !,"Work Sheet entry in use, please try later!"
- GOTO OUT^PRCHQ2B
- +7 LOCK +^PRCS(410,PRCDA410):5
- IF '$TEST
- WRITE !,"Someone is editing the source 2237, please try later!"
- GOTO OUT^PRCHQ2B
- +8 SET X=$$GETNUM($PIECE(Y(0,0),"-",1,2))
- if 'X
- GOTO OUT^PRCHQ2B
- +9 SET DIC="^PRC(444,"
- SET DIC(0)="XL"
- SET DLAYGO=444
- DO ^DIC
- KILL DIC,DLAYGO
- +10 IF +Y<1
- WRITE !,"Unable to add RFQ entry - Please notify IRM staff."
- GOTO OUT^PRCHQ2B
- +11 SET PRCDA=+Y
- if $PIECE(Y,U,3)
- WRITE !,"RFQ # ",$PIECE(Y,U,2)," has been added."
- +12 LOCK +^PRC(444,PRCDA):5
- IF '$TEST
- WRITE !,"Someone else is editing this RFQ entry, please try later!"
- GOTO OUT^PRCHQ2B
- +13 IF '$PIECE(Y,U,3)
- GOTO CONT^PRCHQ2B
- +14 WRITE !,"Importing 2237 information into the RFQ entry..."
- +15 KILL PRC410,PRC443
- +16 FOR I=0,1,2,3,7,9
- SET PRC410(I)=$GET(^PRCS(410,PRCDA410,I))
- +17 SET PRC443(0)=$GET(^PRC(443,PRCDA410,0))
- +18 SET PRCE(0)=^PRC(444,PRCDA,0)
- +19 SET $PIECE(PRCE(0),U,8)=1
- +20 SET PRCX=$PIECE(PRC443(0),U,5)
- if PRCX]""
- SET $PIECE(PRCE(0),U,4)=PRCX
- +21 SET PRCX=$PIECE(PRC410(1),U,3)
- if PRCX]""
- SET $PIECE(PRCE(0),U,6)=PRCX
- +22 SET $PIECE(PRCE(0),U,9)=PRCDA410
- +23 SET PRCX=$PIECE(PRC410(0),U,10)
- if PRCX]""
- SET $PIECE(PRCE(0),U,10)=PRCX
- +24 SET PRCX=$PIECE(PRC410(3),U,5)
- if PRCX]""
- SET $PIECE(PRCE(0),U,11)=PRCX
- +25 SET PRCX=$PIECE(PRC410(7),U)
- if PRCX]""
- SET $PIECE(PRCE(0),U,12)=PRCX
- +26 SET PRCX=$PIECE(PRC410(3),U)
- if PRCX]""
- SET $PIECE(PRCE(0),U,14)=PRCX
- +27 SET PRCY=$PIECE(PRC410(7),U)
- +28 IF PRCY?1.N
- Begin DoDot:1
- +29 KILL ^UTILITY("DIQ1",$JOB)
- +30 NEW DA,DIC,DIQ,DR,PRCZ
- +31 SET DA=PRCY
- SET DIC=200
- SET DIQ="PRCZ"
- SET DR=".132;.135"
- DO EN^DIQ1
- +32 SET PRCX=$SELECT(PRCZ(200,DA,.132)]"":PRCZ(200,DA,.132),1:PRCZ(200,DA,.135))
- +33 if PRCX]""
- SET $PIECE(PRCE(0),U,13)=PRCX
- KILL ^UTILITY("DIQ1",$JOB)
- End DoDot:1
- +34 SET ^PRC(444,PRCDA,0)=PRCE(0)
- KILL PRCE(0)
- +35 SET PRCE(1)=$GET(^PRC(444,PRCDA,1))
- +36 SET PRCX=$PIECE(PRC410(9),U,4)
- SET $PIECE(PRCE(1),U)=$SELECT(+PRCX>0:"O",1:"D")
- +37 SET PRCX=$PIECE(PRC410(1),U,4)
- if PRCX]""
- SET $PIECE(PRCE(1),U,2)=PRCX
- +38 SET PRCX=$PIECE(PRC410(9),U)
- if PRCX]""
- SET $PIECE(PRCE(1),U,4)=PRCX
- +39 SET ^PRC(444,PRCDA,1)=PRCE(1)
- KILL PRCE(1)
- +40 KILL PRC443,PRC410(0),PRC410(1),PRC410(7),PRC410(9)
- +41 SET PRCI=0
- SET PRCJ=0
- +42 FOR
- SET PRCI=$ORDER(^PRCS(410,PRCDA410,"RM",PRCI))
- if PRCI=""
- QUIT
- Begin DoDot:1
- +43 if $DATA(^PRCS(410,PRCDA410,"RM",PRCI,0))
- SET PRCJ=PRCJ+1
- SET ^PRC(444,PRCDA,3,PRCJ,0)=^(0)
- End DoDot:1
- +44 if PRCJ>0
- SET ^PRC(444,PRCDA,3,0)="^^"_PRCJ_U_PRCJ_U_DT_"^^^^"
- +45 DO IT^PRCHQ2A
- +46 GOTO ^PRCHQ2B
- HERE ;
- GETNUM(PRCX) ;Get new RFQ #
- +1 NEW PRCFAIL,PRCI,X,DIC,Y,DA,DLAYGO
- +2 SET X=PRCX
- SET DIC=444.3
- SET DIC(0)="LX"
- SET DLAYGO=444.3
- DO ^DIC
- +3 IF +Y<1
- WRITE !,"Unable to get RFQ counter value - Please notify IRM staff."
- QUIT 0
- +4 SET DA=+Y
- SET PRCFAIL=0
- +5 FOR PRCI=1:1:10
- LOCK +^PRC(444.3,DA):5
- if $TEST
- QUIT
- WRITE !,"Someone else has the RFQ counter locked!"
- if PRCI<10
- WRITE !,?5,"I will try again!"
- if PRCI=10
- SET PRCFAIL=1
- +6 if PRCFAIL
- QUIT 0
- UPCNTR SET X=$PIECE(^PRC(444.3,DA,0),U,2)+1
- SET $PIECE(^PRC(444.3,DA,0),U,2)=X
- +1 SET X=PRCX_"-RFQ-"_$EXTRACT(100000+X,2,6)
- if $DATA(^PRC(444,"B",X))
- GOTO UPCNTR
- +2 LOCK -^PRC(444.3,DA)
- +3 QUIT X