Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m

    r613 r623  
    1 PRCHMA  ;WISC/AKS-Amend to PO, req ;6/10/96  14:07
    2         ;;5.1;IFCAP;**21,79,100,113**;Oct 20, 2000;Build 4
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4 REQ     N PRCHREQ
    5         S PRCHREQ=1
    6 PO      N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
    7         N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
    8         N PRCFL,MSG
    9 LOOP    D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0
    10         ; See routine PRCHAMXA for information on variable PRCHNORE and undefined DIK, var PRCHPO is the basic premise of locks applied to amendments
    11         S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
    12         ; Lock simultaneous entry of users in amend. module for the same record.  Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start
    13         ; the process(AMENDNO) of amending the record we must have var PRCHPO.
    14         S PRCFL=0
    15         W !! D GETPO^PRCHAMU
    16         ; If no record is selected or time-out or up-arrow out then exit without unlocking a record.
    17         I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1
    18         I PRCFL=1 G LOOP
    19         I '$G(PRCHPO)!$D(FIS) G EXIT
    20         I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G EXIT
    21         D AMENDNO^PRCHAMU G:'$G(PRCHAM) EXIT
    22         S PRCHAMT=0,FL=0
    23         D INFO^PRCHAMU G:$D(PRCHAV)!ER EXIT
    24         S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB
    25         I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX
    26         I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
    27         I PRCHNEW=111&($G(CAN)=0) D REV
    28         I $G(CAN)>0 D ENC G:ER EXIT I $G(NOCAN)=0 S DA(1)=PRCHPO,DA=PRCHAM,PRCHAMDA=34,PRCHX=X,X=0 D EN8^PRCHAMXB S X=PRCHX G CAN1
    29 ASK     K NOCAN,DTOUT,DUOUT,REPONUM D ASK^PRCHAMU
    30         G:$D(REPONUM)=1 CAN1
    31         I ER=0 D  G:'$D(REPO)&($G(CAN)=0) ASK
    32         . D @ROU
    33         . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q
    34         . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q
    35         I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
    36         I $D(DTOUT)!($D(DUOUT)) G EXIT
    37         I $G(NOCAN)=1 G ASK
    38         G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT
    39 CAN1    S BFLAG=0
    40         S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)'=6 BFLAG=1
    41         I $P($G(^PRC(443.6,PRCHPO,1)),U,7)=6  D
    42         .S THISHLD=0
    43         .F  S THISHLD=$O(^PRC(443.6,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1)  D
    44         ..S:$P($G(^PRC(443.6,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1
    45         .Q:BFLAG=1
    46         .S THISHLD=0
    47         .F  S THISHLD=$O(^PRC(442,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1)  D
    48         ..S:$P($G(^PRC(442,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1
    49         W:BFLAG=0 !,"This is now a contract order.  You must add a contract to this orders item(s)",!,"before approving the amendment.",!
    50         G:BFLAG=0 EXIT
    51         D:BFLAG=1 UPDATE^PRCHAMU G:$D(Y) EXIT
    52 CHK     I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT
    53         I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D
    54         .S POSTAT=+$G(^PRC(443.6,PRCHPO,7))
    55         .S AMSTAT=$S(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT)
    56         .S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U)
    57         .S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT"
    58         .D ^DIE K DIE,AMSTAT,POSTAT
    59         K PRCHER S LCNT=1 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status.",! S PRCHER=""
    60         I $P($G(^PRC(443.6,PRCHPO,2,0)),U,4)>0 D  G:$D(PRCHER) ERR
    61         .N END S END=IOSL-3
    62         .S PRCH=0 F  S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0)  D
    63         ..S PRCHLN=$G(^PRC(443.6,PRCHPO,2,PRCH,0)) D  Q
    64         ...I $P(PRCHLN,U,4)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing BOC !",$C(7) S PRCHER="",LCNT=LCNT+2
    65         ...I $G(PRCHAUTH)'=1,$G(PRCHREQ) I $P(PRCHLN,U,13)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing NSN!",$C(7) S PRCHER="",LCNT=LCNT+2
    66         ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2
    67         ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2
    68         ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to make sure that a contract number is entered
    69         ...D PCD^PRCHMA1
    70         ...Q
    71         ..Q
    72         .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1
    73         .Q
    74         D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT
    75         I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER=""
    76         I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1
    77         I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER)
    78         I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D  I $G(ERROR) S PRCHER="" K ERROR,FILE
    79         .D ^PRCHSF3
    80         .D ADJ1^PRCHCD0
    81         .D LIMIT^PRCHCD0
    82         ;
    83 ERR     I $D(PRCHER) W !!,?5,"This amendment needs to be re-edited before it can be signed.",!,"**REMINDER** Unsigned amendments are deleted from the system after 7 days." D:LCNT>20  G EXIT
    84         .N DIR S DIR(0)="E" D ^DIR
    85         .Q
    86         D REV:'$G(PRCPROST),APP G:%'=1 EXIT
    87         S PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM) G:PRCHRET'=1 EXIT
    88         S RETURN="" D COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN)
    89         G:RETURN'=1 EXIT
    90         S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE
    91         D ^PRCHSF3
    92         I $P(^PRC(443.6,PRCHPO,0),U,2)'=25 S PRCHQ="^PRCHPAM8",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
    93         I '($P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^PRC(443.6,PRCHPO,0),U,19)=2)) D
    94         . W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
    95         . S FILE=443.6 D:$D(PRCHPO) CHECK^PRCHSWCH
    96         . I $G(PRCHOBL)=1 D SUPP^PRCFFM2M K FILE Q
    97         . I $G(PRCHOBL)=2 S PRCOPODA=PRCHPO D ^PRCOEDI K FILE,PRCOPODA Q
    98         I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 D  S:$G(PRCPROST) PRCPROST=PRCPROST+0.9 G EXIT
    99         .S MTOPDA=1
    100         .D SUPP^PRCFFM2M ;I $P($G(^PRC(442,PRCHPO,23)),"^",11)="P" W !!,"...now generating the PHA transaction..." S PRCOPODA=PRCHPO D NEW^PRCOEDI K PRCOPODA W !!
    101         .S PPTEMP=0,PP410=$P($G(^PRC(442,PRCHPO,0)),"^",12),PPAMT=$P($G(^PRC(442,PRCHPO,0)),"^",16) I PP410'="" S PPTEMP=$P($G(^PRCS(410,PP410,4)),"^",8),PPTEMP=-(PPAMT-PPTEMP)
    102         .I $P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S PPTEMP=PPAMT,PPAMT=0
    103         .I PP410'="" S $P(^PRCS(410,PP410,4),"^",3)=0
    104         .I PP410'="" S $P(^PRCS(410,PP410,4),"^",8)=PPAMT
    105         .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2),$P(PRCOAMT,"^",5)=PPTEMP D EBAL^PRCSEZ(PRCOAMT,"O")
    106         .I PP410'="",$P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S $P(^PRCS(410,PP410,0),"^",2)="CA" D ERS410^PRC0G(PP410_"^C")
    107         .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE
    108         .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
    109         .; Update file #440.5 after amendment has been approved. Consider orders created and amended in the same month and year and the user either
    110         .; cancels the order or enters other type of amendment that changes the final amount of the order. No credit is given for orders from a
    111         .; previous month and year. DT is the current date, system-supplied.
    112         .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8)
    113         .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3)
    114         .S PRCCHG=$P($G(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3)
    115         .S POSTAT=$P($G(^PRC(442,PRCHPO,7)),"^",2)
    116         .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT'=45 D
    117         ..I $G(PPAMT)<0 Q
    118         ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PRCCHG)
    119         ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0
    120         .;
    121         .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT=45 D
    122         ..I $G(PPTEMP)<0 Q
    123         ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)-$G(PPTEMP)
    124         ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0
    125         .;
    126         .; Update file #440.5 only if the amendment is for non-cancellation
    127         .; of an order from a previous month regardless of the year.
    128         .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)'=$E(DT,1,5),POSTAT'=45 D
    129         ..I $G(PPAMT)<0 Q
    130         ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PPAMT)
    131         .K DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410
    132         S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1
    133         I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
    134         D SOURCE^PRCHAMU:$G(SCE)
    135         G EXIT
    136 ENC     S ER=0
    137         D CAN^PRCHMA3
    138         I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q
    139         I $G(PRCHAUTH)=1 D PAID^PRCHINQ I $G(PAID)=1 D  S ER=1 Q
    140         . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7)
    141         S %="",%A="     SURE YOU WANT TO CANCEL THIS ORDER ",%B="" D ^PRCFYN
    142         I %'=1 W ?40,"    <NOTHING CANCELLED>" D  Q
    143         .I $D(PRCHAU) D
    144         ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
    145         ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)=""
    146         .S NOCAN=1
    147         S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))"
    148         D ^DIE K DIE,DA,DR S CAN=1
    149         S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W !
    150         QUIT
    151 APP     S %A="   Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN
    152         Q
    153 REV     N PRCH
    154         S %=1,%B="",%A="   Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN
    155         I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM
    156         Q
    157 EXIT    L -^PRC(442,PRCENTRY)
    158 EXIT1   K ERROR,FIS,REPO,DEL
    159         QUIT:$G(PRCPROST)
    160         I $G(OUT)'=1 G LOOP
    161         QUIT
    162 FLAG    I $G(FLAG)=1 K FLAG Q
    163         Q
    164 NOSIGN  S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
    165 NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@"
    166         D ^DIE K DIE,DA,DR
    167         Q
    168 TOP     ;PAUSE AT BOTTOM OF SCREEN
    169         N DIR S DIR(0)="E"
    170         D ^DIR
    171         S LCNT=1
    172         Q
     1PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96  14:07
     2 ;;5.1;IFCAP;**21,79,100**;Oct 20, 2000
     3 ;Per VHA Directive 10-93-142, this routine should not be modified.
     4REQ ;Req.
     5 N PRCHREQ
     6 S PRCHREQ=1
     7PO ;PO
     8 N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON
     9 N A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
     10 N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND
     11 N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
     12 N PRCFL,MSG
     13LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0
     14 ;
     15 ; See routine PRCHAMXA for information on variable PRCHNORE and for
     16 ; incidence of undefined DIK variable errors.
     17 ; The var PRCHPO is the basic premise of locks applied to amendments.
     18 ; Anytime amend module is accessed add +lock & save po# in PRCENTRY.
     19 ;
     20 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
     21 ;
     22 ; Lock simultaneous entry of users in amend. module for the same record.
     23 ; Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start
     24 ; the process(AMENDNO) of amending the record we must have var PRCHPO.
     25 ;
     26 S PRCFL=0
     27 W !! D GETPO^PRCHAMU
     28 ; If no record is selected or time-out or up-arrow out then exit
     29 ; without unlocking a record.
     30 I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1
     31 I PRCFL=1 G LOOP
     32 I '$G(PRCHPO)!$D(FIS) G EXIT
     33 I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR.",! G EXIT
     34 D AMENDNO^PRCHAMU G:'$G(PRCHAM) EXIT
     35 S PRCHAMT=0,FL=0
     36 D INFO^PRCHAMU G:$D(PRCHAV)!ER EXIT
     37 S X=$P($G(^PRC(443.6,PRCHPO,0)),U,16) D EN2^PRCHAMXB
     38 I PRCHNEW="" S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=0,PRCHAMDA=34 D EN8^PRCHAMXB S X=PRCHX
     39 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
     40 I PRCHNEW=111&($G(CAN)=0) D REV
     41 I $G(CAN)>0 D ENC G:ER EXIT I $G(NOCAN)=0 S DA(1)=PRCHPO,DA=PRCHAM,PRCHAMDA=34,PRCHX=X,X=0 D EN8^PRCHAMXB S X=PRCHX G CAN1
     42ASK K NOCAN,DTOUT,DUOUT,REPONUM D ASK^PRCHAMU
     43 G:$D(REPONUM)=1 CAN1
     44 I ER=0 D  G:'$D(REPO)&($G(CAN)=0) ASK
     45 . D @ROU
     46 . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q
     47 . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q
     48 ;
     49 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
     50 I $D(DTOUT)!($D(DUOUT)) G EXIT
     51 I $G(NOCAN)=1 G ASK
     52 G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT
     53CAN1 D UPDATE^PRCHAMU G:$D(Y) EXIT
     54CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT
     55 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D
     56 .S POSTAT=+$G(^PRC(443.6,PRCHPO,7))
     57 .S AMSTAT=$S(POSTAT=25:26,POSTAT=30:31,POSTAT=40:71,POSTAT=6:83,POSTAT=84:85,POSTAT=86:87,POSTAT=90:91,POSTAT=92:93,POSTAT=94:95,POSTAT=96:97,POSTAT=45:45,1:POSTAT)
     58 .S AMSTAT=$P(^PRCD(442.3,AMSTAT,0),U)
     59 .S DIE="^PRC(443.6,PRCHPO,6,",DA(1)=PRCHPO,DA=PRCHAM,DR="9//^S X=AMSTAT"
     60 .D ^DIE K DIE,AMSTAT,POSTAT
     61 K PRCHER S LCNT=1 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status.",! S PRCHER=""
     62 I $P($G(^PRC(443.6,PRCHPO,2,0)),U,4)>0 D  G:$D(PRCHER) ERR
     63 .N END S END=IOSL-3
     64 .S PRCH=0 F  S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0)  D
     65 ..S PRCHLN=$G(^PRC(443.6,PRCHPO,2,PRCH,0)) D  Q
     66 ...I $P(PRCHLN,U,4)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing BOC !",$C(7) S PRCHER="",LCNT=LCNT+2
     67 ...I $G(PRCHAUTH)'=1,$G(PRCHREQ) I $P(PRCHLN,U,13)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing NSN!",$C(7) S PRCHER="",LCNT=LCNT+2
     68 ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2
     69 ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2
     70 ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to
     71 ...; make sure that a contract number is entered
     72 ...D PCD^PRCHMA1
     73 ...Q
     74 ..Q
     75 .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1
     76 .Q
     77 ;PRC*5.1*100: check line items without an FSC or PSC
     78 D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT
     79 I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER=""
     80 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1
     81 I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER)
     82 ;
     83 ; Change below to allow checks for monthly limits in file #440.5 before
     84 ; completion of the amendment.
     85 ;
     86 I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D  I $G(ERROR) S PRCHER="" K ERROR,FILE
     87 .D ^PRCHSF3
     88 .D ADJ1^PRCHCD0
     89 .D LIMIT^PRCHCD0
     90 ;
     91ERR I $D(PRCHER) W !!,?5,"This amendment needs to be re-edited before it can be signed.",!,"**REMINDER** Unsigned amendments are deleted from the system after 7 days." D:LCNT>20  G EXIT
     92 .N DIR S DIR(0)="E" D ^DIR
     93 .Q
     94 D REV:'$G(PRCPROST),APP G:%'=1 EXIT
     95 S PRCHRET=$$ASK^PRCHAM8(PRCHPO,PRCHAM) G:PRCHRET'=1 EXIT
     96 S RETURN="" D COMMIT^PRCHAM8(PRCHPO,PRCHAM,.RETURN)
     97 G:RETURN'=1 EXIT
     98 S DIE="^PRC(443.6,"_PRCHPO_",6,",DA=PRCHAM,DR="15///TODAY+4" D ^DIE
     99 D ^PRCHSF3
     100 I $P(^PRC(443.6,PRCHPO,0),U,2)'=25 S PRCHQ="^PRCHPAM8",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
     101 I '($P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^PRC(443.6,PRCHPO,0),U,19)=2)) D
     102 . W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM8",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
     103 . S FILE=443.6 D:$D(PRCHPO) CHECK^PRCHSWCH
     104 . I $G(PRCHOBL)=1 D SUPP^PRCFFM2M K FILE Q
     105 . I $G(PRCHOBL)=2 S PRCOPODA=PRCHPO D ^PRCOEDI K FILE,PRCOPODA Q
     106 I $P($G(^PRC(443.6,PRCHPO,0)),U,2)=25 D  S:$G(PRCPROST) PRCPROST=PRCPROST+0.9 G EXIT
     107 .S MTOPDA=1
     108 .D SUPP^PRCFFM2M ;I $P($G(^PRC(442,PRCHPO,23)),"^",11)="P" W !!,"...now generating the PHA transaction..." S PRCOPODA=PRCHPO D NEW^PRCOEDI K PRCOPODA W !!
     109 .S PPTEMP=0,PP410=$P($G(^PRC(442,PRCHPO,0)),"^",12),PPAMT=$P($G(^PRC(442,PRCHPO,0)),"^",16) I PP410'="" S PPTEMP=$P($G(^PRCS(410,PP410,4)),"^",8),PPTEMP=-(PPAMT-PPTEMP)
     110 .I $P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S PPTEMP=PPAMT,PPAMT=0
     111 .I PP410'="" S $P(^PRCS(410,PP410,4),"^",3)=0
     112 .I PP410'="" S $P(^PRCS(410,PP410,4),"^",8)=PPAMT
     113 .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2),$P(PRCOAMT,"^",5)=PPTEMP D EBAL^PRCSEZ(PRCOAMT,"O")
     114 .I PP410'="",$P($G(^PRC(442,PRCHPO,7)),"^",2)=45 S $P(^PRCS(410,PP410,0),"^",2)="CA" D ERS410^PRC0G(PP410_"^C")
     115 .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE
     116 .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
     117 .;
     118 .; Update file #440.5 after amendment has been approved. Consider orders
     119 .; created and amended in the same month and year and the user either
     120 .; cancels the order or enters other type of amendment that changes the
     121 .; final amount of the order. No credit is given for orders from a
     122 .; previous month and year. DT is the current date, system-supplied.
     123 .;
     124 .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8)
     125 .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3)
     126 .S PRCCHG=$P($G(^PRC(442,PRCHPO,6,PRCAMD,0)),U,3)
     127 .S POSTAT=$P($G(^PRC(442,PRCHPO,7)),"^",2)
     128 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT'=45 D
     129 ..I $G(PPAMT)<0 Q
     130 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PRCCHG)
     131 ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0
     132 .;
     133 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)=$E(DT,1,5),POSTAT=45 D
     134 ..I $G(PPTEMP)<0 Q
     135 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)-$G(PPTEMP)
     136 ..I $P($G(^PRC(440.5,PRCHCD,2)),U)<0 S $P(^PRC(440.5,PRCHCD,2),U)=0
     137 .;
     138 .; Update file #440.5 only if the amendment is for non-cancellation
     139 .; of an order from a previous month regardless of the year.
     140 .I $E($P(^PRC(442,PRCHPO,1),U,15),1,5)'=$E(DT,1,5),POSTAT'=45 D
     141 ..I $G(PPAMT)<0 Q
     142 ..S $P(^PRC(440.5,PRCHCD,2),U)=$P($G(^PRC(440.5,PRCHCD,2)),U)+$G(PPAMT)
     143 .K DA,MTOPDA,PRCAMD,PRCHCD,PRCCHG,PRCNODE,POSTAT,PPTEMP,PPAMT,PP410
     144 S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1
     145 I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
     146 ;
     147 D SOURCE^PRCHAMU:$G(SCE)
     148 G EXIT
     149 ;
     150ENC ;Can
     151 S ER=0
     152 D CAN^PRCHMA3
     153 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q
     154 I $G(PRCHAUTH)=1 D PAID^PRCHINQ I $G(PAID)=1 D  S ER=1 Q
     155 . W !,?5,"THERE HAS BEEN PAYMENT MADE FOR THIS PURCHASE CARD ORDER, CANNOT CANCEL !",$C(7)
     156 S %="",%A="     SURE YOU WANT TO CANCEL THIS ORDER ",%B="" D ^PRCFYN
     157 I %'=1 W ?40,"    <NOTHING CANCELLED>" D  Q
     158 .I $D(PRCHAU) D
     159 ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
     160 ..S $P(^PRC(443.6,PRCHPO,6,PRCHAM,1),U,4)=""
     161 .S NOCAN=1
     162 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9////^S X=$O(^PRCD(442.3,""C"",45,0))"
     163 D ^DIE K DIE,DA,DR S CAN=1
     164 S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W !
     165 QUIT
     166APP ;App,pr
     167 S %A="   Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN
     168 Q
     169REV ;Rev
     170 N PRCH
     171 S %=1,%B="",%A="   Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN
     172 I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM
     173 Q
     174EXIT ;Ex
     175 L -^PRC(442,PRCENTRY)
     176EXIT1 K ERROR,FIS,REPO,DEL
     177 QUIT:$G(PRCPROST)
     178 I $G(OUT)'=1 G LOOP
     179 QUIT
     180 ;
     181FLAG ;
     182 I $G(FLAG)=1 K FLAG Q
     183 Q
     184NOSIGN ;
     185 S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
     186NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@"
     187 D ^DIE K DIE,DA,DR
     188 Q
     189TOP ;PAUSE AT BOTTOM OF SCREEN
     190 N DIR S DIR(0)="E"
     191 D ^DIR
     192 S LCNT=1
     193 Q
Note: See TracChangeset for help on using the changeset viewer.