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

PRCHE.m

Go to the documentation of this file.
  1. PRCHE ;WOIFO/LKG/DST-EDIT ROUTINES FOR SUPPLY SYSTEM ;1/25/17 13:03
  1. V ;;5.1;IFCAP;**1,28,39,81,63,144,163,198**;Oct 20, 2000;Build 6
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. EN1 ;ITEM FILE EDIT
  1. N PRCVDA
  1. I '$D(PRC("PARAM")) S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("PARAM"))
  1. W !! D DISP^PRCOSS1
  1. S DIC="^PRC(441,",DIC(0)="AEMQL",DLAYGO=441,DIC("S")="I (+Y<20000000)!$D(^XUSEC(""PRCHITEM SUPER"",DUZ))"
  1. S PRCHPO="",PRCHDA=-1 D ^DIC
  1. I Y>0 D
  1. . S PRCHDA=+Y,DIE=DIC,DA=+Y
  1. . S DR=$S($P($G(^PRC(441,DA,0)),U,15)="":"[PRCHITEM2]",$D(^XUSEC("PRCHITEM MASTER",DUZ)):"[PRCHITEM2]",$D(^XUSEC("PRCHITEM SUPER",DUZ)):"[PRCHITEM2]",1:"[PRCHITEM]")
  1. . I DR="[PRCHITEM]" D
  1. . . N PRCARR S PRCARR(1)="This item is a National Item File entry and you have"
  1. . . S PRCARR(2)="not been granted permission to edit the SHORT DESCRIPTION"
  1. . . S PRCARR(3)="and DESCRIPTION fields. You will not be able to edit these fields."
  1. . . D EN^DDIOL(.PRCARR)
  1. . D LCK D:$D(DA) ^DIE
  1. . ; Send ITEM master file updates info to DynaMed - **81**
  1. . S PRCVDA=$G(DA)
  1. S Y=PRCHDA K PRCHDA D Q K PRCHPO
  1. I Y<0 D CHECK^PRCOSS1 Q
  1. S (PRCHDA,DA,DA(1))=+Y I $O(^PRC(441,DA,4,0)) S DIC="^PRC(441,"_DA(1)_",4,",DIC(0)="QEMAN" D ^DIC S:$G(Y)'=-1 PRCVDA=PRCHDA I Y>0 S DA=+Y,DIE=DIC,DR=3 D ^DIE,Q
  1. ; S:$G(Y)'=-1 PRCVDA=PRCHDA
  1. ; If either ITEM record (and FCP fields) created or updated, and
  1. ; this site is a DynaMed Interface site
  1. I $G(PRCVDA),$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D ONECHK^PRCVIT(PRCVDA)
  1. I $P(^PRC(441,PRCHDA,0),U,10)="",$P(PRC("PARAM"),U,16)="Y" W $C(7),!!,"Warning--BOC is missing from this item--you should",!,"re-edit the item!!",!
  1. I $O(^PRCP(445,"AH",PRCHDA,""))]"" D BLDSEG^PRCPHLFM(3,PRCHDA,0) ; update supply stations
  1. K PRCHDA G EN1
  1. ;
  1. EN2 ;EDIT SITE PARAMETERS
  1. N X R !,"STATION NUMBER: ",X:DTIME Q:'$T!(X["^")!(X="")
  1. I "???"[X D EN2DSP G EN2
  1. I X'?3N W !,"Please enter a 3 digit number or '^' to exit. If attempting to enter substation information, please use 'Substation Enter/Edit'." G EN2
  1. I $D(^PRC(411,"B",X)) G EN2A
  1. N PRCX
  1. S PRCX=$O(^DIC(4,"D",X,"")) I PRCX="" W " ?? (That is not a valid Station Number)" G EN2
  1. S PRCX=$P($G(^DIC(4,PRCX,0)),U,1)
  1. D EN^DDIOL("Do you wish to add "_X_" ("_PRCX_") as a NEW station")
  1. S %=0 D YN^DICN I %'=1 G EN2
  1. ;
  1. EN2A S DIC="^PRC(411,",DIC(0)="LX",DR="[PRCHSITE]",DLAYGO=411 D DIE
  1. G EN2
  1. EN2DSP ;Display entries from file #411 if they are Ok in file #4. Otherwise,
  1. ;alert user about any incomplete entry.
  1. N PRCDA,PRCA,J,PRCIEN,PRCINSN
  1. S PRCDA=0 F J=2:0 S PRCDA=$O(^PRC(411,"B",PRCDA)) Q:PRCDA="" D
  1. . S PRCIEN=$O(^PRC(411,"B",PRCDA,"")) I $D(^PRC(411,PRCIEN,0))#10 D
  1. .. S PRCA=$P($G(^PRC(411,PRCIEN,0)),U,1) I PRCA?3N D
  1. ... S PRCA(J)=$J("",5)_PRCA_" "
  1. ... S PRCINSN=$O(^DIC(4,"D",PRCDA,"")) I PRCINSN']"" D Q
  1. .... W !,$C(7),?5,"ENTRY "_PRCDA_" IS NOT SET UP PROPERLY IN FILE #4. PLEASE CALL IRM"
  1. ... S PRCA(J)=PRCA(J)_$P($G(^DIC(4,PRCINSN,0)),U,1),J=J+1
  1. I J>2 S PRCA(1)=" ",PRCA(J)=" " D EN^DDIOL(.PRCA)
  1. Q
  1. EN3 ;EDIT VENDOR FILE
  1. S DIC="^PRC(440,",DIC(0)="AEMQL",DR="[PRCHVENDOR1]",DLAYGO=440 K PRCHPO D DIE Q:Y<0 G EN3
  1. ;
  1. EN5 ;ENTER A NEW P.O.
  1. D ST Q:'$D(PRC("SITE"))
  1. K PRCH("AM")
  1. EN50 D ENPO^PRCHUTL Q:'$D(PRCHPO) D LCK1 G:'$D(DA) EN50 D ^PRCHNPO L G EN50
  1. ;
  1. EN6 ;EDIT AN INCOMPLETE P.O.
  1. ;Edit an Incomplete Purchase Order created by 'New Purchase Order' option only
  1. D ST Q:'$D(PRC("SITE"))
  1. EN60 N FLG1 S FLG1=1 D PO Q:'$D(PRCHPO)
  1. D LCK1 G:'$D(DA) EN60 D ^PRCHNPO L G EN60
  1. ;
  1. EN8 ;DELETE A RECEIVING REPORT
  1. N FLG1 S FLG1=0 D ST Q:'$D(PRC("SITE")) G EN80^PRCHEF
  1. ;
  1. EN9 ;EDIT COMMON NUMBERING SERIES
  1. W ! S DIC="^PRC(442.6,",DIC(0)="AEMQL",DR=".01:99",DLAYGO=442.6 D DIE Q:Y<0 I $D(^PRC(442.6,+Y)),$P(^(+Y,0),U,5)="" W !!,$C(7),"NOTE: Since you have left the USING SECTION field empty, these",!,"numbers can only be used by P&C.",!
  1. G EN9
  1. ;
  1. EN10 ;EDIT SUPPLY EMPLOYEE INFORMATION
  1. K DIC,DA,X,Y S DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC
  1. G:Y<0 EN10Q
  1. S DA=+Y L +^VA(200,DA):0 E W $C(7),!,"ANOTHER USER IS EDITING THIS ENTRY!" G EN10
  1. K DR,DIE S DR="400;.135;.136;.151",DIE=DIC D ^DIE K DIE,DR
  1. L -^VA(200,DA)
  1. W !?5,"To edit the Signature Block Printed Name or title, Use TBOX",!
  1. G:'$D(DTOUT) EN10
  1. EN10Q K DIC,DIE,X,Y,DA,DR,DTOUT,DUOUT
  1. Q
  1. ;
  1. EN11 ;EDIT ADMINISTRATIVE CERTIFICATIONS
  1. S DIC="^PRC(442.7,",DIC(0)="AEMLQ",DR=".01:99",DLAYGO=442.7 D DIE Q:Y<0 G EN11
  1. ;
  1. EN12 ;EDIT DELIVERY DATE
  1. N PRCHP D ST Q:'$D(PRC("SITE"))
  1. ;S PRCHP("S")="$P($G(^(7)),U,2)>19,$P($G(^(7)),U,2)<30,($P($G(^(0)),U,2)=25!($S($D(PRCHNRQ):$P($G(^(0)),U,2)=8,1:$P($G(^(0)),U,2)<8)))"
  1. EN120 D PORQ I '$D(PRCHPO) G Q
  1. ;I X<20!(X>29) W " ??",$C(7) G EN120
  1. I "^20^21^22^23^24^25^26^27^28^29^32^34^39^44^46^47^"'[(U_X_U) W " ??",$C(7) G EN120
  1. D LCK1 G:'$D(DA) EN120
  1. S D0=DA,%=2,%B="",%A="REVIEW ORDER " D ^PRCFYN D:%=1 ^PRCHDP1
  1. W ! S PRCHDT=$P(^PRC(442,PRCHPO,0),U,10) S DA=PRCHPO,DIE="^PRC(442,",DR="[PRCHDEL]" D ^DIE S X=$P(^PRC(442,PRCHPO,0),U,10) I X,X'=PRCHDT,$P(^(0),U,20)="" S $P(^(0),U,20)=PRCHDT
  1. ; trigger bulletin for changed delivery date
  1. S PRCHDTT=$P(^PRC(442,PRCHPO,0),U,10) I PRCHDTT'=PRCHDT D ^PRCFACS2
  1. K PRCHDT D Q G EN120
  1. ;
  1. EN13 ; Delete 2237 option has been de-activated.
  1. ; See documentation for PRC*5*128.
  1. Q
  1. EN14 ;CREATE ADJUSTMENT VOUCHER
  1. D ST Q:'$D(PRC("SITE"))
  1. EN140 D PORQ Q:'$D(PRCHPO)
  1. N PRCOK,PRCARDIEN,PCARDID,PCARDNM
  1. I X=28!(X=33) W $C(7),!,"Adjustment Vouchers not allowed until after order has been Obligated!!" G EN140
  1. I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"Order has no Receiving Reports !",$C(7) G EN140
  1. S PRCOK=$$PCAUTH(DUZ,PRCHPO) I 'PRCOK D G EN140 ; check authorization level, must be holder, surrogate or approver
  1. . S PCARDIEN=$P(PRCOK,U,2),PCARDID=$P(^PRC(440.5,PCARDIEN,0),U,1) D
  1. .. ;PRC*5.1*163 alters unauthorized user display to card name and card holder
  1. .. S PCARDNM=$P(^PRC(440.5,PCARDIEN,0),U,8),PCARDNM=$P($G(^VA(200,PCARDNM,0)),U)
  1. .. W $C(7),!,"You are not authorized to make adjustments on P-Card:"
  1. .. W !,?6,$P(^PRC(440.5,PCARDIEN,0),U,11),", belonging to ",PCARDNM
  1. . D WRNGMSG ; send e-mail to card holder
  1. D ^PRCHAM4 G EN140
  1. ;
  1. EN15 ;ENTER LOG DEPARTMENTS TO FCP FILE (420)
  1. D ST Q:'$D(PRC("SITE"))
  1. EN150 S DIC="^PRC(420,"_PRC("SITE")_",1,",DIC(0)="AEMNQ"
  1. S DIC("A")="Select CONTROL POINT: ",D="B^C" D MIX^DIC1 G:Y<0 Q
  1. S DIE=DIC,DA(1)=PRC("SITE"),DA=+Y,DR=19 D ^DIE
  1. D:$P(^PRC(420,DA(1),1,DA,0),U,18)?1"11".E
  1. . W !,">>> You have just assigned a LOG DEPARTMENT that should only be used for Subsistence FCPs. If that is NOT true, please reassign it or you will be asked for a Food Group on every item purchased."
  1. G EN150
  1. ;
  1. DIE S PRCHDA=-1 D ^DIC
  1. I Y>0 S PRCHDA=+Y,DIE=DIC,DA=+Y D LCK I $D(DA) D ^DIE
  1. S Y=PRCHDA K PRCHDA G Q
  1. ;
  1. QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR
  1. ;
  1. Q K DA,DIC,DIE,DIK,DR,DLAYGO,D0,E,I,J,L,PRCHEX,PRCHPUSH,%,ROUTINE,CHECK L
  1. Q
  1. ;
  1. LCK1 S DIC="^PRC(442,"
  1. ;
  1. LCK L +@(DIC_DA_")"):DILOCKTM E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
  1. Q
  1. ;
  1. ST S PRCF("X")="S" D ^PRCFSITE
  1. Q
  1. ;
  1. PO S PRCHP("A")="P.O./REQ.NO.: "
  1. S PRCHP("S")=$S(FLG1:"$P($G(^(7)),U,2)<10,($P(^(0),U,2)<10!($P(^(0),U,2)=25&($P($G(^(23)),U,11)=""""))!($P(^(0),U,2)=26))",1:"$P(^(0),U,2)<10!($P(^(0),U,2)=25)!($P(^(0),U,2)=26)")
  1. S:$G(PRCHPC)=1 PRCHP("S")="$P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P($G(^(0)),U,2)=25,$P($G(^(23)),U,11)=""S"""
  1. S:$G(PRCHPC)=2 PRCHP("S")="$P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P($G(^(0)),U,2)=25,$P($G(^(23)),U,11)=""P"""
  1. S:$G(PRCHDELV) PRCHP("S")="$P($G(^(7)),U,2)<9,$P($G(^(23)),U,11)=""D"",$P(^(0),U,2)'=26"
  1. S:$G(PRCHPC)=3 PRCHP("S")="$P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P($G(^(0)),U,2)=25,$P($G(^(23)),U,11)=""P"""
  1. S:$G(PRCHPHAM) PRCHP("S")="$P($G(^(7)),U,2)<9,$P($G(^(23)),U,11)=""D"",$P(^(0),U,2)=26"
  1. D EN3^PRCHPAT
  1. Q
  1. ;
  1. PORQ S:$D(PRCHNRQ) PRCHP("A")="REQUISITION NO.: "
  1. I $G(PRCHAUTH)=1 S PRCHP("S")="$P($G(^(23)),U,11)=""P"""
  1. I $G(PRCHAUTH)=2 S PRCHP("S")="$P($G(^(23)),U,11)=""D"""
  1. D EN3^PRCHPAT
  1. Q
  1. ;
  1. PCAUTH(PRCUSER,PRCORDIEN) ; Determine if authorized to adjust PCard Tx
  1. ; parameter 1 = DUZ of current user
  1. ; parameter 2 = IEN of order in file #442
  1. ; returns 1 if this is not a Purchase Card transaction
  1. ; returns 2 if this is a PCard order and the user is Holder, Surrogate, Approving Official, or Alternate Approving Official
  1. ; returns 0 if this is a PCard order but the user is not one of the above
  1. ; for values 0 and 2, returns the purchase card IEN (#440.5) in the second up-arrow piece
  1. N PCARD,PCAUTH,PCXRF
  1. S PCAUTH=0
  1. S PCARD=$P($G(^PRC(442,PRCORDIEN,23)),U,8)
  1. I PCARD="" Q 1 ; no purchase card involved
  1. F PCXRF="C","E","F" I $D(^PRC(440.5,PCXRF,PRCUSER,PCARD)) S PCAUTH=2 ; pcard is ok for this user
  1. Q PCAUTH_U_PCARD
  1. ;
  1. WRNGMSG ;Send message to PCard holder when non-authorized user attempts to modify Tx
  1. N PRCHOLDER,XMDUZ,XMY,XMSUB,XMTEXT
  1. S PRCHOLDER=$P(^PRC(440.5,PCARDIEN,0),U,8) Q:PRCHOLDER=""
  1. K ^TMP("PRCHE",$J)
  1. S ^TMP("PRCHE",$J,1,0)="An attempt has been made to enter an Adjustment Voucher"
  1. S ^TMP("PRCHE",$J,2,0)="for the following Purchase Card Order:"
  1. S ^TMP("PRCHE",$J,3,0)="P-Card number: "_PCARDID_" Card Holder: "_$P(^VA(200,PRCHOLDER,0),U,1)
  1. S ^TMP("PRCHE",$J,4,0)="Transaction number: "_$P(Y(0,0),U,1)
  1. S ^TMP("PRCHE",$J,5,0)="User attempting access: "_$P(PRC("PER"),U,2)
  1. S ^TMP("PRCHE",$J,6,0)="This user is not on the card's authorized access list."
  1. S XMDUZ="IFCAP Purchase Card Monitor"
  1. S XMSUB="Unauthorized P-Card transaction report"
  1. S XMTEXT="^TMP(""PRCHE"","_$J_","
  1. S XMY(PRCHOLDER)=""
  1. D ^XMD
  1. K ^TMP("PRCHE",$J)
  1. Q