| [623] | 1 | PRCSRIG1 ;WISC/SAW/KMB/LJP/SC-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ;3-3-93/14:30 ; 3/31/05 3:48pm
|
|---|
| 2 | V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;PRC*5.1*81, RIL that originated thru DynaMed is NOT allowed to be
|
|---|
| 6 | ;RE-USED for generating 2237(s),hence removed this prompt for DM
|
|---|
| 7 | ;trxs. only.
|
|---|
| 8 | ;
|
|---|
| 9 | U IO S PRCSNO=$P(^PRCS(410.3,PRCSRID0,0),"^"),PRC("SITE")=+PRCSNO,PRC("CP")=$S($D(^PRC(420,PRC("SITE"),1,+$P(PRCSNO,"-",4),0)):$P(^(0),"^"),1:"")
|
|---|
| 10 | I PRC("CP")="" W !!,"Control Point ",$P(PRCSNO,"-",4),"no longer exists. You will have to transfer",!,"this repetitive item list to an existing control point before you can continue." K PRC("CP") G EXIT
|
|---|
| 11 | ;Create transaction number
|
|---|
| 12 | D:'$D(DT) DT^DICRW S PRCSTIME=$E(DT,4,5),PRCSQUAR=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",PRCSTIME)
|
|---|
| 13 | S:PQTR=1 PRCSQUAR=$P(PRCSNO,"-",3)
|
|---|
| 14 | S Z1=$P(PRCSNO,"-")_"-"_PRC("FY")_"-"_PRCSQUAR_"-"_$P(PRCSNO,"-",4)
|
|---|
| 15 | S Z2=$P(Z1,"-",1,2)_"-"_$P(Z1,"-",4)
|
|---|
| 16 | S PRCSCC=$P(PRCSNO,"-",5),PRCSCC=$S($D(^PRCD(420.1,+PRCSCC,0)):$E($P(^(0),"^"),1,30),1:PRCSCC) S:PRCSCC="NONE" PRCSCC="" S X="N",%DT="T" D ^%DT S PRCSD1=$P(Y,".") X ^DD("DD") S PRCSD=Y,X="T+30" D ^%DT S PRCSD(1)=Y
|
|---|
| 17 | ;
|
|---|
| 18 | ;See NOIS MON-0399-51726
|
|---|
| 19 | KILL ^TMP($J)
|
|---|
| 20 | S IB=0
|
|---|
| 21 | F S IB=$O(^PRCS(410.3,PRCSRID0,1,IB)) Q:'IB D ;
|
|---|
| 22 | . S FF=$G(^PRCS(410.3,PRCSRID0,1,IB,0))
|
|---|
| 23 | . S ^TMP($J,410.3,PRCSRID0,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),IB)=""
|
|---|
| 24 | ;
|
|---|
| 25 | ; Loop thru RIL entry numbers. PRCSV1 is the vendor for
|
|---|
| 26 | ;the item, from the Rep. Item List. Starting here, loop
|
|---|
| 27 | ;thru the vendor to get the items ordered from that vendor,
|
|---|
| 28 | ;using PRCSRI for the item.
|
|---|
| 29 | S (PRCSV1,PRCSTC)="",(PRCSCT,PRCSCT(1),PRCSIT,BFLAG)=0
|
|---|
| 30 | F PRCSRIJ=0:1 S PRCSV1=$O(^TMP($J,410.3,PRCSRID0,1,"AC",PRCSV1)) Q:PRCSV1=""!(BFLAG=1) S PRCSCT=PRCSCT+1,PRCSCT(1)=PRCSCT(1)+1 D:'PRCSRIJ HDRG D ITEMG^PRCSRIG2
|
|---|
| 31 | I 'PRCSRIJ W !,"Items have not yet been entered for Repetitive Item List # ",PRCSNO G CLS
|
|---|
| 32 | D:IOSL-$Y<3 HOLD,HDRG W !!,"Total no. of requests generated: ",PRCSCT," Total no. of items (all requests): ",PRCSIT,!,"Total committed (estimated) cost (all requests) : ","$"_$J(PRCSTC,0,2)
|
|---|
| 33 | SV ;
|
|---|
| 34 | I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC
|
|---|
| 35 | G EXIT:$D(ZTQUEUED)
|
|---|
| 36 | ;patch *81 -DynaMed trx. is not allowed to be re-used
|
|---|
| 37 | N PRCVSY,PRCVID
|
|---|
| 38 | S PRCVSY=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
|
|---|
| 39 | I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0)
|
|---|
| 40 | I PRCVSY=1,PRCVID=1 G CHK1
|
|---|
| 41 | U IO(0) S %=2 W !,"Do you wish to re-use this list " D YN^DICN G:%=1 JMP G:%=0 SV
|
|---|
| 42 | CHK1 I PRCSCT=PRCSCT(1) S DIK="^PRCS(410.3,",DA=PRCSRID0 D ^DIK G CLS
|
|---|
| 43 | JMP D RLR^PRCSUT1
|
|---|
| 44 | S $P(^PRCS(410.3,PRCSRID0,0),U,5)="",DIK="^PRCS(410.3,",DA=PRCSRID0 D IX^DIK
|
|---|
| 45 | CLS ;
|
|---|
| 46 | D:$D(ZTSK) KILL^%ZTLOAD G EXIT
|
|---|
| 47 | ;
|
|---|
| 48 | HDRG W @IOF,"GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE",?55,"DATE: ",PRCSD,!,"Requests Generated From Repetitive Item List Entry # ",PRCSNO,! S L="",$P(L,"-",IOM)="-" W L S L=""
|
|---|
| 49 | Q
|
|---|
| 50 | ;
|
|---|
| 51 | HOLD Q:IO'=IO(0)!($D(ZTQUEUED)) W !,"Press return to continue: " R Z(1):DTIME Q
|
|---|
| 52 | ASK S %=2 W !,"Do you wish to edit this request" D YN^DICN D ASK:%=0 G:%=2 EN1 Q:%'=1
|
|---|
| 53 | EN W ! K DTOUT,DUOUT,Y S DIE="^PRCS(410,",(PRCSDR,DR)="[PRCSENPR]",T1=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=T1 Q
|
|---|
| 54 | S DA=T1 D RL^PRCSUT1,^PRCSCK I $D(PRCSERR),PRCSERR G EN
|
|---|
| 55 | EN1 W ! D W6^PRCSEB Q
|
|---|
| 56 | ;*****************************************************************
|
|---|
| 57 | ; PRCSRID0 represents the ien of the record in file 410.3
|
|---|
| 58 | ; patch *81 --itdmid removes Re-use Ques for DM related RIL
|
|---|
| 59 | ;*****************************************************************
|
|---|
| 60 | ITDMID(PRCSRID0) ; check DynaMed DOC ID existence for an item
|
|---|
| 61 | ;N PRCVA,PRCVB,PRCVFLG
|
|---|
| 62 | ;S PRCVA=0
|
|---|
| 63 | ;S PRCVFLG=0 ; 0 means that there is no DM ID on a item
|
|---|
| 64 | ;S PRCVA=$O(^PRCS(410.3,PRCSRID0,1,PRCVA)) D
|
|---|
| 65 | ;.Q:+$G(PRCVA)'>0
|
|---|
| 66 | ;.S PRCVB=$$GET1^DIQ(410.31,PRCVA_","_PRCSRID0_",",6) ; DM doc id
|
|---|
| 67 | ;.I PRCVB'="" S PRCVFLG=1 Q
|
|---|
| 68 | ;Q PRCVFLG
|
|---|
| 69 | ;
|
|---|
| 70 | ;Remove the prompt if entry is set in 414.02 Audit File 'C' x-ref
|
|---|
| 71 | N PRCVFLG,PRCVL,PRCVM
|
|---|
| 72 | S PRCVM=$$GET1^DIQ(410.3,PRCSRID0_",",.01) ; ext value of RIL trx
|
|---|
| 73 | S PRCVL=""
|
|---|
| 74 | S PRCVFLG=0
|
|---|
| 75 | S PRCVL=$O(^PRCV(414.02,"C",PRCVM,PRCVL))
|
|---|
| 76 | I PRCVL'="" S PRCVFLG=1 Q 1
|
|---|
| 77 | Q PRCVFLG
|
|---|
| 78 | ;
|
|---|
| 79 | ;
|
|---|
| 80 | EXIT K %,%DT,%ZIS,PRCSRID0,DA,DIC,DIE,DIK,PRCSRIJ,K,L,PRCSRIM,PRCS,PRCSCS
|
|---|
| 81 | K PRCSCT,PRCSCC,PRCSD,PRCSD1,PRCSRI,PRCSIT,PRCSL,PRCSNO,PRCSS,PRCSTC
|
|---|
| 82 | K PRCSV1,PX,T1,X,X1,X2,Y,Z,Z1,Z2
|
|---|
| 83 | K PRCSTIME,PRCSQUAR,^TMP($J) Q
|
|---|
