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