- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m
r613 r623 1 PRCSRIG1 2 V ;;5.1;IFCAP;**13,81,101,110**;Oct 20, 2000;Build 73 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 SV 34 35 ;patch *81 -DynaMed trx. is not allowed to be re-used 36 N PRCVSY,PRCVID 37 S PRCVSY=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") 38 I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0)39 I PRCVSY=1,PRCVID=1 G CHK1 40 G EXIT:$D(ZTQUEUED) 41 42 CHK1 43 JMP 44 45 CLS 46 47 48 HDRG 49 50 51 HOLD 52 ASK 53 EN 54 55 EN1 56 57 58 59 60 ITDMID(PRCSRID0) 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 EXIT 81 82 83 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
Note:
See TracChangeset
for help on using the changeset viewer.
