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/PRCHNPO3.m

    r613 r623  
    1 PRCHNPO3        ;WISC/RSD/RHD/SC-CONT. OF NEW PO ; 4/23/99 1:39pm
    2 V       ;;5.1;IFCAP;*112*;Oct 20, 2000;Build 2
    3         ;Per VHA Directive 2004-038, this routine should not be modified.
    4         ;
    5         S PRCHSZ=1
    6         ;
    7 EN0     W !,"Enter a 2237 reference number. The FCP,Cost Center,Service,Delivery",!?3,"Location" W:PRCHSZ " and Line Items" W " will be transferred into this Purchase Order."
    8         W !!,?10,"The 2237 Fiscal Year and Quarter must be earlier or same",!,?10,"as the P.O. Date Fiscal Year and Quarter.",!
    9         I $O(^PRC(442,PRCHPO,13,0)) W !?3,"This Purchase Order already contains:" F I=0:0 S I=$O(^PRC(442,PRCHPO,13,I)) Q:'I  I $D(^PRCS(410,I,0)) W !?3,$P(^(0),U,1)
    10         I '$D(^PRC(442,PRCHPO,1)),$P(^(1),U,15)="" W !!,"Cannot precede without a P.O. DATE" G Q
    11         ;
    12 EN      K PRCHSY S PRCHD=$P(^PRC(442,PRCHPO,1),U,15),PRCHSP=$P(^(0),U,12)
    13         ;screen-out the Issue Book order if status is 65--Assigned to PPM Clerk, for nois MWV-0293-20011
    14         S DIC="^PRC(443,"
    15         S DIC(0)="AQEMZ"
    16         I $G(PRCHZZZ9)'=1 S DIC("S")="I $P(^(0),U,3)]"""",""65,72""'[$P(^(0),U,7),$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6"
    17         I $G(PRCHZZZ9)=1 S DIC("S")="I $P(^(0),U,3)]"""",$P(^(0),U,7)=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6"
    18         D ^DIC K DIC G:Y<0 Q S PRCHSY=+Y,PRCHSY(0)=Y(0),Y(0)=^PRCS(410,+Y,0),PRCHSX=$P(Y(0),U,1) I $D(^(1)),$P(^(1),U,3)="EM" W $C(7),!,"*** EMERGENCY ***"
    19         ;I $D(^PRCS(410,+Y,0)),$P(^(0),U,4)=5 W !?3,"This is an Issue Book Order, and it can't be processed into a Purchase Order." Q
    20         ;
    21 EN1     S PRCHRFQT=$$DATE^PRC0C($P(Y(0),"^",11),"I"),PRCHRFQT=$P(PRCHRFQT,U,1,2)
    22         S PRC("BBFY")=+$$DATE^PRC0C($P(^PRCS(410,+Y,3),"^",11),"I")
    23         ;S PRCHCFQT=$$DATE^PRC0C($P(^PRC(420,PRC("SITE"),0),U,9),"I"),PRCHCFQT=$P(PRCHCFQT,U,1,2)
    24         S PRCHPFQT=$$DATE^PRC0C($P(^PRC(442,PRCHPO,1),"^",15),"I"),PRCHPFQT=$P(PRCHPFQT,U,1,2)
    25         I PRCHRFQT'=PRCHPFQT W !,?10,"The Fiscal Year and Quarter on this 2237 is not",!,?10,"compatible with the PO Date.",!,$C(7) K PRCHRFQT,PRCHPFQT G EN
    26         K PRCHRFQT,PRCHPFQT
    27         I $P(^PRC(442,PRCHPO,0),U,3)]"",+$P(^PRC(442,PRCHPO,0),U,3)'=+$P(^PRCS(410,PRCHSY,3),U,1) W !?3,"Fund Control Point for this 2237 doesn't match the existing FCP in P.O.",$C(7) G EN
    28         I $P(^PRC(442,PRCHPO,0),U,5)]"",+$P(^PRC(442,PRCHPO,0),U,5)'=+$P(^PRCS(410,PRCHSY,3),U,3) W !?3,"Cost Center for this 2237 doesn't match the Cost Center in P.O.",$C(7) G EN
    29         S X="",Z="" I $D(^PRC(420,PRC("SITE"),1,+^PRCS(410,PRCHSY,3),0)) S X=$P(^(0),U,12),Z=$P(^(0),U,18)
    30         I X'=2 S:Z'="" $P(^PRC(442,PRCHPO,17),U,1)=$E(Z,1,3) I Z="" W $C(7),!?3,"Fund Control point is missing LOG Department Number!!" G EN
    31         I X I PRCHN("MP")=4!((X=3)&(PRCHN("MP")=3)) S Y=$P(^PRCD(442.5,PRCHN("MP"),0),U,1) W $C(7),!?3,"This Fund Control Point is not valid for a "_Y_" order." G EN
    32         S EN=0 I $D(^PRC(411,"UP",PRC("SITE"))) D  G EN:EN=1
    33         .I $P($G(^PRCS(410,+Y,0)),U,10)="" W $C(7),!!?3,"This 2237 does not have a substation.",! S EN=1 Q
    34         .I $P($G(^PRCS(410,+Y,0)),U,10)'=$P($G(^PRC(442,PRCHPO,23)),U,7) W $C(7),!!?3,"The substation on this 2237 does not match the substation entered",!?3,"on this "_$S($D(PRCHNRQ):"requisition.",1:"purchase order."),! S EN=1
    35         D SPRMK^PRCHNPO6
    36         ;
    37 N       Q:'PRCHSZ  K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1
    38         W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX)
    39         F  Q:'$F(PRCHX,",,")  S PRCHX=$P(PRCHX,",,",1)_","_$P(PRCHX,",,",2,99) ; *112 remove consecutive commas
    40         S:$E(PRCHX)="," PRCHX=$E(PRCHX,2,$L(PRCHX)) ; *112 remove leading comma
    41         S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) ; *112 remove trailing comma
    42         F I=1:1 S X=$P(PRCHX,",",I) Q:X=""  I +X'=X S X(1)=$P(X,":",1),X(2)=$P(X,":",2) K:+X(1)'=X(1)!(+X(2)'=X(2))!'(X(1)<X(2)) PRCHX Q:'$D(PRCHX)  S $P(PRCHX,",",I)=X(1)_":1:"_X(2)
    43         I '$D(PRCHX) W " ??",$C(7) G N
    44         X "F I="_PRCHX_" D IT Q:'$O(^TMP($J,""PRCHS"",0))" G:'$O(^TMP($J,"PRCHS",0)) N S ^(0)=J
    45         ;
    46 3       G 2:J=+^PRCS(410,PRCHSY,10),Q:'$O(^TMP($J,"PRCHS",0)) W !,"A new 2237 will now be created with the following items: " F K=0:0 S K=$O(PRCHSIT(K)) Q:'K  W !?3,PRCHSIT(K)
    47         S %A="     Do you wish to proceed",%B="",%=1 D ^PRCFYN I %'=1 G N
    48         Q:$D(PRCHG)  S PRCHSIT=J,PRCHS=PRCHSY D WAIT^DICD,^PRCHSP D:PRCHSY=-1 ERR D:PRCHSY=-3 ERR1 D:PRCHSY=-2 ERR2 G:PRCHSY<0 EN D EN4^PRCHNPO2
    49         G EN
    50         ;
    51 1       S I=0 F  S I=$O(^PRCS(410,PRCHSY,"IT","AB",I)) Q:I=""  D IT
    52         S:$O(^TMP($J,"PRCHS",0)) ^(0)=J
    53         G 3
    54         ;
    55 2       Q:$D(PRCHG)  S PRCHSIT=J,PRCHS="" D WAIT^DICD,^PRCHSP1
    56         D:PRCHSY=-1 ERR
    57         D:PRCHSY=-2 ERR2
    58         D:PRCHSY=-3 ERR1
    59         G:PRCHSY<0 EN
    60         D EN4^PRCHNPO2
    61         G EN
    62         ;
    63 IT      I $D(^PRCS(410,PRCHSY,"IT","AB",I)),$D(^PRCS(410,PRCHSY,"IT",$O(^(I,0)),0)) S ^TMP($J,"PRCHS",I)="",J=J+1 S:$L(PRCHSIT(K))>72 K=K+1,PRCHSIT(K)="" S PRCHSIT(K)=PRCHSIT(K)_I_"," Q
    64         W !?5,"** ",I," IS AN INVALID LINE ITEM NUMBER",$C(7) K ^TMP($J,"PRCHS")
    65         Q
    66         ;
    67 HLP     W !?3,"ENTER A LINE ITEM NUMBER IN THE FOLLOWING FORMAT:  1,2,3,4 OR 1:4 ",!?5," OR ENTER 'A' FOR ALL LINE ITEMS " S DIC="^PRCS(410,+PRCHSY,""IT"",",DIC(0)="E",X="??",D="AB" D IX^DIC K DIC G N
    68         Q
    69         ;
    70 Q       S (DA,D0)=PRCHPO K C,DIC,X,PRCH,PRCHD,PRCHS,PRCHSP,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHSZ,PRCHX,^TMP($J,"PRCHS"),EN,Y
    71         S:0 Y="@1" ;<<< Removed the SET Y="@1" from this routine and put it into the template PRCH2138. <<<
    72         Q
    73         ;
    74 DT      S X="T" D ^%DT S DT=Y
    75         Q
    76         ;
    77 EN2     ;CHECKS FCP PARAMETERS & SET Y, CALLED FROM PRCH2138,PRCHIFREG
    78         S PRCHN("SFC")=+$P(^PRC(442,DA,0),"^",19)
    79         S $P(^PRC(442,DA,18),U,2)=$S((PRCHN("SFC")=2)&(PRCHN("MP")=12):"B",PRCHN("SFC")=2:"A",PRCHN("SFC")=3:"J",1:"")
    80         Q
    81         ;
    82 ERR     W !,$C(7),"Cannot get a transaction number at this time for the new transaction being split",!,"out.  Try again later!"
    83         Q
    84         ;
    85 ERR1    W !,$C(7),"Cannot find the 2237 you selected in file 410."
    86         Q
    87         ;
    88 ERR2    W !,$C(7),"Not continuing with this 2237."
    89         Q
    90         ;
    91 VENMSG  ;message to alert users that vendors don't match and that IMF will
    92         ;be updated.
    93         W !!,"NOTE-Vendors on PO and 2237 don't match.  If you proceed IMF info"," will be used.  If there is no IMF entry for the item for this vendor one will ","be created."
    94         N % S %=0
    95         W !,"Would you like to proceed" D YN^DICN W !! I %'=1 S PRCHFLG=1
    96         Q
     1PRCHNPO3 ;WISC/RSD/RHD/SC-CONT. OF NEW PO ; 4/23/99 1:39pm
     2V ;;5.1;IFCAP;;Oct 20, 2000
     3 ;Per VHA Directive 10-93-142, this routine should not be modified.
     4 ;
     5 S PRCHSZ=1
     6 ;
     7EN0 W !,"Enter a 2237 reference number. The FCP,Cost Center,Service,Delivery",!?3,"Location" W:PRCHSZ " and Line Items" W " will be transferred into this Purchase Order."
     8 W !!,?10,"The 2237 Fiscal Year and Quarter must be earlier or same",!,?10,"as the P.O. Date Fiscal Year and Quarter.",!
     9 I $O(^PRC(442,PRCHPO,13,0)) W !?3,"This Purchase Order already contains:" F I=0:0 S I=$O(^PRC(442,PRCHPO,13,I)) Q:'I  I $D(^PRCS(410,I,0)) W !?3,$P(^(0),U,1)
     10 I '$D(^PRC(442,PRCHPO,1)),$P(^(1),U,15)="" W !!,"Cannot precede without a P.O. DATE" G Q
     11 ;
     12EN K PRCHSY S PRCHD=$P(^PRC(442,PRCHPO,1),U,15),PRCHSP=$P(^(0),U,12)
     13 ;screen-out the Issue Book order if status is 65--Assigned to PPM Clerk, for nois MWV-0293-20011
     14 S DIC="^PRC(443,"
     15 S DIC(0)="AQEMZ"
     16 I $G(PRCHZZZ9)'=1 S DIC("S")="I $P(^(0),U,3)]"""",""65,72""'[$P(^(0),U,7),$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6"
     17 I $G(PRCHZZZ9)=1 S DIC("S")="I $P(^(0),U,3)]"""",$P(^(0),U,7)=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE""),$P(^(0),U,2)=""O"",$P(^(0),U,4)'=5,$D(^(""IT"",""AB"")) D EN3^PRCHNPO6"
     18 D ^DIC K DIC G:Y<0 Q S PRCHSY=+Y,PRCHSY(0)=Y(0),Y(0)=^PRCS(410,+Y,0),PRCHSX=$P(Y(0),U,1) I $D(^(1)),$P(^(1),U,3)="EM" W $C(7),!,"*** EMERGENCY ***"
     19 ;I $D(^PRCS(410,+Y,0)),$P(^(0),U,4)=5 W !?3,"This is an Issue Book Order, and it can't be processed into a Purchase Order." Q
     20 ;
     21EN1 S PRCHRFQT=$$DATE^PRC0C($P(Y(0),"^",11),"I"),PRCHRFQT=$P(PRCHRFQT,U,1,2)
     22 S PRC("BBFY")=+$$DATE^PRC0C($P(^PRCS(410,+Y,3),"^",11),"I")
     23 ;S PRCHCFQT=$$DATE^PRC0C($P(^PRC(420,PRC("SITE"),0),U,9),"I"),PRCHCFQT=$P(PRCHCFQT,U,1,2)
     24 S PRCHPFQT=$$DATE^PRC0C($P(^PRC(442,PRCHPO,1),"^",15),"I"),PRCHPFQT=$P(PRCHPFQT,U,1,2)
     25 I PRCHRFQT'=PRCHPFQT W !,?10,"The Fiscal Year and Quarter on this 2237 is not",!,?10,"compatible with the PO Date.",!,$C(7) K PRCHRFQT,PRCHPFQT G EN
     26 K PRCHRFQT,PRCHPFQT
     27 I $P(^PRC(442,PRCHPO,0),U,3)]"",+$P(^PRC(442,PRCHPO,0),U,3)'=+$P(^PRCS(410,PRCHSY,3),U,1) W !?3,"Fund Control Point for this 2237 doesn't match the existing FCP in P.O.",$C(7) G EN
     28 I $P(^PRC(442,PRCHPO,0),U,5)]"",+$P(^PRC(442,PRCHPO,0),U,5)'=+$P(^PRCS(410,PRCHSY,3),U,3) W !?3,"Cost Center for this 2237 doesn't match the Cost Center in P.O.",$C(7) G EN
     29 S X="",Z="" I $D(^PRC(420,PRC("SITE"),1,+^PRCS(410,PRCHSY,3),0)) S X=$P(^(0),U,12),Z=$P(^(0),U,18)
     30 I X'=2 S:Z'="" $P(^PRC(442,PRCHPO,17),U,1)=$E(Z,1,3) I Z="" W $C(7),!?3,"Fund Control point is missing LOG Department Number!!" G EN
     31 I X I PRCHN("MP")=4!((X=3)&(PRCHN("MP")=3)) S Y=$P(^PRCD(442.5,PRCHN("MP"),0),U,1) W $C(7),!?3,"This Fund Control Point is not valid for a "_Y_" order." G EN
     32 S EN=0 I $D(^PRC(411,"UP",PRC("SITE"))) D  G EN:EN=1
     33 .I $P($G(^PRCS(410,+Y,0)),U,10)="" W $C(7),!!?3,"This 2237 does not have a substation.",! S EN=1 Q
     34 .I $P($G(^PRCS(410,+Y,0)),U,10)'=$P($G(^PRC(442,PRCHPO,23)),U,7) W $C(7),!!?3,"The substation on this 2237 does not match the substation entered",!?3,"on this "_$S($D(PRCHNRQ):"requisition.",1:"purchase order."),! S EN=1
     35 D SPRMK^PRCHNPO6
     36 ;
     37N Q:'PRCHSZ  K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1 W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX)
     38 F I=1:1 S X=$P(PRCHX,",",I) Q:X=""  I +X'=X S X(1)=$P(X,":",1),X(2)=$P(X,":",2) K:+X(1)'=X(1)!(+X(2)'=X(2))!'(X(1)<X(2)) PRCHX Q:'$D(PRCHX)  S $P(PRCHX,",",I)=X(1)_":1:"_X(2)
     39 I '$D(PRCHX) W " ??",$C(7) G N
     40 S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) X "F I="_PRCHX_" D IT Q:'$O(^TMP($J,""PRCHS"",0))" G:'$O(^TMP($J,"PRCHS",0)) N S ^(0)=J
     41 ;
     423 G 2:J=+^PRCS(410,PRCHSY,10),Q:'$O(^TMP($J,"PRCHS",0)) W !,"A new 2237 will now be created with the following items: " F K=0:0 S K=$O(PRCHSIT(K)) Q:'K  W !?3,PRCHSIT(K)
     43 S %A="     Do you wish to proceed",%B="",%=1 D ^PRCFYN I %'=1 G N
     44 Q:$D(PRCHG)  S PRCHSIT=J,PRCHS=PRCHSY D WAIT^DICD,^PRCHSP D:PRCHSY=-1 ERR D:PRCHSY=-3 ERR1 D:PRCHSY=-2 ERR2 G:PRCHSY<0 EN D EN4^PRCHNPO2
     45 G EN
     46 ;
     471 S I=0 F  S I=$O(^PRCS(410,PRCHSY,"IT","AB",I)) Q:I=""  D IT
     48 S:$O(^TMP($J,"PRCHS",0)) ^(0)=J
     49 G 3
     50 ;
     512 Q:$D(PRCHG)  S PRCHSIT=J,PRCHS="" D WAIT^DICD,^PRCHSP1
     52 D:PRCHSY=-1 ERR
     53 D:PRCHSY=-2 ERR2
     54 D:PRCHSY=-3 ERR1
     55 G:PRCHSY<0 EN
     56 D EN4^PRCHNPO2
     57 G EN
     58 ;
     59IT I $D(^PRCS(410,PRCHSY,"IT","AB",I)),$D(^PRCS(410,PRCHSY,"IT",$O(^(I,0)),0)) S ^TMP($J,"PRCHS",I)="",J=J+1 S:$L(PRCHSIT(K))>72 K=K+1,PRCHSIT(K)="" S PRCHSIT(K)=PRCHSIT(K)_I_"," Q
     60 W !?5,"** ",I," IS AN INVALID LINE ITEM NUMBER",$C(7) K ^TMP($J,"PRCHS")
     61 Q
     62 ;
     63HLP W !?3,"ENTER A LINE ITEM NUMBER IN THE FOLLOWING FORMAT:  1,2,3,4 OR 1:4 ",!?5," OR ENTER 'A' FOR ALL LINE ITEMS " S DIC="^PRCS(410,+PRCHSY,""IT"",",DIC(0)="E",X="??",D="AB" D IX^DIC K DIC G N
     64 Q
     65 ;
     66Q S (DA,D0)=PRCHPO K C,DIC,X,PRCH,PRCHD,PRCHS,PRCHSP,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHSZ,PRCHX,^TMP($J,"PRCHS"),EN,Y
     67 S:0 Y="@1" ;<<< Removed the SET Y="@1" from this routine and put it into the template PRCH2138. <<<
     68 Q
     69 ;
     70DT S X="T" D ^%DT S DT=Y
     71 Q
     72 ;
     73EN2 ;CHECKS FCP PARAMETERS & SET Y, CALLED FROM PRCH2138,PRCHIFREG
     74 S PRCHN("SFC")=+$P(^PRC(442,DA,0),"^",19)
     75 S $P(^PRC(442,DA,18),U,2)=$S((PRCHN("SFC")=2)&(PRCHN("MP")=12):"B",PRCHN("SFC")=2:"A",PRCHN("SFC")=3:"J",1:"")
     76 Q
     77 ;
     78ERR W !,$C(7),"Cannot get a transaction number at this time for the new transaction being split",!,"out.  Try again later!"
     79 Q
     80 ;
     81ERR1 W !,$C(7),"Cannot find the 2237 you selected in file 410."
     82 Q
     83 ;
     84ERR2 W !,$C(7),"Not continuing with this 2237."
     85 Q
     86 ;
     87VENMSG ;mesasge to alert users that vendors don't match and that IMF will
     88 ;be updated.
     89 W !!,"NOTE-Vendors on PO and 2237 don't match.  If you proceed IMF info"," will be used.  If there is no IMF entry for the item for this vendor one will ","be created."
     90 N % S %=0
     91 W !,"Would you like to proceed" D YN^DICN W !! I %'=1 S PRCHFLG=1
     92 Q
Note: See TracChangeset for help on using the changeset viewer.