source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO2.m@ 1464

Last change on this file since 1464 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1PRCHNPO2 ;WISC/RSD/RHD-CONT. OF NEW PO ;12/1/93 09:41
2V ;;5.1;IFCAP;**16**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN1 ;ASK REQUEST NUMBER FOR IMPREST FUND INPUT TEMPLATE
6 S PRCHSZ=0 D EN0^PRCHNPO3 G Q:'$D(PRCHSY) S PRCHS="",PRCHJ=+$G(^PRCS(410,PRCHSY,10)) D MV1^PRCHSP1,EN4
7 Q
8 ;
9EN2 ;SCREEN FOR BREAKOUT CODE IN FILE 442
10 S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0,Z2="",Z5=$E(PRCHN("TC")) G:$P(^(0),U,3)'=PRCHDT EN2Q F ZI=0:0 S ZI=$O(^PRC(442,PRCHPO,9,DA,1,ZI)) Q:'ZI S Z2=Z2_$P($G(^PRCD(420.6,ZI,0)),U,1)
11 I +PRCHN("MB")'<4!(Z5["F") S:Z1="O"&(Z2="") Z0=1 G EN2Q
12 I +PRCHN("MB")=3!(+PRCHN("MB")=2&("CDE"[Z5))!(+PRCHN("MB")=1&("DE"[Z5)) S Z0=$S(Z1="O"&(Z2=""):1,"MWVY"[Z1&(Z2'["O"):1,1:0) G EN2Q
13 I +PRCHN("MB")=1,Z5["C" S Z0=$S(Z1="O"&(Z2=""):1,Z1="M"&(Z2'["N")&(Z2'["O"):1,Z1="N"&("YVWYVYWVY"[Z2):1,"VWY"[Z1&(Z2'["O"):1,1:0)
14 G:"AB"'[Z5 EN2Q
15 I +PRCHN("MB")=2 S Z0=$S(Z1="O"&(Z2=""):1,Z1="J"&(PRCHN("LSA")="Y")&(Z2'["O"):1,"MWVY"[Z1&(Z2'["O"):1,1:0)
16 I +PRCHN("MB")=1 D EN2Z S Z0=$S(Z1="O"&(Z2=""):1,Z1="G"&Z3:1,Z1="H"&Z3:1,Z1="J"&(PRCHN("LSA")="Y"&Z3):1,Z1="K"&(PRCHN("LSA")="Y"&Z3):1,Z1="M"&(Z2'["N")&(Z2'["O"):1,Z1="N"&("YVWYVYWVY"[Z2):1,"VWY"[Z1&(Z2'["O"):1,1:0)
17EN2Q I Z0
18 K Z0,Z1,Z2,Z3,Z4,ZI
19 Q
20 ;
21EN2Z S Z3=1 F ZI=1:1:$L(Z2) Q:'Z3 S Z4=$E(Z2,ZI) I "MVWY"'[Z4 S Z3=0
22 Q
23 ;
24EN3 ;DISPLAYS BREAKOUT CODES,CALLED FROM TEMPLATE PRCHAMT
25 I $O(PRCHB(0)) S ^PRC(442,PRCHPO,9,DA,1,0)=PRCHB(0) F I=0:0 S I=$O(PRCHB(I)) Q:'I S:$P(^PRCD(420.6,+I,0),"^",5)'="N" ^PRC(442,PRCHPO,9,DA,1,I,0)=I,^PRC(442,PRCHPO,9,DA,1,"B",I,I)=""
26 S I=$P(^PRC(442,PRCHPO,9,DA,0),"^",2),PRCHN("TC")=$P($G(^PRCD(420.6,+I,0)),"^",1),I=0 W !?3,"Possible Breakout Codes: "
27 F Y=49:0 S Y=$O(^PRCD(420.6,Y)) Q:Y>100 D EN2 I $T W:I "," W $P(^PRCD(420.6,Y,0),U,1) S I=I+1
28 W ! K Z,Y,Z1
29 Q
30 ;
31EN4 ;CALLED FROM PRCHNPO3, ADDS COMMENTS
32 G Q:'$D(PRCHSY),LST1:'PRCHSP I '$D(^PRCS(410,PRCHSP)) S PRCHSP="" G LST1
33 S X=$P(^PRCS(410,PRCHSY,4),U,8),$P(^(4),U,1)=0,$P(^(4),U,8)=0,X(1)=$P(^PRCS(410,PRCHSP,4),U,8)+X,$P(^(4),U,1)=X(1),$P(^(4),U,8)=X(1),PRCHSX(1)=$P(^(0),U,1)
34 I $P(^PRCS(410,PRCHSY,7),U,6)]"" D
35 . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,3) D REMOVE^PRCSC1(PRCHSY),ENCODE^PRCSC1(PRCHSY,XX,.X) Q
36 I $P(^PRCS(410,PRCHSY,7),U,9)]"" D
37 . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,8) D REMOVE^PRCSC3(PRCHSY),ENCODE^PRCSC3(PRCHSY,XX) Q
38 I $P(^PRCS(410,PRCHSP,7),U,6)]"" D
39 . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,3) D REMOVE^PRCSC1(PRCHSP),ENCODE^PRCSC1(PRCHSP,XX) Q
40 I $P(^PRCS(410,PRCHSP,7),U,9)]"" D
41 . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,8) D REMOVE^PRCSC3(PRCHSP),ENCODE^PRCSC3(PRCHSP,XX) Q
42 S J=0 F I=0:0 S I=$O(^PRCS(410,PRCHSY,"CO",I)) Q:'I S J=J+1
43 S J=J+1,^PRCS(410,PRCHSY,"CO",J,0)=" THE COST OF THIS REQUEST, $"_X_" ,HAS BEEN CARRIED FORWARD TO TRANSACTION "_PRCHSX(1),^PRCS(410,PRCHSY,"CO",0)="^^"_J_U_J_U_DT_"^^"
44 S J=0 F I=0:0 S I=$O(^PRCS(410,PRCHSP,"CO",I)) Q:'I S J=J+1
45 S J=J+1,^PRCS(410,PRCHSP,"CO",J,0)=" THE COST OF THIS REQUEST, $"_X(1)_" , REFLECTS ORIGINAL COST PLUS, $"_X_" FROM TRANSACTION "_PRCHSX,^PRCS(410,PRCHSP,"CO",0)="^^"_J_U_J_U_DT_"^^"
46 ;
47LST1 S:'PRCHSP $P(^PRC(442,PRCHPO,0),U,12)=PRCHSY I '$D(^PRC(442,PRCHPO,13)) S ^(13,0)="^442.14PA^0^0"
48 I '$D(^PRC(442,PRCHPO,13,PRCHSY,0)) S ^(0)=PRCHSY(0) D REMOVE^PRCHES0(PRCHPO,PRCHSY),ENCODE^PRCHES0(PRCHPO,PRCHSY,$P(PRCHSY(0),U,2),.Y) G QQ:Y<1 D
49 .S $P(^(0),U,3,4)=PRCHSY_U_($P(^PRC(442,PRCHPO,13,0),U,4)+1) S:$P(PRCHSY(0),U,11)]"" ^PRC(442,"G",$P(PRCHSY(0),U,11),PRCHPO,PRCHSY)="" Q
50 I PRCHS W ! S %A="Want to print the new 2237, "_PRCHSX_" ",%B="",%=2 D ^PRCFYN I %=1 S DA=PRCHSY,PRCSF=1 D PRF1^PRCSP1 K PRCSF
51 ;
52Q S (DA,D0)=PRCHPO,Y="@1" K DIC,X,PRCH,PRCHD,PRCHS,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHX,^TMP($J,"PRCHS")
53 Q
54 ;
55EN6 ;DISPLAYS BUSINESS SIZE,CALLED FROM PRCHNPO1
56 ;When Source Code is 5, Bus Type is stuffed in as 4 'Other Entities' via
57 ;template PRCHAMT89 therefore quit & do not display Bus Type
58 Q:$G(PRCHSC)=5
59 S PRCHVAR=$S(PRCHDT:8.3,1:8.2)
60 I $D(^DD(440,PRCHVAR,0)),$L(PRCHN("MB"))=1 S Z=$P(^(0),U,3) F J=1:1 S Z1=$P(Z,";",J) Q:Z1="" I $P(Z1,":",1)=PRCHN("MB") S PRCHN("MB")=PRCHN("MB")_" "_$P(Z1,":",2)
61 I PRCHN("MB")="" W !?3,"Business Type is undefined for this vendor!",$C(7) K PRCHPO,Z,Z1 Q
62 W !?3,"BUSINESS TYPE: ",PRCHN("MB") K Z,Z1
63 Q
64 ;
65EN7 ;SCREEN OF TYPE CODE
66 S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0 I $P(^(0),U,3)'=PRCHDT S Z0=0 G EN7Q
67 I $E(PRCH,1,2)="GS" S Z0=$S(Z1["D"&(Z1[+PRCHN("MB")):1,1:0) G EN7Q
68 I $E(PRCH,1,4)="V797" S Z0=$S(Z1[+PRCHN("MB")&("ABC"[$E(Z1)):1,1:0) G EN7Q
69 I $E(PRCH,1,4)=".OM" S Z0=$S(Z1[+PRCHN("MB")&("ABCX"[$E(Z1)):1,1:0) G EN7Q
70 I Z1[+PRCHN("MB"),Z1'["D" S Z0=1
71EN7Q I Z0
72 K Z0,Z1
73 Q
74 ;
75QQ 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 K PRCSIG,ROUTINE,DIR(0),DIR("A") G Q
76 Q
Note: See TracBrowser for help on using the repository browser.