Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCSRIG2

PRCSRIG2.m

Go to the documentation of this file.
  1. PRCSRIG2 ;SF-ISC/LJP/KMB/BMM-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ; 3/25/05 3:05pm
  1. V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;PRCSRI is the ordered item from the RIL. PX(3) is
  1. ;the ordered item from the Item Master File. PRCSV1 is
  1. ;the vendor from the RIL. X2 is the vendor listed for
  1. ;the item from the Item Master File. PX(1) holds Item
  1. ;Master File data, PX(2) holds Vendor File data.
  1. ;
  1. ;2/16/05 BMM per PRC*5.1*81, added code in ITEMG1 to capture
  1. ;data from two new fields in files 410 and 410.3:
  1. ;DM Doc ID (410 #17, 410.3 #6) and Date Needed (410 #18, 410.3 #7)
  1. ;added variables PRCVDN, PRCVDTN in ITEMG
  1. ;
  1. ;3/9/05 BMM per PRC*5.1*81, added sub UPDAUD to update the DM Audit
  1. ;file when a 2237 is created.
  1. ;
  1. ITEMG N STOP,PRCVDN,PRCVDTN S (PRCSRI,PRCSCS,STOP)="",(PRCSIT(1),K,BFLAG)=0
  1. S (PRCVDN,PRCVDTN)=""
  1. 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=""
  1. D:'BFLAG
  1. . D:$D(DA) ITEMG2 I $D(PRCSL),PRCSL L
  1. . 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=""
  1. . S PRCSTC=PRCSTC+PRCSCS Q
  1. D:BFLAG
  1. . I (PRCSIT>0) D
  1. . . S PRCSIT=PRCSIT-1
  1. . I (PRCSCT>0) D
  1. . . S PRCSCT=PRCSCT-1
  1. Q
  1. ;
  1. 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)
  1. ; If a discrepancy is found, set STOP=1, skip item
  1. 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
  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
  1. Q
  1. ;
  1. ITEMG3 I '$D(Z1)!'$D(Z2) D DVERR Q
  1. 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
  1. D:IOSL-$Y<7 HOLD,HDRG
  1. 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."
  1. ;PRC*5.1*81 update audit file for 2237 creation
  1. I 'K S PRCV2=$P(Y(0),"^",1)
  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:"")
  1. ;
  1. ;For a Supply Fund Requests adding code to derive BOC from NSN
  1. S K=K+1
  1. S X(3)=^PRC(441,PX(3),2,X2,0)
  1. S ITNSN=$E($P($G(^PRC(441,+PX(3),0)),U,5),1,4)
  1. I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) D
  1. . I $P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)'=2!($P(^(0),U,12)'=4) D
  1. . . S PRCSS=$S($P(PX(1),"^",10):$E($P(^PRCD(420.2,$P(PX(1),"^",10),0),"^"),1,30),1:"")
  1. . . Q
  1. . I $P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)=2!($P(^(0),U,12)=4) D
  1. . . S ITACCT=$$ACCT^PRCPUX1(ITNSN)
  1. . . S ITBOC=$S(ITACCT=1:2697,ITACCT=2:2698,ITACCT=3:2699,ITACCT=6:2699,ITACCT=8:2696,1:2699)
  1. . . S PRCSS=$E($P(^PRCD(420.2,ITBOC,0),U,1),1,30)
  1. . . Q
  1. . Q
  1. 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)
  1. ;PRC*5.1*81 add DM Doc ID, Date Needed to new line item
  1. ;
  1. I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D
  1. . Q:'$D(^PRCV(414.02,"C",PRCSNO))
  1. . S ^PRCS(410,DA,"IT",K,4)=PRCVDN_"^"_PRCVDTN
  1. . D UPDAUD(PRCV2)
  1. S ^PRCS(410,DA,"IT","B",K,K)="",^PRCS(410,DA,"IT","AB",K,K)="" S:PRCSS ^PRCS(410,"AD",PRCSS,DA)=""
  1. S PRCSCS=PRCSCS+($P(PX,"^",2)*($P(PX,"^",4))) G EX2
  1. ;
  1. 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)
  1. 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:"")
  1. S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
  1. S:PRC("ACC") $P(^PRCS(410,DA,3),"^",12)=$P(PRC("ACC"),"^",3)
  1. S ^PRCS(410,DA,4)=PRCSCS_"^"_PRCSD1_"^^^^^^"_PRCSCS,^(10)=K,^(7)=+PRC("PER")_"^"_$P(PRC("PER"),"^",3) S:'$D(^(11)) ^(11)=""
  1. S ^PRCS(410,"E",$E($P(PX(2),"^"),1,30),DA)="" S:PRCSCC ^PRCS(410,"AC",$E(PRCSCC,1,30),DA)=""
  1. 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)=""
  1. I IO'=IO(0)!$D(ZTQUEUED) S ^PRCS(410,"AQ",1,DA)="" L -^PRCS(410,DA) G END
  1. S PRC("QTR")=$P($P(^PRCS(410,DA,0),U),"-",3) D ASK^PRCSRIG1 L -^PRCS(410,DA)
  1. END K DA,PRCSDR,PRCSCQT,PRCSOCK,PRCSOCP,PRCSOCS,PRCST,PRCST1,PX,X2 Q
  1. ;
  1. 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=""
  1. Q
  1. ;
  1. HOLD Q:IO'=IO(0)!($D(ZTQUEUED)) W !,"Press return to continue: " R Z(1):DTIME Q
  1. EX K PX,X,X1,X2,Z S PRCSCT=PRCSCT-1 W $C(7),!,"Could not create a request" Q
  1. EX1 K X,X2 D KRL K PX Q
  1. EX2 K PRCSS,Y D KRL K PX(3),X(3) Q
  1. KRL Q
  1. ;
  1. UPDAUD(PRCV2) ;per PRC*5.1*81, update DM Audit file (#414.02) when 2237 is created
  1. ;PRCV2 - 2237's .01 value
  1. ;PRCVDYN - DM Doc ID for each item
  1. ;PRCSRID0 - RIL IEN from above
  1. ;
  1. ;first check DM flag
  1. ;Q:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
  1. N PRCVA,PRCVAC,PRCVC,PRCVDI,PRCVDYN,PRCVI,PRCVIEN,PRCVFCP
  1. N PRCVFL,PRCVJ,PRCVST,PRCVTMP,XMB
  1. S (PRCVC,PRCVDYN,PRCVIEN)="",PRCVFL=0
  1. ;get #items for RIL in 414.02
  1. ;F PRCVI=0:1 S PRCVC=$O(^PRCV(414.02,"C",PRCSNO,PRCVC)) Q:PRCVC=""
  1. ;for each item, update entry in 414.02
  1. ;F PRCVJ=1:1:PRCVI Q:PRCVFL=1 D
  1. S PRCVJ=PRCSRI D
  1. . S PRCVDYN=$$GET1^DIQ(410.31,PRCVJ_","_PRCSRID0_",",6)
  1. . ;
  1. . I PRCVDYN="" D Q
  1. . . ;DM Doc ID missing
  1. . . S PRCVTMP="PRCSRIG2",PRCVST=$P(PRCSNO,"-")
  1. . . S PRCVFCP=$P(PRCSNO,"-",4)
  1. . . S XMB(1)="creating a new 2237 record"
  1. . . S XMB(2)=" <missing>"
  1. . . S XMB(3)="DM doc ID value missing from line item in 2237"
  1. . . S ^TMP($J,"PRCSRIG2",1,0)=""
  1. . . S ^TMP($J,"PRCSRIG2",2,0)="2237 #: "_PRCV2
  1. . . S ^TMP($J,"PRCSRIG2",3,0)="Item #: "_PX(3)
  1. . . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
  1. . ;
  1. . S PRCVIEN=$O(^PRCV(414.02,"B",PRCVDYN,0))
  1. . S PRCVA(414.02,PRCVIEN_",",7)=PRCV2
  1. . D FILE^DIE("","PRCVA")
  1. . I $D(^TMP("DIERR",$J)) D Q
  1. . . ;error updating Audit file
  1. . . S PRCVTMP="PRCSRIG2",PRCVST=$P(PRCSNO,"-")
  1. . . S PRCVFCP=$P(PRCSNO,"-",4)
  1. . . S XMB(1)="updating the DynaMed IFCAP Interface Audit file (#414.02)"
  1. . . S XMB(2)=PRCVDYN
  1. . . S XMB(3)="unable to add update to Audit file entry"
  1. . . S ^TMP($J,"PRCSRIG2",1,0)=""
  1. . . S ^TMP($J,"PRCSRIG2",2,0)="2237 #: "_PRCV2
  1. . . S ^TMP($J,"PRCSRIG2",3,0)="Item #: "_PX(3)
  1. . . S ^TMP($J,"PRCSRIG2",4,0)="Error text: "_$G(^TMP("DIERR",$J,1,"TEXT",1))
  1. . . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
  1. Q
  1. DVERR D BLNKON
  1. W !,"There is an error with the default device defined in file 411.",!,"Please contact IRM before proceeding.",!
  1. D BLNKOFF
  1. S BFLAG=1
  1. Q
  1. ;
  1. BLNKON ;if terminal-type exists turn-on blink
  1. D:$D(IOST(0))
  1. . S X="IOBON"
  1. . D ENDR^%ZISS
  1. . W IOBON
  1. Q
  1. BLNKOFF ;if terminal-type exists turn-off blink
  1. D:$D(IOST(0))
  1. . S X="IOBOFF"
  1. . D ENDR^%ZISS
  1. . W IOBOFF
  1. Q