source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO2.m

PRCHNPO2 ;WISC/RSD/RHD-CONT. OF NEW PO ;12/1/93  09:41
V ;;5.1;IFCAP;**16**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
EN1 ;ASK REQUEST NUMBER FOR IMPREST FUND INPUT TEMPLATE
 S PRCHSZ=0 D EN0^PRCHNPO3 G Q:'$D(PRCHSY) S PRCHS="",PRCHJ=+$G(^PRCS(410,PRCHSY,10)) D MV1^PRCHSP1,EN4
 Q
 ;
EN2 ;SCREEN FOR BREAKOUT CODE IN FILE 442
 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)
 I +PRCHN("MB")'<4!(Z5["F") S:Z1="O"&(Z2="") Z0=1 G EN2Q
 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
 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)
 G:"AB"'[Z5 EN2Q
 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)
 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)
EN2Q I Z0
 K Z0,Z1,Z2,Z3,Z4,ZI
 Q
 ;
EN2Z S Z3=1 F ZI=1:1:$L(Z2) Q:'Z3  S Z4=$E(Z2,ZI) I "MVWY"'[Z4 S Z3=0
 Q
 ;
EN3 ;DISPLAYS BREAKOUT CODES,CALLED FROM TEMPLATE PRCHAMT
 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)=""
 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: "
 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
 W ! K Z,Y,Z1
 Q
 ;
EN4 ;CALLED FROM PRCHNPO3, ADDS COMMENTS
 G Q:'$D(PRCHSY),LST1:'PRCHSP I '$D(^PRCS(410,PRCHSP)) S PRCHSP="" G LST1
 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)
 I $P(^PRCS(410,PRCHSY,7),U,6)]"" D
 . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,3) D REMOVE^PRCSC1(PRCHSY),ENCODE^PRCSC1(PRCHSY,XX,.X) Q
 I $P(^PRCS(410,PRCHSY,7),U,9)]"" D
 . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,8) D REMOVE^PRCSC3(PRCHSY),ENCODE^PRCSC3(PRCHSY,XX) Q
 I $P(^PRCS(410,PRCHSP,7),U,6)]"" D
 . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,3)  D REMOVE^PRCSC1(PRCHSP),ENCODE^PRCSC1(PRCHSP,XX) Q
 I $P(^PRCS(410,PRCHSP,7),U,9)]"" D
 . N X,XX S XX=$P(^PRCS(410,PRCHSY,7),U,8) D REMOVE^PRCSC3(PRCHSP),ENCODE^PRCSC3(PRCHSP,XX) Q
 S J=0 F I=0:0 S I=$O(^PRCS(410,PRCHSY,"CO",I)) Q:'I  S J=J+1
 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_"^^"
 S J=0 F I=0:0 S I=$O(^PRCS(410,PRCHSP,"CO",I)) Q:'I  S J=J+1
 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_"^^"
 ;
LST1 S:'PRCHSP $P(^PRC(442,PRCHPO,0),U,12)=PRCHSY I '$D(^PRC(442,PRCHPO,13)) S ^(13,0)="^442.14PA^0^0"
 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
 .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
 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
 ;
Q S (DA,D0)=PRCHPO,Y="@1" K DIC,X,PRCH,PRCHD,PRCHS,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHX,^TMP($J,"PRCHS")
 Q
 ;
EN6 ;DISPLAYS BUSINESS SIZE,CALLED FROM PRCHNPO1
 ;When Source Code is 5, Bus Type is stuffed in as 4 'Other Entities' via
 ;template PRCHAMT89 therefore quit & do not display Bus Type
 Q:$G(PRCHSC)=5
 S PRCHVAR=$S(PRCHDT:8.3,1:8.2)
 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)
 I PRCHN("MB")="" W !?3,"Business Type is undefined for this vendor!",$C(7) K PRCHPO,Z,Z1 Q
 W !?3,"BUSINESS TYPE: ",PRCHN("MB") K Z,Z1
 Q
 ;
EN7 ;SCREEN OF TYPE CODE
 S Z1=$P(^PRCD(420.6,Y,0),U,1),Z0=0 I $P(^(0),U,3)'=PRCHDT S Z0=0 G EN7Q
 I $E(PRCH,1,2)="GS" S Z0=$S(Z1["D"&(Z1[+PRCHN("MB")):1,1:0) G EN7Q
 I $E(PRCH,1,4)="V797" S Z0=$S(Z1[+PRCHN("MB")&("ABC"[$E(Z1)):1,1:0) G EN7Q
 I $E(PRCH,1,4)=".OM" S Z0=$S(Z1[+PRCHN("MB")&("ABCX"[$E(Z1)):1,1:0) G EN7Q
 I Z1[+PRCHN("MB"),Z1'["D" S Z0=1
EN7Q I Z0
 K Z0,Z1
 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 K PRCSIG,ROUTINE,DIR(0),DIR("A") G Q
 Q