PRCSRIP ;WISC/SAW/BMM-PRINT/DISPLAY ITEMS BY VENDOR FROM REPETITIVE ITEM LIST FILE ;8/18/94 14:24 ;
V ;;5.1;IFCAP;**13,81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
;BMM 2/22/05 per PRC*5.1*81 add code to display DM DOC ID and Date
;Needed fields for RILs originating in DynaMed
;
S DIC="^PRCS(410.3,",DIC(0)="AEMQ",DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=+$P(^(0),""-"",4) I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
S DIC("A")="Select REPETITIVE ITEM LIST #: " D ^DIC K DIC("S") I Y'>0 G EXIT
S D0=+Y G EXIT:$G(^PRCS(410.3,D0,0))=""
;
;See NOIS MON-0399-51726
D SORT
;
S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS G EXIT:POP I $D(IO("Q")) S ZTRTN="QUE^PRCSRIP",ZTSAVE("D0")="" D ^%ZTLOAD G EXIT
QUE U IO S PRCSNO=$P(^PRCS(410.3,D0,0),"^") D NOW^%DTC S Y=% D DD^%DT S PRCSD=Y
S (N,PRCSP,PRCSIT,PRCSTC,Z(1))=""
I $G(ZTRTN)="QUE^PRCSRIP" D SORT ;See NOIS MON-0399-51726
F J=0:1 S N=$O(^TMP($J,410.3,D0,1,"AC",N)) Q:N="" D:'J HDRL D:IOSL-($Y#IOSL)<4 HOLD Q:Z(1)=U D:IOSL-($Y#IOSL)<4 HDRL W !!,"VENDOR: ",$P(N,";")," (",$P(N,";",2),")",! D ITEML
I 'J W !,"Items have not yet been entered for Repetitive Item List # ",PRCSNO
I J D:IOSL-($Y#IOSL)<4 HOLD Q:Z(1)=U D:IOSL-($Y#IOSL)<4 HDRL W !!,"TOTAL # OF ITEMS (ALL VENDORS): ",$J(PRCSIT,4),?40,"TOTAL COST (ALL VENDORS): ",$J(PRCSTC,9,2)
I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC
G EXIT
;
ITEML ;PRC*5.1*81 redirect to ITEML1D instead of ITEML1 if a DynaMed RIL
;
N PRCVDF,PRCVDN
S (N(1),PRCSC,PRCVDF,PRCVDN)=""
;check Inventory flag
S PRCVDF=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
F K=0:1 S N(1)=$O(^TMP($J,410.3,D0,1,"AC",N,N(1))) Q:N(1)="" D Q:Z(1)=U
. ;PRC*5.1*81 if flag=1 then DM RIL, use different display
. S PRCVDN=$$GET1^DIQ(410.31,N(1)_","_D0_",",6)
. I PRCVDF=1,PRCVDN'="" D ITEML1D(PRCVDN) Q
. D ITEML1
Q:Z(1)=U D:IOSL-($Y#IOSL)<3 HDRL W !!,"TOTAL # OF ITEMS: ",$J(K,4),?25,"TOTAL COST: ",$J(PRCSC,9,2),! S L="",$P(L,"-",IOM)="-" W L S L=""
S PRCSIT=PRCSIT+K,PRCSTC=PRCSTC+PRCSC Q
;
ITEML1 I IOSL-($Y#IOSL)<2 D HOLD Q:Z(1)=U D HDRL W !!,"VENDOR: ",$P(N,";")," (",$P(N,";",2),")",!
S X=^PRCS(410.3,D0,1,N(1),0) W !,$P(X,"^"),?12 W:$D(^PRC(441,$P(X,"^"),0)) $E($P(^(0),"^",2),1,42) W ?54,$S($P(X,"^",2)[".":$J($P(X,"^",2),9,2),1:$J($P(X,"^",2),9)),?66,$J($P(X,"^",4),9,2)
I $D(^PRC(441,$P(X,"^"),2,+$P(X,"^",5),0)) W ?78,$S($D(^PRCD(420.5,+$P(^(0),"^",7),0)):$P(^(0),"^"),1:"")
S PRCSC=PRCSC+($P(X,"^",2)*($P(X,"^",4))) Q
;
HOLD Q:IO'=IO(0)!($D(ZTQUEUED)) S Z(1)="" W !,"Press return to continue, uparrow (^) to exit: " R Z(1):DTIME S:'$T Z(1)=U Q
HDRL S PRCSP=PRCSP+1 W @IOF,"REPETITIVE ITEM LIST #: ",PRCSNO,?50,"DATE: ",PRCSD," PAGE ",PRCSP
W !,"ITEM NO.",?12,"SHORT DESCRIPTION",?55,"QUANTITY",?66,"UNIT COST",?77,"U/P",! S L="",$P(L,"-",IOM)="-" W L S L=""
Q
;
SORT ;See NOIS MON-0399-51726
KILL ^TMP($J)
N II,FF S II=0
F S II=$O(^PRCS(410.3,D0,1,II)) Q:'II D ;
. S FF=$G(^PRCS(410.3,D0,1,II,0))
. S ^TMP($J,410.3,D0,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),II)=""
Q
;
EXIT K %,%DT,%ZIS,D0,DIC,I,J,K,L,N,PRCSC,PRCSD,PRCSIT,PRCSNO,PRCSP,PRCSTC
K PRCS,X,Y,Z,IEN410,^TMP($J) Q
;
ITEML1D(PRCVDN) ;PRC*5.1*81
;display items from DynaMed RIL, include DM Doc ID and
;Date Needed
;PRCVDN is DM Doc ID
;
N PRCVED,PRCVFMD
I IOSL-($Y#IOSL)<2 D HOLD Q:Z(1)=U D HDRL W !!,"VENDOR: ",$P(N,";")," (",$P(N,";",2),")",!
S X=^PRCS(410.3,D0,1,N(1),0) W !,$P(X,"^"),?12 W:$D(^PRC(441,$P(X,"^"),0)) $E($P(^(0),"^",2),1,42) W ?54,$S($P(X,"^",2)[".":$J($P(X,"^",2),9,2),1:$J($P(X,"^",2),9)),?66,$J($P(X,"^",4),9,2)
I $D(^PRC(441,$P(X,"^"),2,+$P(X,"^",5),0)) W ?78,$S($D(^PRCD(420.5,+$P(^(0),"^",7),0)):$P(^(0),"^"),1:"")
;S PRCVFMD=$$HL7TFM^XLFDT($P(X,"^",8))
S PRCVED=$$FMTE^XLFDT($P(X,"^",8))
W !,"DM DOC ID: ",$P(X,"^",7),?45,"DATE NEEDED BY: ",PRCVED
S PRCSC=PRCSC+($P(X,"^",2)*($P(X,"^",4)))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSRIP 3950 printed Sep 23, 2025@19:54:34 Page 2
PRCSRIP ;WISC/SAW/BMM-PRINT/DISPLAY ITEMS BY VENDOR FROM REPETITIVE ITEM LIST FILE ;8/18/94 14:24 ;
V ;;5.1;IFCAP;**13,81**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 ;BMM 2/22/05 per PRC*5.1*81 add code to display DM DOC ID and Date
+4 ;Needed fields for RILs originating in DynaMed
+5 ;
+6 SET DIC="^PRCS(410.3,"
SET DIC(0)="AEMQ"
SET DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=+$P(^(0),""-"",4) I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+7 SET DIC("A")="Select REPETITIVE ITEM LIST #: "
DO ^DIC
KILL DIC("S")
IF Y'>0
GOTO EXIT
+8 SET D0=+Y
if $GET(^PRCS(410.3,D0,0))=""
GOTO EXIT
+9 ;
+10 ;See NOIS MON-0399-51726
+11 DO SORT
+12 ;
+13 SET %ZIS("B")="HOME"
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTRTN="QUE^PRCSRIP"
SET ZTSAVE("D0")=""
DO ^%ZTLOAD
GOTO EXIT
QUE USE IO
SET PRCSNO=$PIECE(^PRCS(410.3,D0,0),"^")
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET PRCSD=Y
+1 SET (N,PRCSP,PRCSIT,PRCSTC,Z(1))=""
+2 ;See NOIS MON-0399-51726
IF $GET(ZTRTN)="QUE^PRCSRIP"
DO SORT
+3 FOR J=0:1
SET N=$ORDER(^TMP($JOB,410.3,D0,1,"AC",N))
if N=""
QUIT
if 'J
DO HDRL
if IOSL-($Y#IOSL)<4
DO HOLD
if Z(1)=U
QUIT
if IOSL-($Y#IOSL)<4
DO HDRL
WRITE !!,"VENDOR: ",$PIECE(N,";")," (",$PIECE(N,";",2),")",!
DO ITEML
+4 IF 'J
WRITE !,"Items have not yet been entered for Repetitive Item List # ",PRCSNO
+5 IF J
if IOSL-($Y#IOSL)<4
DO HOLD
if Z(1)=U
QUIT
if IOSL-($Y#IOSL)<4
DO HDRL
WRITE !!,"TOTAL # OF ITEMS (ALL VENDORS): ",$JUSTIFY(PRCSIT,4),?40,"TOTAL COST (ALL VENDORS): ",$JUSTIFY(PRCSTC,9,2)
+6 IF (IO'=IO(0))!($DATA(ZTQUEUED))
DO ^%ZISC
+7 GOTO EXIT
+8 ;
ITEML ;PRC*5.1*81 redirect to ITEML1D instead of ITEML1 if a DynaMed RIL
+1 ;
+2 NEW PRCVDF,PRCVDN
+3 SET (N(1),PRCSC,PRCVDF,PRCVDN)=""
+4 ;check Inventory flag
+5 SET PRCVDF=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
+6 FOR K=0:1
SET N(1)=$ORDER(^TMP($JOB,410.3,D0,1,"AC",N,N(1)))
if N(1)=""
QUIT
Begin DoDot:1
+7 ;PRC*5.1*81 if flag=1 then DM RIL, use different display
+8 SET PRCVDN=$$GET1^DIQ(410.31,N(1)_","_D0_",",6)
+9 IF PRCVDF=1
IF PRCVDN'=""
DO ITEML1D(PRCVDN)
QUIT
+10 DO ITEML1
End DoDot:1
if Z(1)=U
QUIT
+11 if Z(1)=U
QUIT
if IOSL-($Y#IOSL)<3
DO HDRL
WRITE !!,"TOTAL # OF ITEMS: ",$JUSTIFY(K,4),?25,"TOTAL COST: ",$JUSTIFY(PRCSC,9,2),!
SET L=""
SET $PIECE(L,"-",IOM)="-"
WRITE L
SET L=""
+12 SET PRCSIT=PRCSIT+K
SET PRCSTC=PRCSTC+PRCSC
QUIT
+13 ;
ITEML1 IF IOSL-($Y#IOSL)<2
DO HOLD
if Z(1)=U
QUIT
DO HDRL
WRITE !!,"VENDOR: ",$PIECE(N,";")," (",$PIECE(N,";",2),")",!
+1 SET X=^PRCS(410.3,D0,1,N(1),0)
WRITE !,$PIECE(X,"^"),?12
if $DATA(^PRC(441,$PIECE(X,"^"),0))
WRITE $EXTRACT($PIECE(^(0),"^",2),1,42)
WRITE ?54,$SELECT($PIECE(X,"^",2)[".":$JUSTIFY($PIECE(X,"^",2),9,2),1:$JUSTIFY($PIECE(X,"^",2),9)),?66,$JUSTIFY($PIECE(X,"^",4),9,2)
+2 IF $DATA(^PRC(441,$PIECE(X,"^"),2,+$PIECE(X,"^",5),0))
WRITE ?78,$SELECT($DATA(^PRCD(420.5,+$PIECE(^(0),"^",7),0)):$PIECE(^(0),"^"),1:"")
+3 SET PRCSC=PRCSC+($PIECE(X,"^",2)*($PIECE(X,"^",4)))
QUIT
+4 ;
HOLD if IO'=IO(0)!($DATA(ZTQUEUED))
QUIT
SET Z(1)=""
WRITE !,"Press return to continue, uparrow (^) to exit: "
READ Z(1):DTIME
if '$TEST
SET Z(1)=U
QUIT
HDRL SET PRCSP=PRCSP+1
WRITE @IOF,"REPETITIVE ITEM LIST #: ",PRCSNO,?50,"DATE: ",PRCSD," PAGE ",PRCSP
+1 WRITE !,"ITEM NO.",?12,"SHORT DESCRIPTION",?55,"QUANTITY",?66,"UNIT COST",?77,"U/P",!
SET L=""
SET $PIECE(L,"-",IOM)="-"
WRITE L
SET L=""
+2 QUIT
+3 ;
SORT ;See NOIS MON-0399-51726
+1 KILL ^TMP($JOB)
+2 NEW II,FF
SET II=0
+3 ;
FOR
SET II=$ORDER(^PRCS(410.3,D0,1,II))
if 'II
QUIT
Begin DoDot:1
+4 SET FF=$GET(^PRCS(410.3,D0,1,II,0))
+5 SET ^TMP($JOB,410.3,D0,1,"AC",$PIECE(FF,"^",3)_";"_$PIECE(FF,"^",5),II)=""
End DoDot:1
+6 QUIT
+7 ;
EXIT KILL %,%DT,%ZIS,D0,DIC,I,J,K,L,N,PRCSC,PRCSD,PRCSIT,PRCSNO,PRCSP,PRCSTC
+1 KILL PRCS,X,Y,Z,IEN410,^TMP($JOB)
QUIT
+2 ;
ITEML1D(PRCVDN) ;PRC*5.1*81
+1 ;display items from DynaMed RIL, include DM Doc ID and
+2 ;Date Needed
+3 ;PRCVDN is DM Doc ID
+4 ;
+5 NEW PRCVED,PRCVFMD
+6 IF IOSL-($Y#IOSL)<2
DO HOLD
if Z(1)=U
QUIT
DO HDRL
WRITE !!,"VENDOR: ",$PIECE(N,";")," (",$PIECE(N,";",2),")",!
+7 SET X=^PRCS(410.3,D0,1,N(1),0)
WRITE !,$PIECE(X,"^"),?12
if $DATA(^PRC(441,$PIECE(X,"^"),0))
WRITE $EXTRACT($PIECE(^(0),"^",2),1,42)
WRITE ?54,$SELECT($PIECE(X,"^",2)[".":$JUSTIFY($PIECE(X,"^",2),9,2),1:$JUSTIFY($PIECE(X,"^",2),9)),?66,$JUSTIFY($PIECE(X,"^",4),9,2)
+8 IF $DATA(^PRC(441,$PIECE(X,"^"),2,+$PIECE(X,"^",5),0))
WRITE ?78,$SELECT($DATA(^PRCD(420.5,+$PIECE(^(0),"^",7),0)):$PIECE(^(0),"^"),1:"")
+9 ;S PRCVFMD=$$HL7TFM^XLFDT($P(X,"^",8))
+10 SET PRCVED=$$FMTE^XLFDT($PIECE(X,"^",8))
+11 WRITE !,"DM DOC ID: ",$PIECE(X,"^",7),?45,"DATE NEEDED BY: ",PRCVED
+12 SET PRCSC=PRCSC+($PIECE(X,"^",2)*($PIECE(X,"^",4)))
+13 QUIT
+14 ;
