- 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 Jan 18, 2025@03:19:40 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 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 DPress return to continue:
- +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