PRCSRIG2 ;SF-ISC/LJP/KMB/BMM-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ; 3/25/05 3:05pm
V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;PRCSRI is the ordered item from the RIL. PX(3) is
;the ordered item from the Item Master File. PRCSV1 is
;the vendor from the RIL. X2 is the vendor listed for
;the item from the Item Master File. PX(1) holds Item
;Master File data, PX(2) holds Vendor File data.
;
;2/16/05 BMM per PRC*5.1*81, added code in ITEMG1 to capture
;data from two new fields in files 410 and 410.3:
;DM Doc ID (410 #17, 410.3 #6) and Date Needed (410 #18, 410.3 #7)
;added variables PRCVDN, PRCVDTN in ITEMG
;
;3/9/05 BMM per PRC*5.1*81, added sub UPDAUD to update the DM Audit
;file when a 2237 is created.
;
ITEMG N STOP,PRCVDN,PRCVDTN S (PRCSRI,PRCSCS,STOP)="",(PRCSIT(1),K,BFLAG)=0
S (PRCVDN,PRCVDTN)=""
F PRCSRIM=0:1 S PRCSRI=$O(^TMP($J,410.3,PRCSRID0,1,"AC",PRCSV1,PRCSRI)) Q:PRCSRI="" S PRCSIT=PRCSIT+1,PRCSIT(1)=PRCSIT(1)+1 D ITEMG1 D:STOP'=1 ITEMG3 Q:BFLAG S STOP=""
D:'BFLAG
. D:$D(DA) ITEMG2 I $D(PRCSL),PRCSL L
. D:IOSL-$Y<2 HOLD,HDRG W !!," Finished building request.",!,"This request contains ",PRCSIT(1)_$S(PRCSIT(1)=1:" item.",1:" items.")," The total cost for this request is $",$J(PRCSCS,0,2),! S L="",$P(L,"-",IOM)="-" W L S L=""
. S PRCSTC=PRCSTC+PRCSCS Q
D:BFLAG
. I (PRCSIT>0) D
. . S PRCSIT=PRCSIT-1
. I (PRCSCT>0) D
. . S PRCSCT=PRCSCT-1
Q
;
ITEMG1 S PX=^PRCS(410.3,PRCSRID0,1,PRCSRI,0),PX(3)=$P(PX,"^"),PX(1)=^PRC(441,PX(3),0),X2=$P(PX,"^",5),PX(2)=^PRC(440,X2,0),PRCVDN=$P(PX,"^",7),PRCVDTN=$P(PX,"^",8)
; If a discrepancy is found, set STOP=1, skip item
I $D(PX(1)),$P(PX(1),"^",10)'?4N W !,"The budget object code for this item is not entered in the Item Master File.",!,"This item cannot be processed.",! S STOP=1
I '$D(^PRC(441,PX(3),2,X2,0)) D:IOSL-$Y<2 HOLD,HDRG W !,$C(7),"WARNING!!! Item # ",PX(3)," is not available from ",$P(PRCSV1,";")," (",$P(PRCSV1,";",2),")",!,"This item cannot be processed.",! S PRCSIT=PRCSIT-1,PRCSIT(1)=PRCSIT(1)-1 S STOP=1
Q
;
ITEMG3 I '$D(Z1)!'$D(Z2) D DVERR Q
I 'K S Z=Z1,X=Z2 D EN1^PRCSUT3 G:'X EX S X1=X D EN2^PRCSUT3 G:'$D(X1) EX L +^PRCS(410,DA):15 G:$T=0 EX
D:IOSL-$Y<7 HOLD,HDRG
I 'K W !,"A request with Transaction Number ",$P(Y(0),"^")," has been generated.",!!,"The vendor for this request is ",$P(PRCSV1,";")," (",$P(PRCSV1,";",2),")",!,"Now entering items for this request."
;PRC*5.1*81 update audit file for 2237 creation
I 'K S PRCV2=$P(Y(0),"^",1)
;S K=K+1,X(3)=^PRC(441,PX(3),2,X2,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)<1 S PRCSS=$S($P(PX(1),"^",10):$E($P(^PRCD(420.2,$P(PX(1),"^",10),0),"^"),1,30),1:"")
;
;For a Supply Fund Requests adding code to derive BOC from NSN
S K=K+1
S X(3)=^PRC(441,PX(3),2,X2,0)
S ITNSN=$E($P($G(^PRC(441,+PX(3),0)),U,5),1,4)
I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) D
. I $P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)'=2!($P(^(0),U,12)'=4) D
. . S PRCSS=$S($P(PX(1),"^",10):$E($P(^PRCD(420.2,$P(PX(1),"^",10),0),"^"),1,30),1:"")
. . Q
. I $P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)=2!($P(^(0),U,12)=4) D
. . S ITACCT=$$ACCT^PRCPUX1(ITNSN)
. . S ITBOC=$S(ITACCT=1:2697,ITACCT=2:2698,ITACCT=3:2699,ITACCT=6:2699,ITACCT=8:2696,1:2699)
. . S PRCSS=$E($P(^PRCD(420.2,ITBOC,0),U,1),1,30)
. . Q
. Q
S:'$D(PRCSS) PRCSS="" S ^PRCS(410,DA,"IT",K,0)=K_"^"_$P(PX,"^",2)_"^"_$P(X(3),"^",7)_"^"_PRCSS_"^"_PX(3)_"^"_$P(X(3),"^",4)_"^"_$P(PX,"^",4),^PRCS(410,DA,"IT",K,1,0)="^^1^1^"_PRCSD1_"^^",^(1,0)=$P(PX(1),"^",2)
;PRC*5.1*81 add DM Doc ID, Date Needed to new line item
;
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D
. Q:'$D(^PRCV(414.02,"C",PRCSNO))
. S ^PRCS(410,DA,"IT",K,4)=PRCVDN_"^"_PRCVDTN
. D UPDAUD(PRCV2)
S ^PRCS(410,DA,"IT","B",K,K)="",^PRCS(410,DA,"IT","AB",K,K)="" S:PRCSS ^PRCS(410,"AD",PRCSS,DA)=""
S PRCSCS=PRCSCS+($P(PX,"^",2)*($P(PX,"^",4))) G EX2
;
ITEMG2 S ^PRCS(410,DA,"IT",0)="^"_"410.02AI"_"^"_K_"^"_K,%=$P(^PRCS(410.3,PRCSRID0,0),"^",3),$P(^PRCS(410,DA,0),"^",2)="O" S:% $P(^(0),"^",6)=%,^PRCS(410,"AO",%,DA)="" S $P(^PRCS(410,DA,0),"^",4)=$S($D(^PRC(440,"AC","S",X2)):5,1:3)
S ^PRCS(410,DA,1)=PRCSD1_"^^"_"ST"_"^"_PRCSD(1),^(2)=PX(2),^PRCS(410,DA,3)=$P(^PRCS(410,DA,3),"^",1,2)_"^"_PRCSCC_"^"_X2_"^"_$S($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$P(^(0),"^",10),1:"")
S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
S:PRC("ACC") $P(^PRCS(410,DA,3),"^",12)=$P(PRC("ACC"),"^",3)
S ^PRCS(410,DA,4)=PRCSCS_"^"_PRCSD1_"^^^^^^"_PRCSCS,^(10)=K,^(7)=+PRC("PER")_"^"_$P(PRC("PER"),"^",3) S:'$D(^(11)) ^(11)=""
S ^PRCS(410,"E",$E($P(PX(2),"^"),1,30),DA)="" S:PRCSCC ^PRCS(410,"AC",$E(PRCSCC,1,30),DA)=""
I IO'=IO(0)!$D(ZTQUEUED) S $P(^PRCS(410,DA,11),U,3)=1,^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA)="",^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA)=""
I IO'=IO(0)!$D(ZTQUEUED) S ^PRCS(410,"AQ",1,DA)="" L -^PRCS(410,DA) G END
S PRC("QTR")=$P($P(^PRCS(410,DA,0),U),"-",3) D ASK^PRCSRIG1 L -^PRCS(410,DA)
END K DA,PRCSDR,PRCSCQT,PRCSOCK,PRCSOCP,PRCSOCS,PRCST,PRCST1,PX,X2 Q
;
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
EX K PX,X,X1,X2,Z S PRCSCT=PRCSCT-1 W $C(7),!,"Could not create a request" Q
EX1 K X,X2 D KRL K PX Q
EX2 K PRCSS,Y D KRL K PX(3),X(3) Q
KRL Q
;
UPDAUD(PRCV2) ;per PRC*5.1*81, update DM Audit file (#414.02) when 2237 is created
;PRCV2 - 2237's .01 value
;PRCVDYN - DM Doc ID for each item
;PRCSRID0 - RIL IEN from above
;
;first check DM flag
;Q:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
N PRCVA,PRCVAC,PRCVC,PRCVDI,PRCVDYN,PRCVI,PRCVIEN,PRCVFCP
N PRCVFL,PRCVJ,PRCVST,PRCVTMP,XMB
S (PRCVC,PRCVDYN,PRCVIEN)="",PRCVFL=0
;get #items for RIL in 414.02
;F PRCVI=0:1 S PRCVC=$O(^PRCV(414.02,"C",PRCSNO,PRCVC)) Q:PRCVC=""
;for each item, update entry in 414.02
;F PRCVJ=1:1:PRCVI Q:PRCVFL=1 D
S PRCVJ=PRCSRI D
. S PRCVDYN=$$GET1^DIQ(410.31,PRCVJ_","_PRCSRID0_",",6)
. ;
. I PRCVDYN="" D Q
. . ;DM Doc ID missing
. . S PRCVTMP="PRCSRIG2",PRCVST=$P(PRCSNO,"-")
. . S PRCVFCP=$P(PRCSNO,"-",4)
. . S XMB(1)="creating a new 2237 record"
. . S XMB(2)=" <missing>"
. . S XMB(3)="DM doc ID value missing from line item in 2237"
. . S ^TMP($J,"PRCSRIG2",1,0)=""
. . S ^TMP($J,"PRCSRIG2",2,0)="2237 #: "_PRCV2
. . S ^TMP($J,"PRCSRIG2",3,0)="Item #: "_PX(3)
. . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
. ;
. S PRCVIEN=$O(^PRCV(414.02,"B",PRCVDYN,0))
. S PRCVA(414.02,PRCVIEN_",",7)=PRCV2
. D FILE^DIE("","PRCVA")
. I $D(^TMP("DIERR",$J)) D Q
. . ;error updating Audit file
. . S PRCVTMP="PRCSRIG2",PRCVST=$P(PRCSNO,"-")
. . S PRCVFCP=$P(PRCSNO,"-",4)
. . S XMB(1)="updating the DynaMed IFCAP Interface Audit file (#414.02)"
. . S XMB(2)=PRCVDYN
. . S XMB(3)="unable to add update to Audit file entry"
. . S ^TMP($J,"PRCSRIG2",1,0)=""
. . S ^TMP($J,"PRCSRIG2",2,0)="2237 #: "_PRCV2
. . S ^TMP($J,"PRCSRIG2",3,0)="Item #: "_PX(3)
. . S ^TMP($J,"PRCSRIG2",4,0)="Error text: "_$G(^TMP("DIERR",$J,1,"TEXT",1))
. . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
Q
DVERR D BLNKON
W !,"There is an error with the default device defined in file 411.",!,"Please contact IRM before proceeding.",!
D BLNKOFF
S BFLAG=1
Q
;
BLNKON ;if terminal-type exists turn-on blink
D:$D(IOST(0))
. S X="IOBON"
. D ENDR^%ZISS
. W IOBON
Q
BLNKOFF ;if terminal-type exists turn-off blink
D:$D(IOST(0))
. S X="IOBOFF"
. D ENDR^%ZISS
. W IOBOFF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSRIG2 7872 printed Oct 16, 2024@18:19:13 Page 2
PRCSRIG2 ;SF-ISC/LJP/KMB/BMM-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ; 3/25/05 3:05pm
V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;PRCSRI is the ordered item from the RIL. PX(3) is
+3 ;the ordered item from the Item Master File. PRCSV1 is
+4 ;the vendor from the RIL. X2 is the vendor listed for
+5 ;the item from the Item Master File. PX(1) holds Item
+6 ;Master File data, PX(2) holds Vendor File data.
+7 ;
+8 ;2/16/05 BMM per PRC*5.1*81, added code in ITEMG1 to capture
+9 ;data from two new fields in files 410 and 410.3:
+10 ;DM Doc ID (410 #17, 410.3 #6) and Date Needed (410 #18, 410.3 #7)
+11 ;added variables PRCVDN, PRCVDTN in ITEMG
+12 ;
+13 ;3/9/05 BMM per PRC*5.1*81, added sub UPDAUD to update the DM Audit
+14 ;file when a 2237 is created.
+15 ;
ITEMG NEW STOP,PRCVDN,PRCVDTN
SET (PRCSRI,PRCSCS,STOP)=""
SET (PRCSIT(1),K,BFLAG)=0
+1 SET (PRCVDN,PRCVDTN)=""
+2 FOR PRCSRIM=0:1
SET PRCSRI=$ORDER(^TMP($JOB,410.3,PRCSRID0,1,"AC",PRCSV1,PRCSRI))
if PRCSRI=""
QUIT
SET PRCSIT=PRCSIT+1
SET PRCSIT(1)=PRCSIT(1)+1
DO ITEMG1
if STOP'=1
DO ITEMG3
if BFLAG
QUIT
SET STOP=""
+3 if 'BFLAG
Begin DoDot:1
+4 if $DATA(DA)
DO ITEMG2
IF $DATA(PRCSL)
IF PRCSL
LOCK
+5 if IOSL-$Y<2
DO HOLD
DO HDRG
WRITE !!," Finished building request.",!,"This request contains ",PRCSIT(1)_$SELECT(PRCSIT(1)=1:" item.",1:" items.")," The total cost for this request is $",$JUSTIFY(PRCSCS,0,2),!
SET L=""
SET $PIECE(L,"-",IOM)="-"
WRITE L
SET L=""
+6 SET PRCSTC=PRCSTC+PRCSCS
QUIT
End DoDot:1
+7 if BFLAG
Begin DoDot:1
+8 IF (PRCSIT>0)
Begin DoDot:2
+9 SET PRCSIT=PRCSIT-1
End DoDot:2
+10 IF (PRCSCT>0)
Begin DoDot:2
+11 SET PRCSCT=PRCSCT-1
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
ITEMG1 SET PX=^PRCS(410.3,PRCSRID0,1,PRCSRI,0)
SET PX(3)=$PIECE(PX,"^")
SET PX(1)=^PRC(441,PX(3),0)
SET X2=$PIECE(PX,"^",5)
SET PX(2)=^PRC(440,X2,0)
SET PRCVDN=$PIECE(PX,"^",7)
SET PRCVDTN=$PIECE(PX,"^",8)
+1 ; If a discrepancy is found, set STOP=1, skip item
+2 IF $DATA(PX(1))
IF $PIECE(PX(1),"^",10)'?4N
WRITE !,"The budget object code for this item is not entered in the Item Master File.",!,"This item cannot be processed.",!
SET STOP=1
+3 IF '$DATA(^PRC(441,PX(3),2,X2,0))
if IOSL-$Y<2
DO HOLD
DO HDRG
WRITE !,$CHAR(7),"WARNING!!! Item # ",PX(3)," is not available from ",$PIECE(PRCSV1,";")," (",$PIECE(PRCSV1,";",2),")",!,"This item cannot be processed.",!
SET PRCSIT=PRCSIT-1
SET PRCSIT(1)=PRCSIT(1)-1
SET STOP=1
+4 QUIT
+5 ;
ITEMG3 IF '$DATA(Z1)!'$DATA(Z2)
DO DVERR
QUIT
+1 IF 'K
SET Z=Z1
SET X=Z2
DO EN1^PRCSUT3
if 'X
GOTO EX
SET X1=X
DO EN2^PRCSUT3
if '$DATA(X1)
GOTO EX
LOCK +^PRCS(410,DA):15
if $TEST=0
GOTO EX
+2 if IOSL-$Y<7
DO HOLD
DO HDRG
+3 IF 'K
WRITE !,"A request with Transaction Number ",$PIECE(Y(0),"^")," has been generated.",!!,"The vendor for this request is ",$PIECE(PRCSV1,";")," (",$PIECE(PRCSV1,";",2),")",!,"Now entering items for this request."
+4 ;PRC*5.1*81 update audit file for 2237 creation
+5 IF 'K
SET PRCV2=$PIECE(Y(0),"^",1)
+6 ;S K=K+1,X(3)=^PRC(441,PX(3),2,X2,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)<1 S PRCSS=$S($P(PX(1),"^",10):$E($P(^PRCD(420.2,$P(PX(1),"^",10),0),"^"),1,30),1:"")
+7 ;
+8 ;For a Supply Fund Requests adding code to derive BOC from NSN
+9 SET K=K+1
+10 SET X(3)=^PRC(441,PX(3),2,X2,0)
+11 SET ITNSN=$EXTRACT($PIECE($GET(^PRC(441,+PX(3),0)),U,5),1,4)
+12 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
Begin DoDot:1
+13 IF $PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)'=2!($PIECE(^(0),U,12)'=4)
Begin DoDot:2
+14 SET PRCSS=$SELECT($PIECE(PX(1),"^",10):$EXTRACT($PIECE(^PRCD(420.2,$PIECE(PX(1),"^",10),0),"^"),1,30),1:"")
+15 QUIT
End DoDot:2
+16 IF $PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)=2!($PIECE(^(0),U,12)=4)
Begin DoDot:2
+17 SET ITACCT=$$ACCT^PRCPUX1(ITNSN)
+18 SET ITBOC=$SELECT(ITACCT=1:2697,ITACCT=2:2698,ITACCT=3:2699,ITACCT=6:2699,ITACCT=8:2696,1:2699)
+19 SET PRCSS=$EXTRACT($PIECE(^PRCD(420.2,ITBOC,0),U,1),1,30)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 if '$DATA(PRCSS)
SET PRCSS=""
SET ^PRCS(410,DA,"IT",K,0)=K_"^"_$PIECE(PX,"^",2)_"^"_$PIECE(X(3),"^",7)_"^"_PRCSS_"^"_PX(3)_"^"_$PIECE(X(3),"^",4)_"^"_$PIECE(PX,"^",4)
SET ^PRCS(410,DA,"IT",K,1,0)="^^1^1^"_PRCSD1_"^^"
SET ^(1,0)=$PIECE(PX(1),"^",2)
+23 ;PRC*5.1*81 add DM Doc ID, Date Needed to new line item
+24 ;
+25 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
Begin DoDot:1
+26 if '$DATA(^PRCV(414.02,"C",PRCSNO))
QUIT
+27 SET ^PRCS(410,DA,"IT",K,4)=PRCVDN_"^"_PRCVDTN
+28 DO UPDAUD(PRCV2)
End DoDot:1
+29 SET ^PRCS(410,DA,"IT","B",K,K)=""
SET ^PRCS(410,DA,"IT","AB",K,K)=""
if PRCSS
SET ^PRCS(410,"AD",PRCSS,DA)=""
+30 SET PRCSCS=PRCSCS+($PIECE(PX,"^",2)*($PIECE(PX,"^",4)))
GOTO EX2
+31 ;
ITEMG2 SET ^PRCS(410,DA,"IT",0)="^"_"410.02AI"_"^"_K_"^"_K
SET %=$PIECE(^PRCS(410.3,PRCSRID0,0),"^",3)
SET $PIECE(^PRCS(410,DA,0),"^",2)="O"
if %
SET $PIECE(^(0),"^",6)=%
SET ^PRCS(410,"AO",%,DA)=""
SET $PIECE(^PRCS(410,DA,0),"^",4)=$SELECT($DATA(^PRC(440,"AC","S",X2)):5,1:3)
+1 SET ^PRCS(410,DA,1)=PRCSD1_"^^"_"ST"_"^"_PRCSD(1)
SET ^(2)=PX(2)
SET ^PRCS(410,DA,3)=$PIECE(^PRCS(410,DA,3),"^",1,2)_"^"_PRCSCC_"^"_X2_"^"_$SELECT($DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$PIECE(^(0),"^",10),1:"")
+2 SET $PIECE(^PRCS(410,DA,3),"^",11)=$PIECE($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
+3 if PRC("ACC")
SET $PIECE(^PRCS(410,DA,3),"^",12)=$PIECE(PRC("ACC"),"^",3)
+4 SET ^PRCS(410,DA,4)=PRCSCS_"^"_PRCSD1_"^^^^^^"_PRCSCS
SET ^(10)=K
SET ^(7)=+PRC("PER")_"^"_$PIECE(PRC("PER"),"^",3)
if '$DATA(^(11))
SET ^(11)=""
+5 SET ^PRCS(410,"E",$EXTRACT($PIECE(PX(2),"^"),1,30),DA)=""
if PRCSCC
SET ^PRCS(410,"AC",$EXTRACT(PRCSCC,1,30),DA)=""
+6 IF IO'=IO(0)!$DATA(ZTQUEUED)
SET $PIECE(^PRCS(410,DA,11),U,3)=1
SET ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$PIECE($PIECE(^PRCS(410,DA,0),U),"-",5),DA)=""
SET ^PRCS(410,"F1",$PIECE($PIECE(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA)=""
+7 IF IO'=IO(0)!$DATA(ZTQUEUED)
SET ^PRCS(410,"AQ",1,DA)=""
LOCK -^PRCS(410,DA)
GOTO END
+8 SET PRC("QTR")=$PIECE($PIECE(^PRCS(410,DA,0),U),"-",3)
DO ASK^PRCSRIG1
LOCK -^PRCS(410,DA)
END KILL DA,PRCSDR,PRCSCQT,PRCSOCK,PRCSOCP,PRCSOCS,PRCST,PRCST1,PX,X2
QUIT
+1 ;
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
EX KILL PX,X,X1,X2,Z
SET PRCSCT=PRCSCT-1
WRITE $CHAR(7),!,"Could not create a request"
QUIT
EX1 Press return to continue: KILL X,X2
DO KRL
KILL PX
QUIT
EX2 KILL PRCSS,Y
DO KRL
KILL PX(3),X(3)
QUIT
KRL QUIT
+1 ;
UPDAUD(PRCV2) ;per PRC*5.1*81, update DM Audit file (#414.02) when 2237 is created
+1 ;PRCV2 - 2237's .01 value
+2 ;PRCVDYN - DM Doc ID for each item
+3 ;PRCSRID0 - RIL IEN from above
+4 ;
+5 ;first check DM flag
+6 ;Q:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
+7 NEW PRCVA,PRCVAC,PRCVC,PRCVDI,PRCVDYN,PRCVI,PRCVIEN,PRCVFCP
+8 NEW PRCVFL,PRCVJ,PRCVST,PRCVTMP,XMB
+9 SET (PRCVC,PRCVDYN,PRCVIEN)=""
SET PRCVFL=0
+10 ;get #items for RIL in 414.02
+11 ;F PRCVI=0:1 S PRCVC=$O(^PRCV(414.02,"C",PRCSNO,PRCVC)) Q:PRCVC=""
+12 ;for each item, update entry in 414.02
+13 ;F PRCVJ=1:1:PRCVI Q:PRCVFL=1 D
+14 SET PRCVJ=PRCSRI
Begin DoDot:1
+15 SET PRCVDYN=$$GET1^DIQ(410.31,PRCVJ_","_PRCSRID0_",",6)
+16 ;
+17 IF PRCVDYN=""
Begin DoDot:2
+18 ;DM Doc ID missing
+19 SET PRCVTMP="PRCSRIG2"
SET PRCVST=$PIECE(PRCSNO,"-")
+20 SET PRCVFCP=$PIECE(PRCSNO,"-",4)
+21 SET XMB(1)="creating a new 2237 record"
+22 SET XMB(2)=" <missing>"
+23 SET XMB(3)="DM doc ID value missing from line item in 2237"
+24 SET ^TMP($JOB,"PRCSRIG2",1,0)=""
+25 SET ^TMP($JOB,"PRCSRIG2",2,0)="2237 #: "_PRCV2
+26 SET ^TMP($JOB,"PRCSRIG2",3,0)="Item #: "_PX(3)
+27 DO DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
End DoDot:2
QUIT
+28 ;
+29 SET PRCVIEN=$ORDER(^PRCV(414.02,"B",PRCVDYN,0))
+30 SET PRCVA(414.02,PRCVIEN_",",7)=PRCV2
+31 DO FILE^DIE("","PRCVA")
+32 IF $DATA(^TMP("DIERR",$JOB))
Begin DoDot:2
+33 ;error updating Audit file
+34 SET PRCVTMP="PRCSRIG2"
SET PRCVST=$PIECE(PRCSNO,"-")
+35 SET PRCVFCP=$PIECE(PRCSNO,"-",4)
+36 SET XMB(1)="updating the DynaMed IFCAP Interface Audit file (#414.02)"
+37 SET XMB(2)=PRCVDYN
+38 SET XMB(3)="unable to add update to Audit file entry"
+39 SET ^TMP($JOB,"PRCSRIG2",1,0)=""
+40 SET ^TMP($JOB,"PRCSRIG2",2,0)="2237 #: "_PRCV2
+41 SET ^TMP($JOB,"PRCSRIG2",3,0)="Item #: "_PX(3)
+42 SET ^TMP($JOB,"PRCSRIG2",4,0)="Error text: "_$GET(^TMP("DIERR",$JOB,1,"TEXT",1))
+43 DO DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
End DoDot:2
QUIT
End DoDot:1
+44 QUIT
DVERR DO BLNKON
+1 WRITE !,"There is an error with the default device defined in file 411.",!,"Please contact IRM before proceeding.",!
+2 DO BLNKOFF
+3 SET BFLAG=1
+4 QUIT
+5 ;
BLNKON ;if terminal-type exists turn-on blink
+1 if $DATA(IOST(0))
Begin DoDot:1
+2 SET X="IOBON"
+3 DO ENDR^%ZISS
+4 WRITE IOBON
End DoDot:1
+5 QUIT
BLNKOFF ;if terminal-type exists turn-off blink
+1 if $DATA(IOST(0))
Begin DoDot:1
+2 SET X="IOBOFF"
+3 DO ENDR^%ZISS
+4 WRITE IOBOFF
End DoDot:1
+5 QUIT
