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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO2 4945 printed Dec 13, 2024@02:08:55 Page 2
PRCHNPO2 ;WISC/RSD/RHD-CONT. OF NEW PO ;12/1/93 09:41
V ;;5.1;IFCAP;**16**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
EN1 ;ASK REQUEST NUMBER FOR IMPREST FUND INPUT TEMPLATE
+1 SET PRCHSZ=0
DO EN0^PRCHNPO3
if '$DATA(PRCHSY)
GOTO Q
SET PRCHS=""
SET PRCHJ=+$GET(^PRCS(410,PRCHSY,10))
DO MV1^PRCHSP1
DO EN4
+2 QUIT
+3 ;
EN2 ;SCREEN FOR BREAKOUT CODE IN FILE 442
+1 SET Z1=$PIECE(^PRCD(420.6,Y,0),U,1)
SET Z0=0
SET Z2=""
SET Z5=$EXTRACT(PRCHN("TC"))
if $PIECE(^(0),U,3)'=PRCHDT
GOTO EN2Q
FOR ZI=0:0
SET ZI=$ORDER(^PRC(442,PRCHPO,9,DA,1,ZI))
if 'ZI
QUIT
SET Z2=Z2_$PIECE($GET(^PRCD(420.6,ZI,0)),U,1)
+2 IF +PRCHN("MB")'<4!(Z5["F")
if Z1="O"&(Z2="")
SET Z0=1
GOTO EN2Q
+3 IF +PRCHN("MB")=3!(+PRCHN("MB")=2&("CDE"[Z5))!(+PRCHN("MB")=1&("DE"[Z5))
SET Z0=$SELECT(Z1="O"&(Z2=""):1,"MWVY"[Z1&(Z2'["O"):1,1:0)
GOTO EN2Q
+4 IF +PRCHN("MB")=1
IF Z5["C"
SET Z0=$SELECT(Z1="O"&(Z2=""):1,Z1="M"&(Z2'["N")&(Z2'["O"):1,Z1="N"&("YVWYVYWVY"[Z2):1,"VWY"[Z1&(Z2'["O"):1,1:0)
+5 if "AB"'[Z5
GOTO EN2Q
+6 IF +PRCHN("MB")=2
SET Z0=$SELECT(Z1="O"&(Z2=""):1,Z1="J"&(PRCHN("LSA")="Y")&(Z2'["O"):1,"MWVY"[Z1&(Z2'["O"):1,1:0)
+7 IF +PRCHN("MB")=1
DO EN2Z
SET Z0=$SELECT(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 IF Z0
+1 KILL Z0,Z1,Z2,Z3,Z4,ZI
+2 QUIT
+3 ;
EN2Z SET Z3=1
FOR ZI=1:1:$LENGTH(Z2)
if 'Z3
QUIT
SET Z4=$EXTRACT(Z2,ZI)
IF "MVWY"'[Z4
SET Z3=0
+1 QUIT
+2 ;
EN3 ;DISPLAYS BREAKOUT CODES,CALLED FROM TEMPLATE PRCHAMT
+1 IF $ORDER(PRCHB(0))
SET ^PRC(442,PRCHPO,9,DA,1,0)=PRCHB(0)
FOR I=0:0
SET I=$ORDER(PRCHB(I))
if 'I
QUIT
if $PIECE(^PRCD(420.6,+I,0),"^",5)'="N"
SET ^PRC(442,PRCHPO,9,DA,1,I,0)=I
SET ^PRC(442,PRCHPO,9,DA,1,"B",I,I)=""
+2 SET I=$PIECE(^PRC(442,PRCHPO,9,DA,0),"^",2)
SET PRCHN("TC")=$PIECE($GET(^PRCD(420.6,+I,0)),"^",1)
SET I=0
WRITE !?3,"Possible Breakout Codes: "
+3 FOR Y=49:0
SET Y=$ORDER(^PRCD(420.6,Y))
if Y>100
QUIT
DO EN2
IF $TEST
if I
WRITE ","
WRITE $PIECE(^PRCD(420.6,Y,0),U,1)
SET I=I+1
+4 WRITE !
KILL Z,Y,Z1
+5 QUIT
+6 ;
EN4 ;CALLED FROM PRCHNPO3, ADDS COMMENTS
+1 if '$DATA(PRCHSY)
GOTO Q
if 'PRCHSP
GOTO LST1
IF '$DATA(^PRCS(410,PRCHSP))
SET PRCHSP=""
GOTO LST1
+2 SET X=$PIECE(^PRCS(410,PRCHSY,4),U,8)
SET $PIECE(^(4),U,1)=0
SET $PIECE(^(4),U,8)=0
SET X(1)=$PIECE(^PRCS(410,PRCHSP,4),U,8)+X
SET $PIECE(^(4),U,1)=X(1)
SET $PIECE(^(4),U,8)=X(1)
SET PRCHSX(1)=$PIECE(^(0),U,1)
+3 IF $PIECE(^PRCS(410,PRCHSY,7),U,6)]""
Begin DoDot:1
+4 NEW X,XX
SET XX=$PIECE(^PRCS(410,PRCHSY,7),U,3)
DO REMOVE^PRCSC1(PRCHSY)
DO ENCODE^PRCSC1(PRCHSY,XX,.X)
QUIT
End DoDot:1
+5 IF $PIECE(^PRCS(410,PRCHSY,7),U,9)]""
Begin DoDot:1
+6 NEW X,XX
SET XX=$PIECE(^PRCS(410,PRCHSY,7),U,8)
DO REMOVE^PRCSC3(PRCHSY)
DO ENCODE^PRCSC3(PRCHSY,XX)
QUIT
End DoDot:1
+7 IF $PIECE(^PRCS(410,PRCHSP,7),U,6)]""
Begin DoDot:1
+8 NEW X,XX
SET XX=$PIECE(^PRCS(410,PRCHSY,7),U,3)
DO REMOVE^PRCSC1(PRCHSP)
DO ENCODE^PRCSC1(PRCHSP,XX)
QUIT
End DoDot:1
+9 IF $PIECE(^PRCS(410,PRCHSP,7),U,9)]""
Begin DoDot:1
+10 NEW X,XX
SET XX=$PIECE(^PRCS(410,PRCHSY,7),U,8)
DO REMOVE^PRCSC3(PRCHSP)
DO ENCODE^PRCSC3(PRCHSP,XX)
QUIT
End DoDot:1
+11 SET J=0
FOR I=0:0
SET I=$ORDER(^PRCS(410,PRCHSY,"CO",I))
if 'I
QUIT
SET J=J+1
+12 SET J=J+1
SET ^PRCS(410,PRCHSY,"CO",J,0)=" THE COST OF THIS REQUEST, $"_X_" ,HAS BEEN CARRIED FORWARD TO TRANSACTION "_PRCHSX(1)
SET ^PRCS(410,PRCHSY,"CO",0)="^^"_J_U_J_U_DT_"^^"
+13 SET J=0
FOR I=0:0
SET I=$ORDER(^PRCS(410,PRCHSP,"CO",I))
if 'I
QUIT
SET J=J+1
+14 SET J=J+1
SET ^PRCS(410,PRCHSP,"CO",J,0)=" THE COST OF THIS REQUEST, $"_X(1)_" , REFLECTS ORIGINAL COST PLUS, $"_X_" FROM TRANSACTION "_PRCHSX
SET ^PRCS(410,PRCHSP,"CO",0)="^^"_J_U_J_U_DT_"^^"
+15 ;
LST1 if 'PRCHSP
SET $PIECE(^PRC(442,PRCHPO,0),U,12)=PRCHSY
IF '$DATA(^PRC(442,PRCHPO,13))
SET ^(13,0)="^442.14PA^0^0"
+1 IF '$DATA(^PRC(442,PRCHPO,13,PRCHSY,0))
SET ^(0)=PRCHSY(0)
DO REMOVE^PRCHES0(PRCHPO,PRCHSY)
DO ENCODE^PRCHES0(PRCHPO,PRCHSY,$PIECE(PRCHSY(0),U,2),.Y)
if Y<1
GOTO QQ
Begin DoDot:1
+2 SET $PIECE(^(0),U,3,4)=PRCHSY_U_($PIECE(^PRC(442,PRCHPO,13,0),U,4)+1)
if $PIECE(PRCHSY(0),U,11)]""
SET ^PRC(442,"G",$PIECE(PRCHSY(0),U,11),PRCHPO,PRCHSY)=""
QUIT
End DoDot:1
+3 IF PRCHS
WRITE !
SET %A="Want to print the new 2237, "_PRCHSX_" "
SET %B=""
SET %=2
DO ^PRCFYN
IF %=1
SET DA=PRCHSY
SET PRCSF=1
DO PRF1^PRCSP1
KILL PRCSF
+4 ;
Q SET (DA,D0)=PRCHPO
SET Y="@1"
KILL DIC,X,PRCH,PRCHD,PRCHS,PRCHSIT,PRCHJ,PRCHK,PRCHSLI,PRCHSX,PRCHSY,PRCHX,^TMP($JOB,"PRCHS")
+1 QUIT
+2 ;
EN6 ;DISPLAYS BUSINESS SIZE,CALLED FROM PRCHNPO1
+1 ;When Source Code is 5, Bus Type is stuffed in as 4 'Other Entities' via
+2 ;template PRCHAMT89 therefore quit & do not display Bus Type
+3 if $GET(PRCHSC)=5
QUIT
+4 SET PRCHVAR=$SELECT(PRCHDT:8.3,1:8.2)
+5 IF $DATA(^DD(440,PRCHVAR,0))
IF $LENGTH(PRCHN("MB"))=1
SET Z=$PIECE(^(0),U,3)
FOR J=1:1
SET Z1=$PIECE(Z,";",J)
if Z1=""
QUIT
IF $PIECE(Z1,":",1)=PRCHN("MB")
SET PRCHN("MB")=PRCHN("MB")_" "_$PIECE(Z1,":",2)
+6 IF PRCHN("MB")=""
WRITE !?3,"Business Type is undefined for this vendor!",$CHAR(7)
KILL PRCHPO,Z,Z1
QUIT
+7 WRITE !?3,"BUSINESS TYPE: ",PRCHN("MB")
KILL Z,Z1
+8 QUIT
+9 ;
EN7 ;SCREEN OF TYPE CODE
+1 SET Z1=$PIECE(^PRCD(420.6,Y,0),U,1)
SET Z0=0
IF $PIECE(^(0),U,3)'=PRCHDT
SET Z0=0
GOTO EN7Q
+2 IF $EXTRACT(PRCH,1,2)="GS"
SET Z0=$SELECT(Z1["D"&(Z1[+PRCHN("MB")):1,1:0)
GOTO EN7Q
+3 IF $EXTRACT(PRCH,1,4)="V797"
SET Z0=$SELECT(Z1[+PRCHN("MB")&("ABC"[$EXTRACT(Z1)):1,1:0)
GOTO EN7Q
+4 IF $EXTRACT(PRCH,1,4)=".OM"
SET Z0=$SELECT(Z1[+PRCHN("MB")&("ABCX"[$EXTRACT(Z1)):1,1:0)
GOTO EN7Q
+5 IF Z1[+PRCHN("MB")
IF Z1'["D"
SET Z0=1
EN7Q IF Z0
+1 KILL Z0,Z1
+2 QUIT
+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
KILL PRCSIG,ROUTINE,DIR(0),DIR("A")
GOTO Q
+1 QUIT
