- 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
- V ;;5.1;IFCAP;**13,81,101,110**;Oct 20, 2000;Build 7
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;PRC*5.1*81, RIL that originated thru DynaMed is NOT allowed to be
- ;RE-USED for generating 2237(s),hence removed this prompt for DM
- ;trxs. only.
- ;
- 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:"")
- 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
- ;Create transaction number
- 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)
- S:PQTR=1 PRCSQUAR=$P(PRCSNO,"-",3)
- S Z1=$P(PRCSNO,"-")_"-"_PRC("FY")_"-"_PRCSQUAR_"-"_$P(PRCSNO,"-",4)
- S Z2=$P(Z1,"-",1,2)_"-"_$P(Z1,"-",4)
- 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
- ;
- ;See NOIS MON-0399-51726
- KILL ^TMP($J)
- S IB=0
- F S IB=$O(^PRCS(410.3,PRCSRID0,1,IB)) Q:'IB D ;
- . S FF=$G(^PRCS(410.3,PRCSRID0,1,IB,0))
- . S ^TMP($J,410.3,PRCSRID0,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),IB)=""
- ;
- ; Loop thru RIL entry numbers. PRCSV1 is the vendor for
- ;the item, from the Rep. Item List. Starting here, loop
- ;thru the vendor to get the items ordered from that vendor,
- ;using PRCSRI for the item.
- S (PRCSV1,PRCSTC)="",(PRCSCT,PRCSCT(1),PRCSIT,BFLAG)=0
- 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
- I 'PRCSRIJ W !,"Items have not yet been entered for Repetitive Item List # ",PRCSNO G CLS
- 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)
- SV ;
- I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC
- ;patch *81 -DynaMed trx. is not allowed to be re-used
- N PRCVSY,PRCVID
- S PRCVSY=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
- I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0)
- I PRCVSY=1,PRCVID=1 G CHK1
- G EXIT:$D(ZTQUEUED)
- U IO(0) S %=2 W !,"Do you wish to re-use this list " D YN^DICN G:%=1 JMP G:%=0 SV
- CHK1 I PRCSCT=PRCSCT(1) S DIK="^PRCS(410.3,",DA=PRCSRID0 D ^DIK G CLS
- JMP D RLR^PRCSUT1
- S $P(^PRCS(410.3,PRCSRID0,0),U,5)="",DIK="^PRCS(410.3,",DA=PRCSRID0 D IX^DIK
- CLS ;
- D:$D(ZTSK) KILL^%ZTLOAD G EXIT
- ;
- 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=""
- Q
- ;
- HOLD Q:IO'=IO(0)!($D(ZTQUEUED)) W !,"Press return to continue: " R Z(1):DTIME Q
- ASK S %=2 W !,"Do you wish to edit this request" D YN^DICN D ASK:%=0 G:%=2 EN1 Q:%'=1
- 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
- S DA=T1 D RL^PRCSUT1,^PRCSCK I $D(PRCSERR),PRCSERR G EN
- EN1 W ! D W6^PRCSEB Q
- ;*****************************************************************
- ; PRCSRID0 represents the ien of the record in file 410.3
- ; patch *81 --itdmid removes Re-use Ques for DM related RIL
- ;*****************************************************************
- ITDMID(PRCSRID0) ; check DynaMed DOC ID existence for an item
- ;N PRCVA,PRCVB,PRCVFLG
- ;S PRCVA=0
- ;S PRCVFLG=0 ; 0 means that there is no DM ID on a item
- ;S PRCVA=$O(^PRCS(410.3,PRCSRID0,1,PRCVA)) D
- ;.Q:+$G(PRCVA)'>0
- ;.S PRCVB=$$GET1^DIQ(410.31,PRCVA_","_PRCSRID0_",",6) ; DM doc id
- ;.I PRCVB'="" S PRCVFLG=1 Q
- ;Q PRCVFLG
- ;
- ;Remove the prompt if entry is set in 414.02 Audit File 'C' x-ref
- N PRCVFLG,PRCVL,PRCVM
- S PRCVM=$$GET1^DIQ(410.3,PRCSRID0_",",.01) ; ext value of RIL trx
- S PRCVL=""
- S PRCVFLG=0
- S PRCVL=$O(^PRCV(414.02,"C",PRCVM,PRCVL))
- I PRCVL'="" S PRCVFLG=1 Q 1
- Q PRCVFLG
- ;
- ;
- EXIT K %,%DT,%ZIS,PRCSRID0,DA,DIC,DIE,DIK,PRCSRIJ,K,L,PRCSRIM,PRCS,PRCSCS
- K PRCSCT,PRCSCC,PRCSD,PRCSD1,PRCSRI,PRCSIT,PRCSL,PRCSNO,PRCSS,PRCSTC
- K PRCSV1,PX,T1,X,X1,X2,Y,Z,Z1,Z2
- K PRCSTIME,PRCSQUAR,^TMP($J) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSRIG1 4401 printed Jan 18, 2025@03:19:39 Page 2
- 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
- V ;;5.1;IFCAP;**13,81,101,110**;Oct 20, 2000;Build 7
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;
- +3 ;PRC*5.1*81, RIL that originated thru DynaMed is NOT allowed to be
- +4 ;RE-USED for generating 2237(s),hence removed this prompt for DM
- +5 ;trxs. only.
- +6 ;
- +7 USE IO
- SET PRCSNO=$PIECE(^PRCS(410.3,PRCSRID0,0),"^")
- SET PRC("SITE")=+PRCSNO
- SET PRC("CP")=$SELECT($DATA(^PRC(420,PRC("SITE"),1,+$PIECE(PRCSNO,"-",4),0)):$PIECE(^(0),"^"),1:"")
- +8 IF PRC("CP")=""
- WRITE !!,"Control Point ",$PIECE(PRCSNO,"-",4),"no longer exists. You will have to transfer",!,"this repetitive item list to an existing control point before you can continue."
- KILL PRC("CP")
- GOTO EXIT
- +9 ;Create transaction number
- +10 if '$DATA(DT)
- DO DT^DICRW
- SET PRCSTIME=$EXTRACT(DT,4,5)
- SET PRCSQUAR=$PIECE("2^2^2^3^3^3^4^4^4^1^1^1","^",PRCSTIME)
- +11 if PQTR=1
- SET PRCSQUAR=$PIECE(PRCSNO,"-",3)
- +12 SET Z1=$PIECE(PRCSNO,"-")_"-"_PRC("FY")_"-"_PRCSQUAR_"-"_$PIECE(PRCSNO,"-",4)
- +13 SET Z2=$PIECE(Z1,"-",1,2)_"-"_$PIECE(Z1,"-",4)
- +14 SET PRCSCC=$PIECE(PRCSNO,"-",5)
- SET PRCSCC=$SELECT($DATA(^PRCD(420.1,+PRCSCC,0)):$EXTRACT($PIECE(^(0),"^"),1,30),1:PRCSCC)
- if PRCSCC="NONE"
- SET PRCSCC=""
- SET X="N"
- SET %DT="T"
- DO ^%DT
- SET PRCSD1=$PIECE(Y,".")
- XECUTE ^DD("DD")
- SET PRCSD=Y
- SET X="T+30"
- DO ^%DT
- SET PRCSD(1)=Y
- +15 ;
- +16 ;See NOIS MON-0399-51726
- +17 KILL ^TMP($JOB)
- +18 SET IB=0
- +19 ;
- FOR
- SET IB=$ORDER(^PRCS(410.3,PRCSRID0,1,IB))
- if 'IB
- QUIT
- Begin DoDot:1
- +20 SET FF=$GET(^PRCS(410.3,PRCSRID0,1,IB,0))
- +21 SET ^TMP($JOB,410.3,PRCSRID0,1,"AC",$PIECE(FF,"^",3)_";"_$PIECE(FF,"^",5),IB)=""
- End DoDot:1
- +22 ;
- +23 ; Loop thru RIL entry numbers. PRCSV1 is the vendor for
- +24 ;the item, from the Rep. Item List. Starting here, loop
- +25 ;thru the vendor to get the items ordered from that vendor,
- +26 ;using PRCSRI for the item.
- +27 SET (PRCSV1,PRCSTC)=""
- SET (PRCSCT,PRCSCT(1),PRCSIT,BFLAG)=0
- +28 FOR PRCSRIJ=0:1
- SET PRCSV1=$ORDER(^TMP($JOB,410.3,PRCSRID0,1,"AC",PRCSV1))
- if PRCSV1=""!(BFLAG=1)
- QUIT
- SET PRCSCT=PRCSCT+1
- SET PRCSCT(1)=PRCSCT(1)+1
- if 'PRCSRIJ
- DO HDRG
- DO ITEMG^PRCSRIG2
- +29 IF 'PRCSRIJ
- WRITE !,"Items have not yet been entered for Repetitive Item List # ",PRCSNO
- GOTO CLS
- +30 if IOSL-$Y<3
- DO HOLD
- DO HDRG
- WRITE !!,"Total no. of requests generated: ",PRCSCT," Total no. of items (all requests): ",PRCSIT,!,"Total committed (estimated) cost (all requests) : ","$"_$JUSTIFY(PRCSTC,0,2)
- SV ;
- +1 IF (IO'=IO(0))!($DATA(ZTQUEUED))
- DO ^%ZISC
- +2 ;patch *81 -DynaMed trx. is not allowed to be re-used
- +3 NEW PRCVSY,PRCVID
- +4 SET PRCVSY=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
- +5 IF PRCVSY=1
- SET PRCVID=$$ITDMID(PRCSRID0)
- +6 IF PRCVSY=1
- IF PRCVID=1
- GOTO CHK1
- +7 if $DATA(ZTQUEUED)
- GOTO EXIT
- +8 USE IO(0)
- SET %=2
- WRITE !,"Do you wish to re-use this list "
- DO YN^DICN
- if %=1
- GOTO JMP
- if %=0
- GOTO SV
- CHK1 IF PRCSCT=PRCSCT(1)
- SET DIK="^PRCS(410.3,"
- SET DA=PRCSRID0
- DO ^DIK
- GOTO CLS
- JMP DO RLR^PRCSUT1
- +1 SET $PIECE(^PRCS(410.3,PRCSRID0,0),U,5)=""
- SET DIK="^PRCS(410.3,"
- SET DA=PRCSRID0
- DO IX^DIK
- CLS ;
- +1 if $DATA(ZTSK)
- DO KILL^%ZTLOAD
- GOTO EXIT
- +2 ;
- HDRG WRITE @IOF,"GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE",?55,"DATE: ",PRCSD,!,"Requests Generated From Repetitive Item List Entry # ",PRCSNO,!
- SET L=""
- SET $PIECE(L,"-",IOM)="-"
- WRITE L
- SET L=""
- +1 QUIT
- +2 ;
- HOLD if IO'=IO(0)!($DATA(ZTQUEUED))
- QUIT
- WRITE !,"Press return to continue: "
- READ Z(1):DTIME
- QUIT
- ASK SET %=2
- WRITE !,"Do you wish to edit this request"
- DO YN^DICN
- if %=0
- DO ASK
- if %=2
- GOTO EN1
- if %'=1
- QUIT
- EN WRITE !
- KILL DTOUT,DUOUT,Y
- SET DIE="^PRCS(410,"
- SET (PRCSDR,DR)="[PRCSENPR]"
- SET T1=DA
- DO ^DIE
- IF $DATA(Y)!($DATA(DTOUT))
- SET DA=T1
- QUIT
- +1 SET DA=T1
- DO RL^PRCSUT1
- DO ^PRCSCK
- IF $DATA(PRCSERR)
- IF PRCSERR
- GOTO EN
- EN1 WRITE !
- DO W6^PRCSEB
- QUIT
- +1 ;*****************************************************************
- +2 ; PRCSRID0 represents the ien of the record in file 410.3
- +3 ; patch *81 --itdmid removes Re-use Ques for DM related RIL
- +4 ;*****************************************************************
- ITDMID(PRCSRID0) ; check DynaMed DOC ID existence for an item
- +1 ;N PRCVA,PRCVB,PRCVFLG
- +2 ;S PRCVA=0
- +3 ;S PRCVFLG=0 ; 0 means that there is no DM ID on a item
- +4 ;S PRCVA=$O(^PRCS(410.3,PRCSRID0,1,PRCVA)) D
- +5 ;.Q:+$G(PRCVA)'>0
- +6 ;.S PRCVB=$$GET1^DIQ(410.31,PRCVA_","_PRCSRID0_",",6) ; DM doc id
- +7 ;.I PRCVB'="" S PRCVFLG=1 Q
- +8 ;Q PRCVFLG
- +9 ;
- +10 ;Remove the prompt if entry is set in 414.02 Audit File 'C' x-ref
- +11 NEW PRCVFLG,PRCVL,PRCVM
- +12 Press return to continue: ; ext value of RIL trx
- SET PRCVM=$$GET1^DIQ(410.3,PRCSRID0_",",.01)
- +13 SET PRCVL=""
- +14 SET PRCVFLG=0
- +15 SET PRCVL=$ORDER(^PRCV(414.02,"C",PRCVM,PRCVL))
- +16 IF PRCVL'=""
- SET PRCVFLG=1
- QUIT 1
- +17 QUIT PRCVFLG
- +18 ;
- +19 ;
- EXIT KILL %,%DT,%ZIS,PRCSRID0,DA,DIC,DIE,DIK,PRCSRIJ,K,L,PRCSRIM,PRCS,PRCSCS
- +1 KILL PRCSCT,PRCSCC,PRCSD,PRCSD1,PRCSRI,PRCSIT,PRCSL,PRCSNO,PRCSS,PRCSTC
- +2 KILL PRCSV1,PX,T1,X,X1,X2,Y,Z,Z1,Z2
- +3 KILL PRCSTIME,PRCSQUAR,^TMP($JOB)
- QUIT